fix: help entry, logging

repository.json

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

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 <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
+      clearCollection = DB.delete (DB.select [] (T.pack collectionName))
-        when dummyData $ do
-          clearCollection
-          insertToCollection
-          return ()
-
-      clearCollection = delete (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
+          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 = return ()

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

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 

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 <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
+        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."
         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) ++ ")";
+      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
     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])
     
 
 

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"], [

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 <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
+      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
 
@@ -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
+          _ -> 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 ()
     where
@@ -90,8 +112,7 @@ module Main (call, main) where
         result <- restartService "nginx"
         case result of
           Left err -> return ()
-          Right _ ->
+          Right _ -> info $ "restarted nginx"
-            liftIO $ putStrLn $ "restarted nginx"
 
       writeIncludeStatementIfMissing path target = do
         content <- readFile path

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
+  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)
 
   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
-    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")
-                            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 = ""
           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 /" $

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 <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

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