fix: help entry, logging

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

View File

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

View File

@ -2,61 +2,57 @@
module Main (call, main) where module Main (call, main) where
import System.Serverman.Types import System.Serverman.Types
import System.Serverman.Utils hiding (execute) 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 qualified Data.ByteString.Char8 as BS
import Data.List hiding (delete) import Data.List hiding (delete)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State hiding (liftIO)
import System.IO.Error 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 :: Service -> App ()
call s@(Service { name, version, service })= do call s@(Service { name, version, service })= do
(AppState { arguments }) <- get (AppState { arguments }) <- get
let params@(DatabaseParams { database, dummyData, user, pass, host }) = toDBParams arguments let params@(DatabaseParams { database, dummyData, user, pass, host }) = toDBParams arguments
run = do
when dummyData $ do
clearCollection
insertToCollection
return ()
liftIO $ do liftIO $ do
result <- tryIOError $ connect (readHostPort databaseHost) result <- tryIOError $ DB.connect (DB.readHostPort host)
case result of case result of
Right pipe -> do 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 Left err -> do
putStrLn $ show err putStrLn $ show err
putStrLn $ "[Error] could not connect to MongoDB server " ++ databaseHost putStrLn $ "[Error] could not connect to MongoDB server " ++ host
where where
run = do clearCollection = DB.delete (DB.select [] (T.pack collectionName))
when dummyData $ do
clearCollection
insertToCollection
return ()
clearCollection = delete (select [] (T.pack collectionName))
where (collectionName, _, _) = dummy where (collectionName, _, _) = dummy
insertToCollection = insertMany (T.pack collectionName) records insertToCollection = DB.insertMany (T.pack collectionName) records
where where
(collectionName, definitions, rows) = dummy (collectionName, definitions, rows) = dummy
records = map (\row -> zipWith (\def value -> def =: row) (map T.pack definitions) row) rows records = map (\row -> zipWith (\def value -> def DB.=: 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 :: IO ()
main = return () main = return ()

View File

@ -9,6 +9,7 @@ module Types (DatabaseParams(..), toDBParams, dummy) where
toDBParams (("pass", Just value):xs) = (toDBParams xs) { pass = value } toDBParams (("pass", Just value):xs) = (toDBParams xs) { pass = value }
toDBParams (("host", Just value):xs) = (toDBParams xs) { host = value } toDBParams (("host", Just value):xs) = (toDBParams xs) { host = value }
toDBParams (("dummy-data", Just value):xs) = (toDBParams xs) { dummyData = True } toDBParams (("dummy-data", Just value):xs) = (toDBParams xs) { dummyData = True }
toDBParams (_:xs) = (toDBParams xs)
toDBParams _ = def toDBParams _ = def
data DatabaseParams = DatabaseParams { database :: String data DatabaseParams = DatabaseParams { database :: String

View File

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

View File

@ -1,54 +1,77 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (call, main) where module Main (call, main) where
import System.Serverman.Types import System.Serverman.Types
import System.Serverman.Utils hiding (execute) import System.Serverman.Utils hiding (execute)
import Types import Types
import Database.MySQL.Base import "mysql-haskell" Database.MySQL.Base
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import Data.List import Data.List
import Control.Monad 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 :: Service -> App ()
call s@(Service { name, version, service }) = do call s@(Service { name, version, service }) = do
(AppState { arguments }) <- get (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 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 when dummyData $ do
let (tableName, _, _) = dummy let (tableName, _, _) = dummy
query conn $ BS.pack createDummyTables execute_ conn createDummyTables
query conn $ BS.pack clearTable execute_ conn clearTable
query conn $ BS.pack insertToDummyTables execute_ conn insertToDummyTables
putStrLn $ "Created dummy table '" ++ tableName ++ "' and filled it with data." putStrLn $ "Created dummy table '" ++ tableName ++ "' and filled it with data."
return () return ()
clearPort servermanPort
return () return ()
clearTable = "DELETE FROM " ++ tableName clearTable :: Query
clearTable = renderParams "DELETE FROM ?" [One (MySQLBytes $ BS.pack tableName)]
where (tableName, _, _) = dummy where (tableName, _, _) = dummy
createDummyTables :: Query
createDummyTables = createTable dummy createDummyTables = createTable dummy
where where
createTable (tableName, columns, rows) = "CREATE TABLE IF NOT EXISTS " ++ tableName ++ "(" ++ intercalate "," (map columnDef columns) ++ ")"; createTable (tableName, columns, rows) = renderParams "CREATE TABLE IF NOT EXISTS ? (?)" [One (MySQLBytes $ BS.pack tableName), Many (map columnDef columns)]
columnDef "children" = "children INT" columnDef "children" = MySQLText "children INT"
columnDef "birth_date" = "birth_date DATETIME" columnDef "birth_date" = MySQLText "birth_date DATETIME"
columnDef "gender" = "gender ENUM('Male', 'Female')" columnDef "gender" = MySQLText "gender ENUM('Male', 'Female')"
columnDef name = name ++ " VARCHAR(255)" columnDef name = MySQLBytes (BL.toStrict . fromQuery $ renderParams "? VARCHAR(255)" [One (MySQLBytes $ BS.pack name)])
insertToDummyTables :: Query
insertToDummyTables = insertTable dummy insertToDummyTables = insertTable dummy
where where
insertTable (tableName, _, rows) = "INSERT INTO " ++ tableName ++ " VALUES " ++ intercalate "," (map insertRow rows) insertTable (tableName, _, rows) = renderParams "INSERT INTO ? VALUES (?)" [One (MySQLBytes $ BS.pack tableName), Many (map insertRow rows)]
insertRow row = "('" ++ intercalate "','" row ++ "')" insertRow row = MySQLBytes (BL.toStrict . fromQuery $ renderParams "?" [Many $ map (MySQLBytes . BS.pack) row])

View File

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

View File

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

View File

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

View File

@ -16,6 +16,17 @@ module Main (call, main) where
import Data.Either import Data.Either
import Control.Monad.State hiding (liftIO) 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 :: Service -> App ()
call s@(Service { name, version, service })= do call s@(Service { name, version, service })= do

View File

@ -13,6 +13,7 @@ module Types ( FileSharingParams (..)
toFSParams (("anonymous", Nothing):xs) = (toFSParams xs) { anonymous = True } toFSParams (("anonymous", Nothing):xs) = (toFSParams xs) { anonymous = True }
toFSParams (("anonymous-write", Nothing):xs) = (toFSParams xs) { anonymousWrite = True } toFSParams (("anonymous-write", Nothing):xs) = (toFSParams xs) { anonymousWrite = True }
toFSParams (("recreate-user", Nothing):xs) = (toFSParams xs) { recreateUser = True } toFSParams (("recreate-user", Nothing):xs) = (toFSParams xs) { recreateUser = True }
toFSParams (_:xs) = (toFSParams xs)
toFSParams _ = def toFSParams _ = def
data FileSharingParams = FileSharingParams { directory :: FilePath data FileSharingParams = FileSharingParams { directory :: FilePath