thereadme/serverman-repository
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fix: help entry, logging

Browse Source
This commit is contained in:
Mahdi Dibaiee
2017-03-30 23:01:18 +04:30
parent 46eaf3e4f6
commit a646e2bd33
10 changed files with 156 additions and 90 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
repository.json
View File

@@ -27,6 +27,8 @@
"dependencies": [],
"service": "mysql",
"packages": {
"debian": ["mysql-server"],
"arch": ["mariadb"],
"_": ["mysql"]
},
"category": "database"

56
services/mongodb/src/Main.hs
View File

@@ -2,61 +2,57 @@
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils hiding (execute)
import Database.MongoDB
import Types
import qualified Database.MongoDB as DB
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 Control.Monad.State hiding (liftIO)
import System.IO.Error
help :: App String
help = return $
mkHelp "mongodb [--options]"
[ ("--database <name>", "database name, default: serverman")
, ("--user <username>", "database username, default: serverman")
, ("--password <password>", "database password, default: serverman")
, ("--host <domain>", "database hostname")
, ("--port <num>", "database port number")
, ("--dummy-data", "insert dummy data into database")]
call :: Service -> App ()
call s@(Service { name, version, service })= do
(AppState { arguments }) <- get
let params@(DatabaseParams { database, dummyData, user, pass, host }) = toDBParams arguments
run = do
when dummyData $ do
clearCollection
insertToCollection
return ()
liftIO $ do
result <- tryIOError $ connect (readHostPort databaseHost)
result <- tryIOError $ DB.connect (DB.readHostPort host)
case result of
Right pipe -> do
e <- access pipe master (T.pack database) run
e <- DB.access pipe DB.master (T.pack database) run
close pipe
DB.close pipe
Left err -> do
putStrLn $ show err
putStrLn $ "[Error] could not connect to MongoDB server " ++ databaseHost
putStrLn $ "[Error] could not connect to MongoDB server " ++ host
where
run = do
when dummyData $ do
clearCollection
insertToCollection
return ()
clearCollection = delete (select [] (T.pack collectionName))
clearCollection = DB.delete (DB.select [] (T.pack collectionName))
where (collectionName, _, _) = dummy
insertToCollection = insertMany (T.pack collectionName) records
insertToCollection = DB.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 ++ "')"
records = map (\row -> zipWith (\def value -> def DB.=: row) (map T.pack definitions) row) rows
main :: IO ()
main = return ()

1
services/mongodb/src/Types.hs
View File

@@ -9,6 +9,7 @@ module Types (DatabaseParams(..), toDBParams, dummy) where
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 (_:xs) = (toDBParams xs)
toDBParams _ = def
data DatabaseParams = DatabaseParams { database :: String

3
services/mysql/serverman-service-mysql.cabal
View File

@@ -18,4 +18,5 @@ executable mysql
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, data-default-class
, mysql >= 0.1.4 && < 1
, mysql-haskell >= 0.1.4 && < 1
, text

55
services/mysql/src/Main.hs
View File

@@ -1,54 +1,77 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils hiding (execute)
import Types
import Database.MySQL.Base
import "mysql-haskell" Database.MySQL.Base
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import Data.List
import Control.Monad
import Control.Monad.State
import Control.Monad.State hiding (liftIO)
help :: App String
help = return $
mkHelp "mysql [--options]"
[ ("--database <name>", "database name, default: serverman")
, ("--user <username>", "database username, default: serverman")
, ("--password <password>", "database password, default: serverman")
, ("--host <domain>", "database hostname")
, ("--port <num>", "database port number")
, ("--dummy-data", "insert dummy data into database")]
call :: Service -> App ()
call s@(Service { name, version, service }) = do
(AppState { arguments }) <- get
let params@(DatabaseParams { database, dummyData, user, pass, host }) = toDBParams arguments
let params@(DatabaseParams { database, dummyData, user, pass, host, port }) = toDBParams arguments
servermanPort <- usingPort port
liftIO $ do
conn <- connect $ defaultConnectInfo { connectUser = user, connectPassword = pass, connectHost = host }
conn <- connect $ defaultConnectInfo { ciUser = BS.pack user, ciPassword = BS.pack pass, ciHost = host, ciPort = read servermanPort }
query conn $ BS.pack ("CREATE DATABASE IF NOT EXISTS " ++ database)
print $ renderParams "CREATE DATABASE IF NOT EXISTS ?" [One (MySQLText $ T.pack database)]
execute conn "CREATE DATABASE IF NOT EXISTS ?;" [One (MySQLText $ T.pack database)]
when dummyData $ do
let (tableName, _, _) = dummy
query conn $ BS.pack createDummyTables
query conn $ BS.pack clearTable
query conn $ BS.pack insertToDummyTables
execute_ conn createDummyTables
execute_ conn clearTable
execute_ conn insertToDummyTables
putStrLn $ "Created dummy table '" ++ tableName ++ "' and filled it with data."
return ()
clearPort servermanPort
return ()
clearTable = "DELETE FROM " ++ tableName
clearTable :: Query
clearTable = renderParams "DELETE FROM ?" [One (MySQLBytes $ BS.pack tableName)]
where (tableName, _, _) = dummy
createDummyTables :: Query
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)"
createTable (tableName, columns, rows) = renderParams "CREATE TABLE IF NOT EXISTS ? (?)" [One (MySQLBytes $ BS.pack tableName), Many (map columnDef columns)]
columnDef "children" = MySQLText "children INT"
columnDef "birth_date" = MySQLText "birth_date DATETIME"
columnDef "gender" = MySQLText "gender ENUM('Male', 'Female')"
columnDef name = MySQLBytes (BL.toStrict . fromQuery $ renderParams "? VARCHAR(255)" [One (MySQLBytes $ BS.pack name)])
insertToDummyTables :: Query
insertToDummyTables = insertTable dummy
where
insertTable (tableName, _, rows) = "INSERT INTO " ++ tableName ++ " VALUES " ++ intercalate "," (map insertRow rows)
insertRow row = "('" ++ intercalate "','" row ++ "')"
insertTable (tableName, _, rows) = renderParams "INSERT INTO ? VALUES (?)" [One (MySQLBytes $ BS.pack tableName), Many (map insertRow rows)]
insertRow row = MySQLBytes (BL.toStrict . fromQuery $ renderParams "?" [Many $ map (MySQLBytes . BS.pack) row])

10
services/mysql/src/Types.hs
View File

@@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Types (DatabaseParams(..), toDBParams, dummy) where
import System.Serverman.Utils
@@ -6,9 +8,11 @@ module Types (DatabaseParams(..), toDBParams, dummy) where
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 (("password", 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 (("port", Just value):xs) = (toDBParams xs) { port = value }
toDBParams (("dummy-data", Nothing):xs) = (toDBParams xs) { dummyData = True }
toDBParams (_:xs) = (toDBParams xs)
toDBParams _ = def
data DatabaseParams = DatabaseParams { database :: String
@@ -16,6 +20,7 @@ module Types (DatabaseParams(..), toDBParams, dummy) where
, user :: String
, pass :: String
, host :: String
, port :: String
} deriving (Eq, Show)
instance Default DatabaseParams where
@@ -24,6 +29,7 @@ module Types (DatabaseParams(..), toDBParams, dummy) where
, user = "serverman"
, pass = "serverman"
, host = "localhost"
, port = "3306"
}
dummy = ("serverman_users", ["first_name", "last_name", "email", "children", "birth_date", "gender"], [

55
services/nginx/src/Main.hs
View File

@@ -2,6 +2,7 @@
module Main (call, main) where
import System.Serverman.Types
import System.Serverman.Utils
import System.Serverman.Log
import Types
import System.Directory
@@ -11,19 +12,32 @@ module Main (call, main) where
import System.Process
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State
import Control.Monad.State hiding (liftIO)
import Control.Monad.Free
import Data.List
main :: IO ()
main = return ()
help :: App String
help = return $
mkHelp "nginx [--options]"
[ ("--directory <path>", "(static) directory to serve, default: /var/www/html")
, ("--domain <domain>", "domain name to listen on, default: localhost")
, ("--port <num>", "port number to listen on, default: 80")
, ("--forward <num>", "(forward) port number to forward to")
, ("--email <email>", "(ssl) email to register SSL certificate on")
, ("--ssl", "(ssl) generate an SSL certificate using letsencrypt")
, ("--directory-listing", "(static) enable directory indexing")]
call :: Service -> App ()
call _ =
do
(AppState { arguments }) <- get
let params@(ServerParams { ssl, domain, directory, serverType, email }) = toServerParams arguments
verbose $ show params
-- Turn SSL off at first, because we have not yet received a certificate
let content = show (params { ssl = False, port = "80" })
config = "/etc/nginx/"
@@ -33,31 +47,37 @@ module Main (call, main) where
targetDir = directory
createCert path cmd = do
verbose $ "creating certificate in " ++ path ++ " using command " ++ cmd
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
write stdout
when (not ("error" `isInfixOf` stdout)) $ do
verbose $ "writing params to " ++ path
liftIO $ writeFile path (show params)
liftIO . wait =<< restart
return ()
verbose $ "creating directories " ++ targetDir ++ ", " ++ parent
liftIO $ do
createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent
writeIncludeStatementIfMissing mainConfig parent
verbose $ "adding include statement to " ++ mainConfig ++ " pointing to " ++ parent
liftIO $ writeIncludeStatementIfMissing mainConfig parent
when ssl $ do
let sslPath = config </> "ssl.conf"
writeFileIfMissing sslPath nginxSSL
putStrLn $ "wrote ssl configuration to " ++ sslPath
when ssl $ do
let sslPath = config </> "ssl.conf"
verbose $ "writing SSL configuration to " ++ sslPath
writeFile path content
liftIO $ writeFileIfMissing sslPath nginxSSL
putStrLn $ "wrote your configuration file to " ++ path
info $ "wrote ssl configuration to " ++ sslPath
liftIO $ writeFile path content
info $ "wrote your configuration file to " ++ path
liftIO . wait =<< restart
@@ -66,6 +86,8 @@ module Main (call, main) where
dhExists <- liftIO $ doesFileExist dhparamPath
when (not dhExists) $ do
verbose $ "creating dhparam using openssl"
dhparam <- liftedAsync $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True
liftIO $ wait dhparam
return ()
@@ -76,13 +98,13 @@ module Main (call, main) where
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
_ -> do
info $ "you should use letsencrypt to create a certificate for your domain"
write $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem"
write $ "my suggestion is running this command:"
write $ "sudo letsencrypt certonly --webroot --webroot-path <YOUR_APPLICATION_DIRECTORY> -d " ++ domain
liftIO $ putStrLn $ "for more information, see: https://certbot.eff.org/"
write $ "for more information, see: https://certbot.eff.org/"
return ()
where
@@ -90,8 +112,7 @@ module Main (call, main) where
result <- restartService "nginx"
case result of
Left err -> return ()
Right _ ->
liftIO $ putStrLn $ "restarted nginx"
Right _ -> info $ "restarted nginx"
writeIncludeStatementIfMissing path target = do
content <- readFile path

48
services/nginx/src/Types.hs
View File

@@ -15,37 +15,40 @@ module Types ( ServerType (..)
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 (("directory-listing", Nothing):xs) = (toServerParams xs) { directoryListing = True }
toServerParams (_:xs) = (toServerParams xs)
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
data ServerParams = ServerParams { directory :: FilePath
, domain :: String
, port :: String
, forward :: String
, email :: String
, ssl :: Bool
, directoryListing :: Bool
, serverType :: ServerType
} deriving (Eq)
instance Default ServerParams where
def = ServerParams { directory = "/var/www"
, domain = "localhost"
, port = "80"
, forward = ""
, email = ""
, ssl = False
, serverType = Static }
def = ServerParams { directory = "/var/www/html"
, domain = "localhost"
, port = "80"
, forward = ""
, email = ""
, ssl = False
, directoryListing = False
, serverType = Static }
instance Show ServerParams where
show (ServerParams { directory, domain, port, forward, email, ssl, serverType }) =
show (ServerParams { directory, domain, port, forward, email, ssl, serverType, directoryListing }) =
let redirect
| ssl = block "server" $
semicolon $
keyvalue ([ ("listen", "80")
, ("listen", "[::]:80")
, ("server_name", domain)
, ("rewrite", "^ https://$server_name$request_uri? permanent")
]) " "
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")
@@ -59,11 +62,12 @@ module Types ( ServerType (..)
, ("listen", listen)
, ("listen", "[::]:" ++ listen)
, ("index", "index.html index.html index.php")
, ("autoindex", if directoryListing then "on" else "off")
] ++ https
in
case serverType of
Static ->
(block "server" $ keyvalue (base ++ [("root", directory)]) " ") ++ "\n" ++ redirect
(block "server" $ semicolon $ keyvalue (base ++ [("root", directory)]) " ") ++ "\n" ++ redirect
PortForwarding ->
let proxyBlock = block "location /" $

11
services/vsftpd/src/Main.hs
View File

@@ -16,6 +16,17 @@ module Main (call, main) where
import Data.Either
import Control.Monad.State hiding (liftIO)
help :: App String
help = return $
mkHelp "vsftpd [--options]"
[ ("--directory <path>", "directory to serve, default: /srv/ftp/serverman/")
, ("--user <username>", "ftp server username, default: serverman")
, ("--password <password>", "ftp server password, default: serverman")
, ("--port <num>", "ftp server port number, default: 20")
, ("--anonymous", "allow anonymous connections, default: False")
, ("--anonymous-write", "allow anonymous writes, default: False")
, ("--writable", "allow writes to the ftp server, default: True")
, ("--recreate-user", "if the specified username exists, delete and create it again, otherwise leave it intact")]
call :: Service -> App ()
call s@(Service { name, version, service })= do

1
services/vsftpd/src/Types.hs
View File

@@ -13,6 +13,7 @@ module Types ( FileSharingParams (..)
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 (_:xs) = (toFSParams xs)
toFSParams _ = def
data FileSharingParams = FileSharingParams { directory :: FilePath