refactor(services): move services to repository

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

0
memory_logfile Normal file
View File

View File

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

View File

@ -21,12 +21,12 @@ module System.Serverman ( run
run :: Action r -> App r
run (Pure r) = return r
run (Free (DetectOS next)) = getOS >>= run . next
run (Free (Start os service next)) = startService os service >> run next
run (Free (Stop os service next)) = stopService os service >> run next
run (Free (Install os service next)) = installService os service >> run next
run (Free (DetectOS next)) = getOS >> run next
run (Free (Start service next)) = startService service >> run next
run (Free (Stop service next)) = stopService 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

View File

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

View File

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

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"]])

View File

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

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"

View File

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

View File

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

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 ++ "')"

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 ++ "')"

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"

View File

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

View File

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

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

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"

View File

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

View File

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

View File

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

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

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

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)

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

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