feat: moved services from source to here, still untested: vsftpd,

mongodb, mysql, nginx
This commit is contained in:
Mahdi Dibaiee 2017-03-18 18:06:18 +03:30
parent a5cc8582fc
commit 5550b17522
22 changed files with 990 additions and 8 deletions

23
.gitignore vendored Normal file
View File

@ -0,0 +1,23 @@
#### joe made this: http://goel.io/joe
#### haskell ####
dist
dist-*
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
.HTF/

View File

@ -2,11 +2,8 @@
{ {
"name": "nginx", "name": "nginx",
"service": "nginx", "service": "nginx",
"config": "/etc/nginx/",
"version": "0.1.0", "version": "0.1.0",
"dependencies": { "dependencies": ["letsencrypt"],
"letsencrypt": "^0.1.0"
},
"packages": { "packages": {
"_": ["nginx"] "_": ["nginx"]
}, },
@ -15,9 +12,8 @@
{ {
"name": "vsftpd", "name": "vsftpd",
"config": "/etc/vsftpd.conf",
"version": "0.1.0", "version": "0.1.0",
"dependencies": {}, "dependencies": [],
"service": "vsftpd", "service": "vsftpd",
"packages": { "packages": {
"_": ["vsftpd"] "_": ["vsftpd"]
@ -27,13 +23,23 @@
{ {
"name": "mysql", "name": "mysql",
"config": "/etc/mysql/",
"version": "0.1.0", "version": "0.1.0",
"dependencies": {}, "dependencies": [],
"service": "mysql", "service": "mysql",
"packages": { "packages": {
"_": ["mysql"] "_": ["mysql"]
}, },
"category": "database" "category": "database"
},
{
"name": "mongodb",
"version": "0.1.0",
"dependencies": [],
"service": "mongodb",
"packages": {
"_": ["mongodb"]
},
"category": "database"
} }
] ]

View File

@ -0,0 +1,24 @@
name: serverman-service-mongodb
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/mdibaiee/mongodb#readme
license: GPL-3
license-file: LICENSE
author: Mahdi Dibaiee
maintainer: mahdi@theread.me
copyright: 2017 Mahdi Dibaiee
category: mongodb
build-type: Simple
cabal-version: >=1.10
executable mongodb
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, data-default-class
, mtl
, mongoDB >= 2.1.1.1 && < 3
, bytestring
, text

View File

@ -0,0 +1,62 @@
{-# LANGUAGE NamedFieldPuns #-}
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils hiding (execute)
import Database.MongoDB
import qualified Data.ByteString.Char8 as BS
import Data.List hiding (delete)
import qualified Data.Text as T
import Control.Monad
import Control.Monad.State
import System.IO.Error
call :: Service -> App ()
call s@(Service { name, version, service })= do
(AppState { arguments }) <- get
let params@(DatabaseParams { database, dummyData, user, pass, host }) = toDBParams arguments
liftIO $ do
result <- tryIOError $ connect (readHostPort databaseHost)
case result of
Right pipe -> do
e <- access pipe master (T.pack database) run
close pipe
Left err -> do
putStrLn $ show err
putStrLn $ "[Error] could not connect to MongoDB server " ++ databaseHost
where
run = do
when dummyData $ do
clearCollection
insertToCollection
return ()
clearCollection = delete (select [] (T.pack collectionName))
where (collectionName, _, _) = dummy
insertToCollection = insertMany (T.pack collectionName) records
where
(collectionName, definitions, rows) = dummy
records = map (\row -> zipWith (\def value -> def =: row) (map T.pack definitions) row) rows
createDummyTables = createTable dummy
where
createTable (tableName, columns, rows) = "CREATE TABLE IF NOT EXISTS " ++ tableName ++ "(" ++ intercalate "," (map columnDef columns) ++ ")";
columnDef "children" = "children INT"
columnDef "birth_date" = "birth_date DATETIME"
columnDef "gender" = "gender ENUM('Male', 'Female')"
columnDef name = name ++ " VARCHAR(255)"
insertToDummyTables = insertTable dummy
where
insertTable (tableName, _, rows) = "INSERT INTO " ++ tableName ++ " VALUES " ++ intercalate "," (map insertRow rows)
insertRow row = "('" ++ intercalate "','" row ++ "')"
main :: IO ()
main = return ()

View File

@ -0,0 +1,68 @@
module Types (DatabaseParams(..), toDBParams, dummy) where
import System.Serverman.Utils
import Data.Default.Class
toDBParams :: [(String, Maybe String)] -> DatabaseParams
toDBParams (("database", Just value):xs) = (toDBParams xs) { database = value }
toDBParams (("user", Just value):xs) = (toDBParams xs) { user = value }
toDBParams (("pass", Just value):xs) = (toDBParams xs) { pass = value }
toDBParams (("host", Just value):xs) = (toDBParams xs) { host = value }
toDBParams (("dummy-data", Just value):xs) = (toDBParams xs) { dummyData = True }
toDBParams _ = def
data DatabaseParams = DatabaseParams { database :: String
, dummyData :: Bool
, user :: String
, pass :: String
, host :: String
} deriving (Eq, Show)
instance Default DatabaseParams where
def = DatabaseParams { database = "serverman"
, dummyData = False
, user = "serverman"
, pass = "serverman"
, host = "localhost"
}
dummy = ("serverman_users", ["first_name", "last_name", "email", "children", "birth_date", "gender"], [
["MacKenzie","Wilcox","vel.sapien.imperdiet@bibendumsedest.com","4","1997-10-30T06:29:02-08:00","Male"],
["Martha","Elliott","Phasellus@luctusetultrices.com","3","2000-03-04T00:53:32-08:00","Male"],
["Declan","Nash","ut.quam@ultriciessemmagna.net","1","1975-08-02T00:27:02-07:00","Female"],
["Kasimir","Fisher","sit.amet.consectetuer@sapien.net","2","2015-06-09T21:45:41-07:00","Male"],
["Uma","Kelley","vulputate@maurisa.ca","2","1990-05-27T06:28:00-07:00","Female"],
["Hayley","Owen","eu.eros@velnisl.org","4","2013-07-02T06:13:04-07:00","Male"],
["Pamela","Hebert","vestibulum.lorem@molestietellus.net","1","1998-01-21T05:32:18-08:00","Female"],
["Sydnee","Irwin","ultrices@consectetueradipiscing.edu","4","1984-01-15T22:55:10-08:00","Female"],
["Brandon","Sharp","non@nunc.co.uk","3","2000-06-21T10:05:13-07:00","Female"],
["Gray","Guerrero","ipsum@magnaUttincidunt.net","1","1975-12-02T06:59:56-08:00","Female"],
["Nomlanga","Mercado","dolor.Quisque.tincidunt@Donec.edu","1","2015-07-04T01:21:44-07:00","Male"],
["Luke","Frazier","Aenean.sed.pede@Etiamvestibulum.co.uk","1","2007-01-22T22:03:24-08:00","Male"],
["Cynthia","Farmer","vel@eratEtiam.co.uk","3","1975-06-20T06:40:51-07:00","Female"],
["Timothy","Hopper","magna.Praesent.interdum@Phasellusvitaemauris.org","1","1991-03-18T15:36:03-08:00","Male"],
["Graiden","Walton","est.mauris@aultricies.edu","1","1997-12-06T10:35:10-08:00","Female"],
["Abigail","Webster","elementum.dui@Duissitamet.com","4","1978-05-03T13:39:42-07:00","Female"],
["Samuel","Dyer","parturient.montes@Etiamligula.org","3","2002-08-30T21:34:17-07:00","Female"],
["May","Blackburn","montes.nascetur.ridiculus@Aliquameratvolutpat.org","1","2004-11-01T13:10:43-08:00","Female"],
["Regina","Hicks","Sed.nulla.ante@atpretium.edu","2","2005-08-28T02:52:49-07:00","Female"],
["Roth","Bright","lacus@feugiattellus.edu","4","2010-07-26T14:27:31-07:00","Male"],
["Sylvester","Chapman","Sed.eu@sitametdiam.edu","4","1975-01-23T19:36:26-08:00","Male"],
["Martin","Sharp","Nullam@Vivamusnibh.net","2","2016-10-18T23:48:20-07:00","Male"],
["Mary","Schroeder","sem.egestas.blandit@nullaatsem.com","1","1993-03-16T17:41:10-08:00","Female"],
["Blythe","Alston","amet.faucibus.ut@ornareFuscemollis.org","1","1980-09-22T04:58:53-07:00","Female"],
["Nathan","Ramsey","in.molestie@Mauris.ca","4","2006-05-07T08:30:57-07:00","Female"],
["Zelenia","Meadows","nunc@Aenean.com","3","1983-04-03T01:42:18-08:00","Female"],
["Karyn","Booker","tempor@sagittissemperNam.ca","3","2006-10-13T02:29:44-07:00","Male"],
["Hiram","Booth","semper@risusDonecegestas.ca","4","2001-10-30T19:53:13-08:00","Male"],
["Robert","Mcclure","semper@nonduinec.org","1","2012-11-14T17:32:09-08:00","Female"],
["Celeste","Callahan","convallis@NulladignissimMaecenas.edu","1","1984-08-22T22:56:35-07:00","Female"],
["Magee","Olsen","ligula.consectetuer.rhoncus@fermentumvel.com","2","1978-04-09T15:12:05-08:00","Female"],
["Dana","Mccullough","ut.sem.Nulla@eleifendnec.net","4","2000-08-23T07:54:53-07:00","Male"],
["Yen","Blanchard","et@Morbi.org","3","1997-05-09T03:30:56-07:00","Male"],
["Cora","Valdez","lorem.vitae.odio@vulputateullamcorpermagna.net","2","1998-10-24T16:06:46-07:00","Male"],
["Amela","Blackburn","vulputate.dui@ultrices.co.uk","3","2006-03-08T07:42:27-08:00","Male"],
["Dean","Blanchard","ac.tellus@nonummyipsumnon.co.uk","2","2014-12-21T14:38:37-08:00","Female"],
["Alika","Shields","est.mauris@mollis.co.uk","3","1976-11-08T22:32:16-08:00","Female"],
["Byron","Dudley","mattis@nequeNullam.org","1","1992-07-04T12:32:20-07:00","Female"],
["Noelle","Young","et.malesuada.fames@aliquetmolestietellus.net","2","2009-04-05T03:05:01-07:00","Female"]])

View File

@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-8.5
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

View File

@ -0,0 +1,22 @@
name: serverman-service-mysql
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/mdibaiee/mysql#readme
license: GPL-3
license-file: LICENSE
author: Mahdi Dibaiee
maintainer: mahdi@theread.me
copyright: 2017 Mahdi Dibaiee
category: mysql
build-type: Simple
cabal-version: >=1.10
executable mysql
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, data-default-class
, mtl
, mysql >= 0.1.4 && < 1

View File

@ -0,0 +1,56 @@
{-# LANGUAGE NamedFieldPuns #-}
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils hiding (execute)
import Types
import Database.MySQL.Base
import qualified Data.ByteString.Char8 as BS
import Data.List
import Control.Monad
import Control.Monad.State
call :: Service -> App ()
call s@(Service { name, version, service }) = do
(AppState { arguments }) <- get
let params@(DatabaseParams { database, dummyData, user, pass, host }) = toDBParams arguments
liftIO $ do
conn <- connect $ defaultConnectInfo { connectUser = user, connectPassword = pass, connectHost = host }
query conn $ BS.pack ("CREATE DATABASE IF NOT EXISTS " ++ database)
when dummyData $ do
let (tableName, _, _) = dummy
query conn $ BS.pack createDummyTables
query conn $ BS.pack clearTable
query conn $ BS.pack insertToDummyTables
putStrLn $ "Created dummy table '" ++ tableName ++ "' and filled it with data."
return ()
return ()
clearTable = "DELETE FROM " ++ tableName
where (tableName, _, _) = dummy
createDummyTables = createTable dummy
where
createTable (tableName, columns, rows) = "CREATE TABLE IF NOT EXISTS " ++ tableName ++ "(" ++ intercalate "," (map columnDef columns) ++ ")";
columnDef "children" = "children INT"
columnDef "birth_date" = "birth_date DATETIME"
columnDef "gender" = "gender ENUM('Male', 'Female')"
columnDef name = name ++ " VARCHAR(255)"
insertToDummyTables = insertTable dummy
where
insertTable (tableName, _, rows) = "INSERT INTO " ++ tableName ++ " VALUES " ++ intercalate "," (map insertRow rows)
insertRow row = "('" ++ intercalate "','" row ++ "')"
main :: IO ()
main = return ()

View File

@ -0,0 +1,68 @@
module Types (DatabaseParams(..), toDBParams, dummy) where
import System.Serverman.Utils
import Data.Default.Class
toDBParams :: [(String, Maybe String)] -> DatabaseParams
toDBParams (("database", Just value):xs) = (toDBParams xs) { database = value }
toDBParams (("user", Just value):xs) = (toDBParams xs) { user = value }
toDBParams (("pass", Just value):xs) = (toDBParams xs) { pass = value }
toDBParams (("host", Just value):xs) = (toDBParams xs) { host = value }
toDBParams (("dummy-data", Just value):xs) = (toDBParams xs) { dummyData = True }
toDBParams _ = def
data DatabaseParams = DatabaseParams { database :: String
, dummyData :: Bool
, user :: String
, pass :: String
, host :: String
} deriving (Eq, Show)
instance Default DatabaseParams where
def = DatabaseParams { database = "serverman"
, dummyData = False
, user = "serverman"
, pass = "serverman"
, host = "localhost"
}
dummy = ("serverman_users", ["first_name", "last_name", "email", "children", "birth_date", "gender"], [
["MacKenzie","Wilcox","vel.sapien.imperdiet@bibendumsedest.com","4","1997-10-30T06:29:02-08:00","Male"],
["Martha","Elliott","Phasellus@luctusetultrices.com","3","2000-03-04T00:53:32-08:00","Male"],
["Declan","Nash","ut.quam@ultriciessemmagna.net","1","1975-08-02T00:27:02-07:00","Female"],
["Kasimir","Fisher","sit.amet.consectetuer@sapien.net","2","2015-06-09T21:45:41-07:00","Male"],
["Uma","Kelley","vulputate@maurisa.ca","2","1990-05-27T06:28:00-07:00","Female"],
["Hayley","Owen","eu.eros@velnisl.org","4","2013-07-02T06:13:04-07:00","Male"],
["Pamela","Hebert","vestibulum.lorem@molestietellus.net","1","1998-01-21T05:32:18-08:00","Female"],
["Sydnee","Irwin","ultrices@consectetueradipiscing.edu","4","1984-01-15T22:55:10-08:00","Female"],
["Brandon","Sharp","non@nunc.co.uk","3","2000-06-21T10:05:13-07:00","Female"],
["Gray","Guerrero","ipsum@magnaUttincidunt.net","1","1975-12-02T06:59:56-08:00","Female"],
["Nomlanga","Mercado","dolor.Quisque.tincidunt@Donec.edu","1","2015-07-04T01:21:44-07:00","Male"],
["Luke","Frazier","Aenean.sed.pede@Etiamvestibulum.co.uk","1","2007-01-22T22:03:24-08:00","Male"],
["Cynthia","Farmer","vel@eratEtiam.co.uk","3","1975-06-20T06:40:51-07:00","Female"],
["Timothy","Hopper","magna.Praesent.interdum@Phasellusvitaemauris.org","1","1991-03-18T15:36:03-08:00","Male"],
["Graiden","Walton","est.mauris@aultricies.edu","1","1997-12-06T10:35:10-08:00","Female"],
["Abigail","Webster","elementum.dui@Duissitamet.com","4","1978-05-03T13:39:42-07:00","Female"],
["Samuel","Dyer","parturient.montes@Etiamligula.org","3","2002-08-30T21:34:17-07:00","Female"],
["May","Blackburn","montes.nascetur.ridiculus@Aliquameratvolutpat.org","1","2004-11-01T13:10:43-08:00","Female"],
["Regina","Hicks","Sed.nulla.ante@atpretium.edu","2","2005-08-28T02:52:49-07:00","Female"],
["Roth","Bright","lacus@feugiattellus.edu","4","2010-07-26T14:27:31-07:00","Male"],
["Sylvester","Chapman","Sed.eu@sitametdiam.edu","4","1975-01-23T19:36:26-08:00","Male"],
["Martin","Sharp","Nullam@Vivamusnibh.net","2","2016-10-18T23:48:20-07:00","Male"],
["Mary","Schroeder","sem.egestas.blandit@nullaatsem.com","1","1993-03-16T17:41:10-08:00","Female"],
["Blythe","Alston","amet.faucibus.ut@ornareFuscemollis.org","1","1980-09-22T04:58:53-07:00","Female"],
["Nathan","Ramsey","in.molestie@Mauris.ca","4","2006-05-07T08:30:57-07:00","Female"],
["Zelenia","Meadows","nunc@Aenean.com","3","1983-04-03T01:42:18-08:00","Female"],
["Karyn","Booker","tempor@sagittissemperNam.ca","3","2006-10-13T02:29:44-07:00","Male"],
["Hiram","Booth","semper@risusDonecegestas.ca","4","2001-10-30T19:53:13-08:00","Male"],
["Robert","Mcclure","semper@nonduinec.org","1","2012-11-14T17:32:09-08:00","Female"],
["Celeste","Callahan","convallis@NulladignissimMaecenas.edu","1","1984-08-22T22:56:35-07:00","Female"],
["Magee","Olsen","ligula.consectetuer.rhoncus@fermentumvel.com","2","1978-04-09T15:12:05-08:00","Female"],
["Dana","Mccullough","ut.sem.Nulla@eleifendnec.net","4","2000-08-23T07:54:53-07:00","Male"],
["Yen","Blanchard","et@Morbi.org","3","1997-05-09T03:30:56-07:00","Male"],
["Cora","Valdez","lorem.vitae.odio@vulputateullamcorpermagna.net","2","1998-10-24T16:06:46-07:00","Male"],
["Amela","Blackburn","vulputate.dui@ultrices.co.uk","3","2006-03-08T07:42:27-08:00","Male"],
["Dean","Blanchard","ac.tellus@nonummyipsumnon.co.uk","2","2014-12-21T14:38:37-08:00","Female"],
["Alika","Shields","est.mauris@mollis.co.uk","3","1976-11-08T22:32:16-08:00","Female"],
["Byron","Dudley","mattis@nequeNullam.org","1","1992-07-04T12:32:20-07:00","Female"],
["Noelle","Young","et.malesuada.fames@aliquetmolestietellus.net","2","2009-04-05T03:05:01-07:00","Female"]])

66
services/mysql/stack.yaml Normal file
View File

@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-8.5
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

View File

@ -0,0 +1,24 @@
name: serverman-service-nginx
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/githubuser/nginx#readme
license: GPL-3
license-file: LICENSE
author: Author name here
maintainer: example@example.com
copyright: 2017 Author name here
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md
executable nginx
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, data-default-class
, monad-control
, mtl
, free

BIN
services/nginx/src/Main Executable file

Binary file not shown.

BIN
services/nginx/src/Main.hi Normal file

Binary file not shown.

126
services/nginx/src/Main.hs Normal file
View File

@ -0,0 +1,126 @@
{-# LANGUAGE NamedFieldPuns #-}
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils
import Types
import System.Directory
import System.IO
import System.IO.Error
import System.FilePath
import System.Process
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State
import Control.Monad.Free
import Data.List
main :: IO ()
main = return ()
call :: Service -> App ()
call _ =
do
(AppState { arguments }) <- get
let params@(ServerParams { ssl, domain, directory, serverType, email }) = toServerParams arguments
-- Turn SSL off at first, because we have not yet received a certificate
let content = show (params { ssl = False, port = "80" })
config = "/etc/nginx/"
mainConfig = "/etc/nginx/nginx.conf"
parent = config </> "serverman-configs"
path = parent </> domain
targetDir = directory
createCert path cmd = do
result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", directory, "-d", domain, "--email", email, "--agree-tos", "-n"] "" False
case result of
Left _ -> if cmd == "letsencrypt" then createCert path "certbot" else return ()
Right stdout -> do
liftIO $ putStrLn stdout
when (not ("error" `isInfixOf` stdout)) $ do
liftIO $ writeFile path (show params)
liftIO . wait =<< restart
return ()
liftIO $ do
createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent
writeIncludeStatementIfMissing mainConfig parent
when ssl $ do
let sslPath = config </> "ssl.conf"
writeFileIfMissing sslPath nginxSSL
putStrLn $ "wrote ssl configuration to " ++ sslPath
writeFile path content
putStrLn $ "wrote your configuration file to " ++ path
liftIO . wait =<< restart
when ssl $ do
let dhparamPath = "/etc/ssl/certs/dhparam.pem"
dhExists <- liftIO $ doesFileExist dhparamPath
when (not dhExists) $ do
dhparam <- liftedAsync $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True
liftIO $ wait dhparam
return ()
case serverType of
Static -> do
letsencrypt <- liftedAsync $ createCert path "letsencrypt"
liftIO $ wait letsencrypt
return ()
_ -> liftIO $ do
putStrLn $ "you should use letsencrypt to create a certificate for your domain"
putStrLn $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem"
putStrLn $ "my suggestion is running this command:"
putStrLn $ "sudo letsencrypt certonly --webroot --webroot-path <YOUR_APPLICATION_DIRECTORY> -d " ++ domain
liftIO $ putStrLn $ "for more information, see: https://certbot.eff.org/"
return ()
where
restart = liftedAsync $ do
result <- restartService "nginx"
case result of
Left err -> return ()
Right _ ->
liftIO $ putStrLn $ "restarted nginx"
writeIncludeStatementIfMissing path target = do
content <- readFile path
let statement = "include " ++ target ++ "/*;"
when (not (statement `isInfixOf` content)) $ do
let newContent = appendAfter content "http {" (indent . indent $ statement)
writeFile path newContent
nginxSSL = "# from https://cipherli.st/\n\
\# and https://raymii.org/s/tutorials/Strong_SSL_Security_On_nginx.html\n\
\\n\
\ssl_protocols TLSv1 TLSv1.1 TLSv1.2;\n\
\ssl_prefer_server_ciphers on;\n\
\ssl_ciphers 'EECDH+AESGCM:EDH+AESGCM:AES256+EECDH:AES256+EDH';\n\
\ssl_ecdh_curve secp384r1;\n\
\ssl_session_cache shared:SSL:10m;\n\
\ssl_session_tickets off;\n\
\ssl_stapling on;\n\
\ssl_stapling_verify on;\n\
\resolver 8.8.8.8 8.8.4.4 valid=300s;\n\
\resolver_timeout 5s;\n\
\# Disable preloading HSTS for now. You can use the commented out header line that includes\n\
\# the 'preload' directive if you understand the implications.\n\
\#add_header Strict-Transport-Security 'max-age=63072000; includeSubdomains; preload';\n\
\add_header Strict-Transport-Security 'max-age=63072000; includeSubdomains';\n\
\add_header X-Frame-Options DENY;\n\
\add_header X-Content-Type-Options nosniff;\n\
\\n\
\ssl_dhparam /etc/ssl/certs/dhparam.pem;\n"

BIN
services/nginx/src/Main.o Normal file

Binary file not shown.

View File

@ -0,0 +1,76 @@
{-# LANGUAGE NamedFieldPuns #-}
module Types ( ServerType (..)
, ServerParams (..)
, toServerParams) where
import System.Serverman.Types
import System.Serverman.Utils
import Data.Default.Class
toServerParams :: [(String, Maybe String)] -> ServerParams
toServerParams (("directory", Just value):xs) = (toServerParams xs) { directory = value, serverType = Static }
toServerParams (("domain", Just value):xs) = (toServerParams xs) { domain = value }
toServerParams (("port", Just value):xs) = (toServerParams xs) { port = value }
toServerParams (("forward", Just value):xs) = (toServerParams xs) { forward = value, serverType = PortForwarding }
toServerParams (("email", Just value):xs) = (toServerParams xs) { email = value }
toServerParams (("ssl", Nothing):xs) = (toServerParams xs) { ssl = True }
toServerParams _ = def
data ServerType = Static | PortForwarding deriving (Show, Eq)
data ServerParams = ServerParams { directory :: FilePath
, domain :: String
, port :: String
, forward :: String
, email :: String
, ssl :: Bool
, serverType :: ServerType
} deriving (Eq)
instance Default ServerParams where
def = ServerParams { directory = "/var/www"
, domain = "localhost"
, port = "80"
, forward = ""
, email = ""
, ssl = False
, serverType = Static }
instance Show ServerParams where
show (ServerParams { directory, domain, port, forward, email, ssl, serverType }) =
let redirect
| ssl = block "server" $
semicolon $
keyvalue ([ ("listen", "80")
, ("listen", "[::]:80")
, ("server_name", domain)
, ("rewrite", "^ https://$server_name$request_uri? permanent")
]) " "
| otherwise = ""
https
| ssl = [ ("ssl_certificate", "/etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem")
, ("ssl_certificate_key", "/etc/letsencrypt/live/" ++ domain ++ "/privkey.pem")
, ("include", "ssl.conf")]
| otherwise = []
listen = port ++ (if ssl then " ssl" else "")
base = [ ("server_name", domain)
, ("listen", listen)
, ("listen", "[::]:" ++ listen)
, ("index", "index.html index.html index.php")
] ++ https
in
case serverType of
Static ->
(block "server" $ keyvalue (base ++ [("root", directory)]) " ") ++ "\n" ++ redirect
PortForwarding ->
let proxyBlock = block "location /" $
semicolon $
keyvalue ([ ("proxy_pass", "http://127.0.0.1:" ++ forward)
, ("proxy_set_header", "X-Forwarded-Host $host")
, ("proxy_set_header", "X-Forwarded-Server $host")
, ("proxy_set_header", "X-Forwarded-For $proxy_add_x_forwarded_for")
]) " "
in (block "server" $ semicolon (keyvalue base " ") ++ proxyBlock) ++ "\n" ++ redirect

66
services/nginx/stack.yaml Normal file
View File

@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-8.5
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

37
services/template.hsfiles Normal file
View File

@ -0,0 +1,37 @@
{-# START_FILE serverman-service-{{name}}.cabal #-}
name: serverman-service-{{name}}
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}}#readme
license: GPL-3
license-file: LICENSE
author: {{author-name}}{{^author-name}}Author name here{{/author-name}}
maintainer: {{author-email}}{{^author-email}}example@example.com{{/author-email}}
copyright: {{year}}{{^year}}2017{{/year}} {{author-name}}{{^author-name}}Author name here{{/author-name}}
category: {{category}}{{^category}}serverman{{/category}}
build-type: Simple
cabal-version: >=1.10
executable {{name}}
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, data-default-class
, mtl
{-# START_FILE src/Main.hs #-}
{-# LANGUAGE NamedFieldPuns #-}
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils
import Control.Monad.State
call :: Service -> App ()
call s@(Service { name, version, service })= do
(AppState { os, arguments }) <- get
return ()
main :: IO ()
main = return ()

View File

@ -0,0 +1,21 @@
name: serverman-service-vsftpd
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/mdibaiee/vsftpd#readme
license: GPL-3
license-file: LICENSE
author: Mahdi Dibaiee
maintainer: mahdi@theread.me
copyright: 2017 Mahdi Dibaiee
category: ftp
build-type: Simple
cabal-version: >=1.10
executable vsftpd
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, data-default-class
, mtl

View File

@ -0,0 +1,50 @@
{-# LANGUAGE NamedFieldPuns #-}
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils
import Types
import System.Directory hiding (writable)
import System.IO
import System.IO.Error
import System.FilePath
import System.Process
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Free
import Data.List
import Data.Either
import Control.Monad.State
call :: Service -> App ()
call s@(Service { name, version, service })= do
(AppState { os, arguments }) <- get
let params@(FileSharingParams { directory, port, user, pass, anonymous, anonymousWrite, writable, recreateUser }) = toFSParams arguments
let content = show params
config = "/etc/"
original = config </> "vsftpd.conf"
userList = config </> "vsftpd-serverman-user-list"
when recreateUser $ executeRoot "userdel" [user] "" True >> return ()
(Right opensslResponse) <- execute "openssl" ["passwd", "-1", pass] "" True
let encryptedPassword = head . lines $ opensslResponse
executeRoot "useradd" [user, "-d", directory, "-G", "ftp", "-p", encryptedPassword] "" True
liftIO $ do
renameFileIfMissing original (original ++ ".backup")
writeFile original content
writeFile userList user
result <- restartService "vsftpd"
case result of
Left err -> return ()
Right _ ->
liftIO $ putStrLn $ "restarted vsftpd"
main :: IO ()
main = return ()

View File

@ -0,0 +1,55 @@
{-# LANGUAGE NamedFieldPuns #-}
module Types ( FileSharingParams (..)
, toFSParams) where
import System.Serverman.Utils
import Data.Default.Class
toFSParams :: [(String, Maybe String)] -> FileSharingParams
toFSParams (("directory", Just value):xs) = (toFSParams xs) { directory = value }
toFSParams (("user", Just value):xs) = (toFSParams xs) { user = value }
toFSParams (("pass", Just value):xs) = (toFSParams xs) { pass = value }
toFSParams (("port", Just value):xs) = (toFSParams xs) { port = value }
toFSParams (("writable", Nothing):xs) = (toFSParams xs) { writable = True }
toFSParams (("anonymous", Nothing):xs) = (toFSParams xs) { anonymous = True }
toFSParams (("anonymous-write", Nothing):xs) = (toFSParams xs) { anonymousWrite = True }
toFSParams (("recreate-user", Nothing):xs) = (toFSParams xs) { recreateUser = True }
toFSParams _ = def
data FileSharingParams = FileSharingParams { directory :: FilePath
, user :: String
, pass :: String
, port :: String
, writable :: Bool
, anonymous :: Bool
, anonymousWrite :: Bool
, recreateUser :: Bool
} deriving (Eq)
instance Default FileSharingParams where
def = FileSharingParams { directory = "/srv/ftp/serverman"
, user = "serverman"
, pass = "serverman"
, port = "20"
, writable = True
, anonymous = False
, anonymousWrite = False
, recreateUser = False
}
instance Show FileSharingParams where
show (FileSharingParams { directory, user, pass, port, writable, anonymous, anonymousWrite }) =
let boolToEnglish True = "YES"
boolToEnglish False = "NO"
in
keyvalue [ ("anonymous_enable", boolToEnglish anonymous)
, ("write_enable", boolToEnglish writable)
, ("allow_writeable_chroot", boolToEnglish writable)
, ("anon_upload_enable", boolToEnglish anonymousWrite)
, ("anon_mkdir_write_enable", boolToEnglish anonymousWrite)
, ("listen", "YES")
, ("userlist_enable", "YES")
, ("userlist_file", "/etc/vsftpd-serverman-user-list")
, ("userlist_deny", "NO")
, ("chroot_local_user", "YES")
, ("xferlog_enable", "YES")
, ("local_enable", "YES")] "="

View File

@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-8.5
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor