From a646e2bd33c5634efa5126ddaf062b8c136b9dc8 Mon Sep 17 00:00:00 2001 From: Mahdi Dibaiee Date: Thu, 30 Mar 2017 23:01:18 +0430 Subject: [PATCH] fix: help entry, logging --- repository.json | 2 + services/mongodb/src/Main.hs | 58 +++++++++----------- services/mongodb/src/Types.hs | 1 + services/mysql/serverman-service-mysql.cabal | 3 +- services/mysql/src/Main.hs | 57 +++++++++++++------ services/mysql/src/Types.hs | 10 +++- services/nginx/src/Main.hs | 55 +++++++++++++------ services/nginx/src/Types.hs | 48 ++++++++-------- services/vsftpd/src/Main.hs | 11 ++++ services/vsftpd/src/Types.hs | 1 + 10 files changed, 156 insertions(+), 90 deletions(-) diff --git a/repository.json b/repository.json index a26500a..a066ccf 100644 --- a/repository.json +++ b/repository.json @@ -27,6 +27,8 @@ "dependencies": [], "service": "mysql", "packages": { + "debian": ["mysql-server"], + "arch": ["mariadb"], "_": ["mysql"] }, "category": "database" diff --git a/services/mongodb/src/Main.hs b/services/mongodb/src/Main.hs index 10eb83e..4e03dd6 100644 --- a/services/mongodb/src/Main.hs +++ b/services/mongodb/src/Main.hs @@ -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 ", "database name, default: serverman") + , ("--user ", "database username, default: serverman") + , ("--password ", "database password, default: serverman") + , ("--host ", "database hostname") + , ("--port ", "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 - - where - run = do - when dummyData $ do - clearCollection - insertToCollection - return () + putStrLn $ "[Error] could not connect to MongoDB server " ++ host - clearCollection = delete (select [] (T.pack collectionName)) + where + 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 () diff --git a/services/mongodb/src/Types.hs b/services/mongodb/src/Types.hs index 31462d1..3db4cc2 100644 --- a/services/mongodb/src/Types.hs +++ b/services/mongodb/src/Types.hs @@ -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 diff --git a/services/mysql/serverman-service-mysql.cabal b/services/mysql/serverman-service-mysql.cabal index b8cee70..960f16f 100644 --- a/services/mysql/serverman-service-mysql.cabal +++ b/services/mysql/serverman-service-mysql.cabal @@ -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 diff --git a/services/mysql/src/Main.hs b/services/mysql/src/Main.hs index 51b2f3c..1eefae7 100644 --- a/services/mysql/src/Main.hs +++ b/services/mysql/src/Main.hs @@ -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 ", "database name, default: serverman") + , ("--user ", "database username, default: serverman") + , ("--password ", "database password, default: serverman") + , ("--host ", "database hostname") + , ("--port ", "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]) diff --git a/services/mysql/src/Types.hs b/services/mysql/src/Types.hs index 31462d1..87bffa1 100644 --- a/services/mysql/src/Types.hs +++ b/services/mysql/src/Types.hs @@ -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"], [ diff --git a/services/nginx/src/Main.hs b/services/nginx/src/Main.hs index 5d636e4..c3b2ab6 100644 --- a/services/nginx/src/Main.hs +++ b/services/nginx/src/Main.hs @@ -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 ", "(static) directory to serve, default: /var/www/html") + , ("--domain ", "domain name to listen on, default: localhost") + , ("--port ", "port number to listen on, default: 80") + , ("--forward ", "(forward) port number to forward to") + , ("--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 -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 -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 diff --git a/services/nginx/src/Types.hs b/services/nginx/src/Types.hs index 11ef74a..a932ded 100644 --- a/services/nginx/src/Types.hs +++ b/services/nginx/src/Types.hs @@ -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 /" $ diff --git a/services/vsftpd/src/Main.hs b/services/vsftpd/src/Main.hs index b7ea746..1583051 100644 --- a/services/vsftpd/src/Main.hs +++ b/services/vsftpd/src/Main.hs @@ -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 ", "directory to serve, default: /srv/ftp/serverman/") + , ("--user ", "ftp server username, default: serverman") + , ("--password ", "ftp server password, default: serverman") + , ("--port ", "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 diff --git a/services/vsftpd/src/Types.hs b/services/vsftpd/src/Types.hs index e603c36..031af45 100644 --- a/services/vsftpd/src/Types.hs +++ b/services/vsftpd/src/Types.hs @@ -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