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

refactor(services): move services to repository

Browse Source
This commit is contained in:
Mahdi Dibaiee 2017-03-18 18:04:56 +03:30
parent cf6670bafa
commit 7c80963642
25 changed files with 150 additions and 702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
memory_logfile Normal file
View File

2
serverman.cabal
View File

@ -38,8 +38,6 @@ library
, directory , directory
, filepath , filepath
, async , async
, mysql >= 0.1.4 && < 1
, mongoDB >= 2.1.1.1 && < 3
, text , text
, bytestring , bytestring
, unix , unix

10
src/System/Serverman.hs
View File

@ -21,12 +21,12 @@ module System.Serverman ( run
run :: Action r -> App r run :: Action r -> App r
run (Pure r) = return r run (Pure r) = return r
run (Free (DetectOS next)) = getOS >>= run . next run (Free (DetectOS next)) = getOS >> run next
run (Free (Start os service next)) = startService os service >> run next run (Free (Start service next)) = startService service >> run next
run (Free (Stop os service next)) = stopService os service >> run next run (Free (Stop service next)) = stopService service >> run next
run (Free (Install os service next)) = installService os service >> run next run (Free (Install service next)) = installService service >> run next
run (Free (Call service params next)) = callService service params >> run next run (Free (Call service next)) = callService service >> run next
run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next

42
src/System/Serverman/Action.hs
View File

@ -14,8 +14,8 @@ module System.Serverman.Action ( ActionF(..)
import System.Serverman.Actions.Repository import System.Serverman.Actions.Repository
import System.Serverman.Actions.Remote import System.Serverman.Actions.Remote
import System.Serverman.Utils
import System.Serverman.Types import System.Serverman.Types
import System.Serverman.Utils
import System.Serverman.Services import System.Serverman.Services
import System.Directory import System.Directory
@ -28,39 +28,39 @@ module System.Serverman.Action ( ActionF(..)
import System.IO.Error import System.IO.Error
import Data.Char import Data.Char
data ActionF x = Call Service Params x data ActionF x = Call Service x
| DetectOS (OS -> x) | DetectOS x
| Install Service OS x | Install Service x
| Remote [Address] (Action ()) x | Remote [Address] (Action ()) x
| FetchRepository x | FetchRepository x
| Start Service OS x | Start Service x
| Stop Service OS x | Stop Service x
instance Functor ActionF where instance Functor ActionF where
fmap f (Call service params x) = Call service params (f x) fmap f (Call service x) = Call service (f x)
fmap f (Install service os x) = Install service os (f x) fmap f (Install service x) = Install service (f x)
fmap f (Start service os x) = Start service os (f x) fmap f (Start service x) = Start service (f x)
fmap f (Stop service os x) = Stop service os (f x) fmap f (Stop service x) = Stop service (f x)
fmap f (DetectOS x) = DetectOS (f . x) fmap f (DetectOS x) = DetectOS (f x)
fmap f (Remote addr action x) = Remote addr action (f x) fmap f (Remote addr action x) = Remote addr action (f x)
fmap f (FetchRepository x) = FetchRepository (f x) fmap f (FetchRepository x) = FetchRepository (f x)
type Action = Free ActionF type Action = Free ActionF
call :: Service -> Params -> Action () call :: Service -> Action ()
call service params = liftF $ Call service params () call service = liftF $ Call service ()
install :: Service -> OS -> Action () install :: Service -> Action ()
install service os = liftF $ Install service os () install service = liftF $ Install service ()
start :: Service -> OS -> Action () start :: Service -> Action ()
start service os = liftF $ Start service os () start service = liftF $ Start service ()
stop :: Service -> OS -> Action () stop :: Service -> Action ()
stop service os = liftF $ Stop service os () stop service = liftF $ Stop service ()
detectOS :: Action OS detectOS :: Action ()
detectOS = liftF $ DetectOS id detectOS = liftF $ DetectOS ()
remote :: [Address] -> Action () -> Action () remote :: [Address] -> Action () -> Action ()
remote addrs action = liftF $ Remote addrs action () remote addrs action = liftF $ Remote addrs action ()

33
src/System/Serverman/Actions/Call.hs
View File

@ -14,51 +14,44 @@ module System.Serverman.Actions.Call (callService) where
import Data.List import Data.List
import Stack.Package import Stack.Package
callService :: Service -> Params -> App () callService :: Service -> App ()
callService s@(Service { name, version }) params = do callService s@(Service { name, version }) = do
state@(AppState { repositoryURL }) <- get state@(AppState { repositoryURL }) <- get
dir <- liftIO $ getAppUserDataDirectory "serverman" dir <- liftIO $ getAppUserDataDirectory "serverman"
let path = dir </> "repository" </> "services" </> name let path = dir </> "repository" </> "services" </> name
source = dir </> "source" </> "src" source = dir </> "source" </> "src"
entry = path </> "src" </> "Main.hs" src = path </> "src"
object = path </> "Main.o" entry = src </> "Main.hs"
packages <- liftIO $ readFile $ path </> "packages" let include = [source, src]
{-result <- exec "stack" (["ghc", entry, "--package", intercalate "," . lines $ packages, "--"] ++ includeArgs) "" (Just source) True-}
{-let packagePaths = splitAtElem packagePath ':'-}
let include = [source, path]
includeArgs = map ("-i"++) include includeArgs = map ("-i"++) include
(Right stackEnv) <- exec "stack" ["install", "--dependencies-only"] "" (Just path) True
(Right stackEnv) <- exec "stack" ["exec", "env"] "" (Just path) True (Right stackEnv) <- exec "stack" ["exec", "env"] "" (Just path) True
backupEnv <- liftIO $ getEnvironment backupEnv <- liftIO $ getEnvironment
liftIO $ setEnvironment $ parseKeyValue stackEnv '=' liftIO $ setEnvironment $ parseKeyValue stackEnv '='
liftIO $ print include
func <- liftIO $ runInterpreter (interpreter include entry) func <- liftIO $ runInterpreter (interpreter include entry)
case func of case func of
Right fn -> fn Right fn -> fn s
Left err -> liftIO $ do Left err -> liftIO $ do
putStrLn $ "error reading `call` from module " ++ entry putStrLn $ "error reading `call` from module " ++ entry
print err case err of
WontCompile errs -> mapM_ (putStrLn . errMsg) errs
x -> print x
liftIO $ setEnvironment backupEnv liftIO $ setEnvironment backupEnv
return () return ()
{-result <- build entry object ["-i" ++ source]-}
{-print result-}
{-result :: (Maybe ) <- liftIO $ eval content ["System.Serverman.Types", "System.Serverman.Utils", "Control.Monad.State"]-} interpreter :: [FilePath] -> FilePath -> Interpreter (Service -> App ())
{-liftIO $ print result-}
interpreter :: [FilePath] -> FilePath -> Interpreter (App ())
interpreter path entry = do interpreter path entry = do
set [searchPath := path] set [searchPath := path]
loadModules [entry] loadModules [entry]
setTopLevelModules ["Main"] setTopLevelModules ["Main"]
interpret "call" (as :: App ()) interpret "call" (as :: Service -> App ())

54
src/System/Serverman/Actions/Database.hs
View File

@ -1,54 +0,0 @@
module System.Serverman.Actions.Database (DatabaseParams(..), dummy) where
import System.Serverman.Utils
import System.Serverman.Services
import Control.Monad.Free
data DatabaseParams = DatabaseParams { database :: String
, databaseService :: Service
, dummyData :: Bool
, databaseUser :: String
, databasePass :: String
, databaseHost :: String
} deriving (Eq)
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"]])

6
src/System/Serverman/Actions/Env.hs
View File

@ -7,6 +7,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
import System.IO.Error import System.IO.Error
import Data.Either import Data.Either
import Data.Char import Data.Char
import Control.Monad.State
getOS = do getOS = do
arch_release <- execute "cat" ["/etc/os-release"] "" False arch_release <- execute "cat" ["/etc/os-release"] "" False
@ -20,4 +21,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
| "Mac" `isInfixOf` release = Mac | "Mac" `isInfixOf` release = Mac
| otherwise = Unknown | otherwise = Unknown
return distro state <- get
put $ state { os = distro }
return ()

37
src/System/Serverman/Actions/FileSharing.hs
View File

@ -1,37 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.FileSharing (FileSharingParams(..)) where
import System.Serverman.Services
import System.Serverman.Utils
data FileSharingParams = FileSharingParams { fDirectory :: FilePath
, fUser :: String
, fPass :: String
, fPort :: String
, fWritable :: Bool
, fAnonymous :: Bool
, fAnonymousWrite :: Bool
, fRecreateUser :: Bool
, fService :: Service
} deriving (Eq)
instance Show FileSharingParams where
show (FileSharingParams { fDirectory, fUser, fPass, fPort, fWritable, fAnonymous, fAnonymousWrite, fService })
| name fService == "vsftpd" =
let boolToEnglish True = "YES"
boolToEnglish False = "NO"
in
keyvalue [ ("anonymous_enable", boolToEnglish fAnonymous)
, ("write_enable", boolToEnglish fWritable)
, ("allow_writeable_chroot", boolToEnglish fWritable)
, ("anon_upload_enable", boolToEnglish fAnonymousWrite)
, ("anon_mkdir_write_enable", boolToEnglish fAnonymousWrite)
, ("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")] "="
| otherwise = "Unknown service provider"

12
src/System/Serverman/Actions/Install.hs
View File

@ -6,6 +6,7 @@ module System.Serverman.Actions.Install (installService) where
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Services import System.Serverman.Services
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Actions.Repository
import System.Serverman.Types import System.Serverman.Types
import System.IO.Error import System.IO.Error
@ -14,10 +15,15 @@ module System.Serverman.Actions.Install (installService) where
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Data.List
import Data.Maybe
installService :: Service -> OS -> App () installService :: Service -> App ()
installService s@(Service { dependencies, packages }) os = do installService s@(Service { dependencies, packages }) = do
forM_ dependencies (`installService` os) (AppState { os }) <- get
deps <- catMaybes <$> mapM findService dependencies
forM_ deps installService
let base = case os of let base = case os of
Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"]) Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"])

33
src/System/Serverman/Actions/Manage.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.Manage (startService, stopService) where module System.Serverman.Actions.Manage (startService, stopService) where
import System.Serverman.Types
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Actions.Install import System.Serverman.Actions.Install
@ -8,15 +9,25 @@ module System.Serverman.Actions.Manage (startService, stopService) where
import Control.Monad.State import Control.Monad.State
startService :: Service -> OS -> App () startService :: Service -> App ()
startService (Service { service }) os startService (Service { service }) = do
| os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running." (AppState { os }) <- get
| otherwise = executeRoot "systemctl" ["start", service] "" True case os of
>> execute "sleep" ["5s"] "" True Mac -> do
>> return () liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
stopService :: Service -> OS -> App () _ -> do
stopService (Service { service }) os executeRoot "systemctl" ["start", service] "" True
| os == Mac = liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically." execute "sleep" ["5s"] "" True
| otherwise = executeRoot "systemctl" ["stop", service] "" True return ()
>> return ()
stopService :: Service -> App ()
stopService (Service { service }) = do
(AppState { os }) <- get
case os of
Mac -> do
liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically."
_ -> do
executeRoot "systemctl" ["stop", service] "" True
return ()

55
src/System/Serverman/Actions/MongoDB.hs
View File

@ -1,55 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.MongoDB (mongodb) where
import System.Serverman.Actions.Database
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
mongodb :: DatabaseParams -> App ()
mongodb (DatabaseParams { database, dummyData, databaseHost }) = 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 ++ "')"

46
src/System/Serverman/Actions/MySQL.hs
View File

@ -1,46 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.MySQL (mysql) where
import System.Serverman.Actions.Database
import System.Serverman.Utils hiding (execute)
import Database.MySQL.Base
import qualified Data.ByteString.Char8 as BS
import Data.List
import Control.Monad
import Control.Monad.State
mysql :: DatabaseParams -> App ()
mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = liftIO $ do
conn <- connect $ defaultConnectInfo { connectUser = databaseUser, connectPassword = databasePass, connectHost = databaseHost }
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 ++ "')"

120
src/System/Serverman/Actions/Nginx.hs
View File

@ -1,120 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.Nginx (nginx) where
import System.Serverman.Action
import System.Serverman.Actions.WebServer
import System.Serverman.Utils
import System.Serverman.Services
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
nginx :: ServerParams -> App ()
nginx params@(ServerParams { ssl, serverService, domain, wDirectory, serverType, email }) =
do
-- Turn SSL off at first, because we have not yet received a certificate
let content = show (params { ssl = False, port = "80" })
mainConfig = config serverService </> "nginx.conf"
parent = config serverService </> "serverman-configs"
path = parent </> domain
targetDir = wDirectory
liftIO $ do
createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent
writeIncludeStatementIfMissing mainConfig parent
when ssl $ do
let sslPath = config serverService </> "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 " ++ show serverService
createCert path cmd = do
result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", wDirectory, "-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 ()
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"

13
src/System/Serverman/Actions/Repository.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.Repository (fetchRepo) where module System.Serverman.Actions.Repository (fetchRepo, findService) where
import System.Serverman.Utils import System.Serverman.Utils
import System.Directory import System.Directory
import System.Serverman.Services import System.Serverman.Services
@ -19,9 +19,15 @@ module System.Serverman.Actions.Repository (fetchRepo) where
import Control.Monad.State import Control.Monad.State
import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Text as T import qualified Data.Text as T
import Data.List
sourceURL = "https://github.com/mdibaiee/serverman" sourceURL = "https://github.com/mdibaiee/serverman"
findService :: String -> App (Maybe Service)
findService n = do
(AppState { repository }) <- get
return $ find (\a -> name a == n) repository
fetchRepo :: App Repository fetchRepo :: App Repository
fetchRepo = do fetchRepo = do
state@(AppState { repositoryURL }) <- get state@(AppState { repositoryURL }) <- get
@ -53,6 +59,7 @@ module System.Serverman.Actions.Repository (fetchRepo) where
case repo of case repo of
Just list -> do Just list -> do
let r = rights list let r = rights list
state <- get state <- get
put $ state { repository = r } put $ state { repository = r }
return $ rights list return $ rights list
@ -70,17 +77,17 @@ module System.Serverman.Actions.Repository (fetchRepo) where
flip parseEither obj $ \object -> do flip parseEither obj $ \object -> do
name <- object .: "name" name <- object .: "name"
version <- object .: "version" version <- object .: "version"
config <- object .: "config"
service <- object .: "service" service <- object .: "service"
category <- object .: "category" category <- object .: "category"
packages <- object .: "packages" packages <- object .: "packages"
dependencies <- object .: "dependencies"
pkglist :: [(OS, [String])] <- map (\(os, name) -> (read os, name)) <$> M.toList <$> parseJSON packages pkglist :: [(OS, [String])] <- map (\(os, name) -> (read os, name)) <$> M.toList <$> parseJSON packages
return Service { name = name return Service { name = name
, version = version , version = version
, config = config
, service = service , service = service
, category = category , category = category
, packages = pkglist , packages = pkglist
, dependencies = dependencies
} }

33
src/System/Serverman/Actions/Start.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.Manage (startService, stopService) where module System.Serverman.Actions.Manage (startService, stopService) where
import System.Serverman.Types
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Actions.Install import System.Serverman.Actions.Install
@ -8,15 +9,25 @@ module System.Serverman.Actions.Manage (startService, stopService) where
import Control.Monad.State import Control.Monad.State
startService :: Service -> OS -> App () startService :: Service -> App ()
startService (Service { service }) os startService (Service { service }) = do
| os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running." (AppState { os }) <- get
| otherwise = executeRoot "systemctl" ["start", service] "" True case os of
>> execute "sleep" ["5s"] "" True Mac -> do
>> return () liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
stopService :: Service -> OS -> App () _ -> do
stopService (Service { service }) os executeRoot "systemctl" ["start", service] "" True
| os == Mac = liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically." execute "sleep" ["5s"] "" True
| otherwise = executeRoot "systemctl" ["stop", service] "" True return ()
>> return ()
stopService :: Service -> App ()
stopService (Service { service }) = do
(AppState { os }) <- get
case os of
Mac -> do
liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically."
_ -> do
executeRoot "systemctl" ["stop", service] "" True
return ()

43
src/System/Serverman/Actions/VsFTPd.hs
View File

@ -1,43 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.VsFTPd (vsftpd) where
import System.Serverman.Utils
import System.Serverman.Services
import System.Serverman.Actions.FileSharing
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.Free
import Data.List
import Data.Either
import Control.Monad.State
vsftpd :: FileSharingParams -> App ()
vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) =
do
let content = show params
original = config fService
userList = takeDirectory original </> "vsftpd-serverman-user-list"
when fRecreateUser $ executeRoot "userdel" [fUser] "" True >> return ()
(Right opensslResponse) <- execute "openssl" ["passwd", "-1", fPass] "" True
let encryptedPassword = head . lines $ opensslResponse
executeRoot "useradd" [fUser, "-d", fDirectory, "-G", "ftp", "-p", encryptedPassword] "" True
liftIO $ do
renameFileIfMissing original (original ++ ".backup")
writeFile original content
writeFile userList fUser
result <- restartService "vsftpd"
case result of
Left err -> return ()
Right _ ->
liftIO $ putStrLn $ "restarted " ++ show fService

59
src/System/Serverman/Actions/WebServer.hs
View File

@ -1,59 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) where
import System.Serverman.Utils
import System.Serverman.Services
import Control.Monad.Free
data ServerType = Static | PortForwarding deriving (Show, Eq)
data ServerParams = ServerParams { wDirectory :: FilePath
, domain :: String
, port :: String
, forward :: String
, email :: String
, ssl :: Bool
, serverType :: ServerType
, serverService :: Service
} deriving (Eq)
instance Show ServerParams where
show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService })
| name serverService == "nginx" =
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", wDirectory)]) " ") ++ "\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
| otherwise = "Unknown service provider"

7
src/System/Serverman/Services.hs
View File

@ -17,11 +17,10 @@ module System.Serverman.Services ( Service(..)
packageByOS (Service { packages }) os = fromMaybe (fromJust $ lookup Unknown packages) (lookup os packages) packageByOS (Service { packages }) os = fromMaybe (fromJust $ lookup Unknown packages) (lookup os packages)
info :: Service -> String info :: Service -> String
info s@(Service { config, packages, service, version, dependencies }) = info s@(Service { packages, service, version, dependencies }) =
show s ++ ( show s ++ (
indent $ indent $
keyvalue [ ("config", config) keyvalue [ ("pacakges", commas $ map (commas . snd) packages)
, ("pacakges", commas $ map (commas . snd) packages)
, ("service", service) , ("service", service)
, ("dependencies", commas $ map name dependencies)] ": " , ("dependencies", commas dependencies)] ": "
) )

15
src/System/Serverman/Types.hs
View File

@ -57,11 +57,10 @@ module System.Serverman.Types ( Service (..)
| os == Unknown = "_" | os == Unknown = "_"
data Service = Service { name :: String data Service = Service { name :: String
, config :: String
, packages :: [(OS, [String])] , packages :: [(OS, [String])]
, service :: String , service :: String
, version :: String , version :: String
, dependencies :: [Service] , dependencies :: [String]
, category :: String , category :: String
} deriving (Eq, Generic) } deriving (Eq, Generic)
@ -74,15 +73,19 @@ module System.Serverman.Types ( Service (..)
type Repository = [Service] type Repository = [Service]
data AppState = AppState { remoteMode :: Maybe (Address, String) data AppState = AppState { remoteMode :: Maybe (Address, String)
, repository :: Repository , repository :: Repository
, repositoryURL :: String , repositoryURL :: String
, os :: OS
, arguments :: [(String, Maybe String)]
} deriving (Show) } deriving (Show)
instance Default AppState where instance Default AppState where
def = AppState { remoteMode = Nothing def = AppState { remoteMode = Nothing
, repository = def , repository = def
, repositoryURL = "https://github.com/mdibaiee/serverman-repository" , repositoryURL = "https://github.com/mdibaiee/serverman-repository"
, os = Unknown
, arguments = []
} }
type App = StateT AppState IO type App = StateT AppState IO

37
src/System/Term.hs
View File

@ -17,6 +17,7 @@ module System.Term ( initialize ) where
import Data.List import Data.List
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Actions.Repository
initialize = do initialize = do
args <- getArgs args <- getArgs
@ -24,29 +25,39 @@ module System.Term ( initialize ) where
dir <- liftIO $ getAppUserDataDirectory "serverman" dir <- liftIO $ getAppUserDataDirectory "serverman"
let path = dir </> "repository" let path = dir </> "repository"
liftIO $ print args
let params = parseParams args let params = parseParams args
liftIO $ print params liftIO $ print params
-- Fetch repository first -- Fetch repository first
S.runApp $ do S.runApp $ do
S.run (S.fetchRepository) S.run (S.fetchRepository)
S.run (S.detectOS)
state@(S.AppState { S.repository }) <- get state@(S.AppState { S.repository }) <- get
put $ state { arguments = rest params }
case params of case params of
(Params { listServices = True }) -> liftIO $ do (Params { listServices = True }) -> liftIO $ do
mapM_ print repository mapM_ print repository
(Params { install = Just service }) -> do (Params { install = Just service }) -> do
os <- S.run S.detectOS ms <- findService service
S.run (S.install (findService repository service) os) case ms of
Just s -> S.run (S.install s)
Nothing -> liftIO $ putStrLn $ "service not found: " ++ service
(Params { rest = (x:xs) }) -> do
case x of
(service, Nothing) -> do
ms <- findService service
case ms of
Just s -> S.run (S.call s)
Nothing -> liftIO $ putStrLn $ "could not find any service matching " ++ service
_ -> liftIO $ putStrLn $ "could not understand your input"
{-S.run (S.call (head repository) [])-} {-S.run (S.call (head repository) [])-}
return () return ()
where where
findService repository n = fromJust $ find (\a -> S.name a == n) repository
data Manage = Start | Stop deriving (Eq, Show) data Manage = Start | Stop deriving (Eq, Show)
@ -56,6 +67,7 @@ module System.Term ( initialize ) where
, update :: Bool , update :: Bool
, remote :: Maybe FilePath , remote :: Maybe FilePath
, help :: Bool , help :: Bool
, rest :: [(String, Maybe String)]
} deriving (Show) } deriving (Show)
instance Default Params where instance Default Params where
@ -65,6 +77,7 @@ module System.Term ( initialize ) where
, remote = Nothing , remote = Nothing
, update = False , update = False
, help = False , help = False
, rest = []
} }
parseParams :: [String] -> Params parseParams :: [String] -> Params
@ -76,8 +89,20 @@ module System.Term ( initialize ) where
parseParams ("--remote":s:xs) = (parseParams xs) { remote = Just s } parseParams ("--remote":s:xs) = (parseParams xs) { remote = Just s }
parseParams ("--help":xs) = (parseParams xs) { help = True } parseParams ("--help":xs) = (parseParams xs) { help = True }
parseParams ("-h":xs) = (parseParams xs) { help = True } parseParams ("-h":xs) = (parseParams xs) { help = True }
parseParams [] = def parseParams [] = def { help = True }
parseParams _ = Params { help = True } parseParams x = def { rest = toPairs x }
where
toPairs [] = []
toPairs [x] = [(getWord x, Nothing)]
toPairs (x:y:xs)
| flagName x && value y = [(getWord x, Just y)] ++ toPairs xs
| flagName y && value x = [(getWord x, Nothing)] ++ toPairs (y:xs)
| flagName x && flagName y = [(getWord x, Nothing)] ++ toPairs (y:xs)
| otherwise = toPairs xs
flagName = isPrefixOf "-"
value = not . flagName
getWord = dropWhile (== '-')
{-WEB SERVER -} {-WEB SERVER -}
{-data Params = WebServerParams { directory :: String-} {-data Params = WebServerParams { directory :: String-}

45
src/System/Term/Database.hs
View File

@ -1,45 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.Database (mode, handle, Params(..)) where
import System.Console.CmdArgs hiding (name)
import qualified System.Console.CmdArgs as C (name)
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory
data Params = Params { name :: String
, service :: String
, dummyData :: Bool
, user :: String
, pass :: String
, host :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { name = "test" &= help "database name, defaults to test"
, service = "mysql" &= help "service to setup: mysql, defaults to mysql"
, dummyData = False &= help "generate dummy data in the database" &= explicit &= C.name "dummy-data"
, user = "root" &= help "database's username, defaults to root"
, pass = "" &= help "database's password, defaults to blank string"
, host = "127.0.0.1" &= help "database's host, defaults to localhost"
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir
} &= explicit &= C.name "database"
handle (Params { name, service, dummyData, user, pass, host, remote }) =
R.handle remote $ do
let serviceName = read service
let params = S.DatabaseParams { S.database = name
, S.databaseService = serviceName
, S.dummyData = dummyData
, S.databaseUser = user
, S.databasePass = pass
, S.databaseHost = host
}
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newDatabase params

53
src/System/Term/FileSharing.hs
View File

@ -1,53 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.FileSharing (mode, handle, Params(..)) where
import System.Console.CmdArgs
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory hiding (writable)
data Params = Params { directory :: String
, user :: String
, pass :: String
, port :: String
, writable :: Bool
, anonymous :: Bool
, anonymousWrite :: Bool
, recreateUser :: Bool
, service :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { directory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory"
, user = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user"
, pass = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password"
, anonymous = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous"
, anonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write"
, writable = True &= help "allow write operations, defaults to True" &= explicit &= name "writable"
, port = "21" &= help "service port, defaults to 21" &= explicit &= name "port"
, service = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service"
, recreateUser = False &= help "recreate the user" &= explicit &= name "recreate-user"
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
} &= explicit &= name "filesharing"
handle (Params { directory, user, pass, port, anonymous, anonymousWrite, writable, service, recreateUser, remote }) =
R.handle remote $ do
let serviceName = read service
let params = S.FileSharingParams { S.fDirectory = directory
, S.fUser = user
, S.fPass = pass
, S.fPort = port
, S.fAnonymous = anonymous
, S.fAnonymousWrite = anonymousWrite
, S.fWritable = writable
, S.fService = serviceName
, S.fRecreateUser = recreateUser
}
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newFileSharing params

27
src/System/Term/Install.hs
View File

@ -1,27 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.Install (mode, handle, Params(..)) where
import System.Console.CmdArgs
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory
data Params = Params { service :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { service = def &= argPos 0
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
}
handle (Params { service, remote }) =
R.handle remote $ do
let serviceName = read service
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)

10
src/System/Term/Remote.hs
View File

@ -1,10 +0,0 @@
module System.Term.Remote (handle) where
import qualified System.Serverman as S
handle file generateAction
| null file = S.run =<< generateAction
| otherwise = do
list <- map read . lines <$> readFile file
action <- generateAction
S.run $ S.remote list action

60
src/System/Term/WebServer.hs
View File

@ -1,60 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.WebServer (mode, handle, Params(..)) where
import System.Console.CmdArgs
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory
data Params = Params { directory :: String
, domain :: String
, port :: String
, forward :: String
, service :: String
, ssl :: Bool
, email :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { directory = "/var/www/html/" &= typDir &= help "directory to serve static files from, defaults to /var/www/html/"
, domain = "test.dev" &= typ "DOMAIN" &= help "domain/server name, defaults to test.dev"
, port = def &= typ "PORT" &= help "port number to listen to, defaults to 80 for http and 443 for https"
, forward = def &= typ "PORT" &= help "the port to forward to (in case of a port-forwarding server)"
, ssl = False &= help "create a letsencrypt certificate for this domain, defaults to false"
, email = def &= help "email required for registering your certificate"
, service = "nginx" &= help "service to build config for: nginx, defaults to nginx"
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
} &= explicit &= name "webserver"
handle (Params { directory, domain, port, ssl, forward, service, email, remote }) =
R.handle remote $ do
when (ssl && null email) $ die "Email is required for generating a certificate"
let serverType
| (not . null) forward = S.PortForwarding
| otherwise = S.Static
let serviceName = read service :: S.Service
let portNumber
| (not . null) port = port
| ssl = "443"
| otherwise = "80"
absoluteDirectory <- makeAbsolute directory
let params = S.ServerParams { S.wDirectory = absoluteDirectory
, S.domain = domain
, S.port = portNumber
, S.ssl = ssl
, S.forward = forward
, S.serverType = serverType
, S.serverService = serviceName
, S.email = email
}
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newServer params