diff --git a/serverman.cabal b/serverman.cabal index 55ec6bd..2b189bb 100644 --- a/serverman.cabal +++ b/serverman.cabal @@ -48,6 +48,10 @@ library , mongoDB >= 2.1.1.1 && < 3 , text , bytestring + , unix + , Unixutils + , mtl + , monad-control default-language: Haskell2010 executable serverman diff --git a/src/System/Serverman.hs b/src/System/Serverman.hs index 1cb672e..e914fd5 100644 --- a/src/System/Serverman.hs +++ b/src/System/Serverman.hs @@ -29,7 +29,7 @@ module System.Serverman ( run import Control.Monad.Free - run :: Action r -> IO r + 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 diff --git a/src/System/Serverman/Actions/Env.hs b/src/System/Serverman/Actions/Env.hs index b9fa15d..43497e5 100644 --- a/src/System/Serverman/Actions/Env.hs +++ b/src/System/Serverman/Actions/Env.hs @@ -4,6 +4,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where import Data.List import System.IO.Error import Data.Either + import Data.Char data OS = Debian | Arch | Mac | Unknown deriving (Show, Eq) @@ -12,7 +13,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where deb_release <- execute "cat" ["/etc/lsb-release"] "" False mac_release <- execute "sw_vers" ["-productName"] "" False - let release = head $ rights [arch_release, deb_release, mac_release] + let release = map toLower . head . rights $ [arch_release, deb_release, mac_release] distro | or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian | "arch" `isInfixOf` release = Arch diff --git a/src/System/Serverman/Actions/Install.hs b/src/System/Serverman/Actions/Install.hs index 9a975c2..72b927d 100644 --- a/src/System/Serverman/Actions/Install.hs +++ b/src/System/Serverman/Actions/Install.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module System.Serverman.Actions.Install (installService, package, dependencies) where import System.Serverman.Action import System.Serverman.Utils @@ -8,8 +10,9 @@ module System.Serverman.Actions.Install (installService, package, dependencies) import System.IO.Error import System.Process import Control.Concurrent.Async - import Control.Monad.Free import Control.Monad + import Control.Monad.State + import Control.Monad.Trans.Control class Installable a where dependencies :: a -> [a] @@ -32,7 +35,7 @@ module System.Serverman.Actions.Install (installService, package, dependencies) package SSHFs _ = "sshfs" - installService :: Service -> OS -> IO () + installService :: Service -> OS -> App () installService service os = do forM_ (dependencies service) (`installService` os) @@ -43,11 +46,13 @@ module System.Serverman.Actions.Install (installService, package, dependencies) _ -> ("echo", ["Unknown operating system"]) pkg = package service os - process <- async $ do + process <- liftedAsync $ do result <- executeRoot (fst base) (snd base ++ [pkg]) "" True case result of Left err -> return () Right _ -> do - putStrLn $ "installed " ++ show service ++ "." - wait process + liftIO $ putStrLn $ "installed " ++ show service ++ "." + + liftIO $ wait process + return () diff --git a/src/System/Serverman/Actions/MongoDB.hs b/src/System/Serverman/Actions/MongoDB.hs index 1440e3d..85089bb 100644 --- a/src/System/Serverman/Actions/MongoDB.hs +++ b/src/System/Serverman/Actions/MongoDB.hs @@ -8,10 +8,11 @@ module System.Serverman.Actions.MongoDB (mongodb) where import Data.List hiding (delete) import qualified Data.Text as T import Control.Monad + import Control.Monad.State import System.IO.Error - mongodb :: DatabaseParams -> IO () - mongodb (DatabaseParams { database, dummyData, databaseHost }) = do + mongodb :: DatabaseParams -> App () + mongodb (DatabaseParams { database, dummyData, databaseHost }) = liftIO $ do result <- tryIOError $ connect (readHostPort databaseHost) case result of diff --git a/src/System/Serverman/Actions/MySQL.hs b/src/System/Serverman/Actions/MySQL.hs index 1b27fab..2f54379 100644 --- a/src/System/Serverman/Actions/MySQL.hs +++ b/src/System/Serverman/Actions/MySQL.hs @@ -7,9 +7,10 @@ module System.Serverman.Actions.MySQL (mysql) where import qualified Data.ByteString.Char8 as BS import Data.List import Control.Monad + import Control.Monad.State - mysql :: DatabaseParams -> IO () - mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = do + 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) diff --git a/src/System/Serverman/Actions/Nginx.hs b/src/System/Serverman/Actions/Nginx.hs index 4ac8f09..32ee443 100644 --- a/src/System/Serverman/Actions/Nginx.hs +++ b/src/System/Serverman/Actions/Nginx.hs @@ -12,10 +12,11 @@ module System.Serverman.Actions.Nginx (nginx) where import System.Process import Control.Concurrent.Async import Control.Monad + import Control.Monad.State import Control.Monad.Free import Data.List - nginx :: ServerParams -> IO () + 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 @@ -25,62 +26,66 @@ module System.Serverman.Actions.Nginx (nginx) where path = parent domain targetDir = wDirectory - createDirectoryIfMissing True targetDir - createDirectoryIfMissing True parent + liftIO $ do + createDirectoryIfMissing True targetDir + createDirectoryIfMissing True parent - writeIncludeStatementIfMissing mainConfig parent + writeIncludeStatementIfMissing mainConfig parent - when ssl $ do - let sslPath = configDirectory serverService "ssl.conf" - writeFileIfMissing sslPath nginxSSL - putStrLn $ "wrote ssl configuration to " ++ sslPath + when ssl $ do + let sslPath = configDirectory serverService "ssl.conf" + writeFileIfMissing sslPath nginxSSL + putStrLn $ "wrote ssl configuration to " ++ sslPath - writeFile path content + writeFile path content - putStrLn $ "wrote your configuration file to " ++ path - - wait =<< restart + putStrLn $ "wrote your configuration file to " ++ path + + liftIO . wait =<< restart when ssl $ do let dhparamPath = "/etc/ssl/certs/dhparam.pem" - dhExists <- doesFileExist dhparamPath + dhExists <- liftIO $ doesFileExist dhparamPath when (not dhExists) $ do - dhparam <- async $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True - wait dhparam + dhparam <- liftedAsync $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True + liftIO $ wait dhparam return () case serverType of Static -> do - letsencrypt <- async $ createCert path "letsencrypt" + letsencrypt <- liftedAsync $ createCert path "letsencrypt" - wait letsencrypt - _ -> do + liftIO $ wait letsencrypt + return () + _ -> liftIO $ do putStrLn $ "you should use letsencrypt to create a certificate for your domain" putStrLn $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem" putStrLn $ "my suggestion is running this command:" putStrLn $ "sudo letsencrypt certonly --webroot --webroot-path -d " ++ domain - putStrLn $ "for more information, see: https://certbot.eff.org/" + liftIO $ putStrLn $ "for more information, see: https://certbot.eff.org/" + return () where - restart = async $ do + restart = liftedAsync $ do result <- restartService "nginx" case result of Left err -> return () Right _ -> - putStrLn $ "restarted " ++ show serverService + 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 - putStrLn stdout + liftIO $ putStrLn stdout when (not ("error" `isInfixOf` stdout)) $ do - writeFile path (show params) - wait =<< restart + liftIO $ writeFile path (show params) + liftIO . wait =<< restart + return () writeIncludeStatementIfMissing path target = do content <- readFile path diff --git a/src/System/Serverman/Actions/Remote.hs b/src/System/Serverman/Actions/Remote.hs index 6e87ade..6d8f792 100644 --- a/src/System/Serverman/Actions/Remote.hs +++ b/src/System/Serverman/Actions/Remote.hs @@ -1,38 +1,89 @@ module System.Serverman.Actions.Remote ( runRemotely , Address) where import System.Serverman.Utils + + import System.Unix.Chroot import Data.List import System.Directory import System.IO import System.FilePath + import System.Posix.Env + import System.Posix.Files + import Control.Monad + import Data.Maybe + import Data.IORef + import Control.Monad.State - type Host = String - type Port = String - type User = String - data Address = Address Host Port User + import Debug.Trace - runRemotely :: Address -> IO r -> IO () + runRemotely :: Address -> App r -> App () runRemotely addr@(Address host port user) action = do - let path = "/tmp/serverman/" show addr + let servermanAddr = Address host port "serverman" + p = if null port then [] else ["-p", port] + connection = takeWhile (/= ':') (show addr) + smConnection = "serverman@" ++ host + path = "/tmp/serverman/" connection - createDirectoryIfMissing True path + home <- liftIO getHomeDirectory - execute "sshfs" [show addr, path] "" True + let keyPath = home ".ssh/serverman" + pubPath = keyPath <.> "pub" + + liftIO $ createDirectoryIfMissing True path + + execute "fusermount" ["-u", path] "" False + + let sftpOptions = ["-o", "sftp_server=sudo -u serverman /usr/lib/openssh/sftp-server"] + + result <- execute "sshfs" (p ++ noPassword ++ sftpOptions ++ ["-o", "nonempty", "-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" True + + case result of + Right _ -> do + state <- get + put $ state { remoteMode = Just (servermanAddr, keyPath) } + action + + return () + + Left _ -> do + liftIO $ do + putStrLn $ "it seems to be the first time you are using serverman for configuring " ++ show addr + putStrLn $ "remotely. serverman will create a user, and add it to sudoers file. an ssh key will be created" + putStrLn $ "and that will be used for connecting to the server from now on." + putStrLn $ "you might be prompted for password if you are not using SSH key authentication." + + putStrLn $ "Enter password for " ++ connection + + home <- liftIO getHomeDirectory + password <- liftIO getPassword + + execIfMissing keyPath $ execute "ssh-keygen" ["-N", "", "-f", keyPath] "" True >> return () + + publicKey <- liftIO $ readFile pubPath + + let runCommand a b = execRemote addr Nothing (Just "root") password a b "" Nothing True + runServerman a b = execRemote addr (Just keyPath) (Just "serverman") password a b "" Nothing True + + (Right encryptedPassword) <- execute "openssl" ["passwd", "-1", "serverman"] "" True + runCommand "useradd" ["-m", "-p", (quote . removeTrailingNewline) encryptedPassword, "serverman"] + runCommand "echo" ["'serverman ALL=(ALL) NOPASSWD: ALL'", ">>", "/etc/sudoers"] + + runServerman "mkdir" ["/home/serverman/.ssh", "-p"] + runServerman "touch" ["/home/serverman/.ssh/authorized_keys"] + runServerman "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"] + + return () return () - instance Read Address where - readsPrec _ addr - | '@' `elem` addr = - let (user, rest) = span (== '@') addr - (host, port) = readHostPort rest - in [(Address host port user, [])] - | otherwise = - let (host, port) = readHostPort addr - in [(Address host port "", [])] + where + noPassword = ["-o", "PasswordAuthentication=no", "-o", "PubkeyAuthentication=yes"] - where - readHostPort str = span (== ':') str + chroot path (key, value) + | key == "PATH" = (key, path ++ concatMap (modPath path) value) + | otherwise = (key, value) - instance Show Address where - show (Address host port user) = user ++ "@" ++ host ++ ":" ++ port + modPath path c + | c == ':' = ":" ++ path + | otherwise = [c] + diff --git a/src/System/Serverman/Actions/Start.hs b/src/System/Serverman/Actions/Start.hs index 6ec0675..d1c6274 100644 --- a/src/System/Serverman/Actions/Start.hs +++ b/src/System/Serverman/Actions/Start.hs @@ -4,9 +4,11 @@ module System.Serverman.Actions.Start (startService) where import System.Serverman.Actions.Install import System.Serverman.Services - startService :: Service -> OS -> IO () + import Control.Monad.State + + startService :: Service -> OS -> App () startService service os - | os == Mac = putStrLn $ "Couldn't start " ++ package service os ++ " automatically. If you encounter any problems, make sure it is running." + | os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ package service os ++ " automatically. If you encounter any problems, make sure it is running." | otherwise = executeRoot "systemctl" ["start", package service os] "" True >> execute "sleep" ["5s"] "" True >> return () diff --git a/src/System/Serverman/Actions/VsFTPd.hs b/src/System/Serverman/Actions/VsFTPd.hs index cd6d784..8d54844 100644 --- a/src/System/Serverman/Actions/VsFTPd.hs +++ b/src/System/Serverman/Actions/VsFTPd.hs @@ -15,8 +15,9 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where import Control.Monad.Free import Data.List import Data.Either + import Control.Monad.State - vsftpd :: FileSharingParams -> IO () + vsftpd :: FileSharingParams -> App () vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) = do let content = show params @@ -30,14 +31,13 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where executeRoot "useradd" [fUser, "-d", fDirectory, "-G", "ftp", "-p", encryptedPassword] "" True - renameFileIfMissing original (original ++ ".backup") - - writeFile original content - - writeFile userList fUser + liftIO $ do + renameFileIfMissing original (original ++ ".backup") + writeFile original content + writeFile userList fUser result <- restartService "vsftpd" case result of Left err -> return () Right _ -> - putStrLn $ "restarted " ++ show fService + liftIO $ putStrLn $ "restarted " ++ show fService diff --git a/src/System/Serverman/Utils.hs b/src/System/Serverman/Utils.hs index 30c1e02..22f010d 100644 --- a/src/System/Serverman/Utils.hs +++ b/src/System/Serverman/Utils.hs @@ -1,14 +1,28 @@ -module System.Serverman.Utils ( keyvalue +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +module System.Serverman.Utils ( App (..) + , AppState (..) + , runApp + , keyvalue + , parseKeyValue , semicolon , block , indent + , quote + , removeTrailingNewline + , execIfMissing , writeFileIfMissing , renameFileIfMissing , commandError , appendAfter , exec , execute + , execRemote + , Address (..) + , liftedAsync , restartService + , getPassword , executeRoot) where import System.IO @@ -20,30 +34,56 @@ module System.Serverman.Utils ( keyvalue import Data.List import Control.Exception import System.Exit + import Data.Maybe + import System.Posix.Terminal + import System.Posix.IO (stdInput) + import Data.Maybe + import System.Posix.Files + import System.Posix.Env + import Control.Monad.State + import Control.Monad.Trans.Control + import Data.Default.Class + + import Debug.Trace + + data AppState = AppState { remoteMode :: Maybe (Address, String) } deriving (Show) + + instance Default AppState where + def = AppState { remoteMode = Nothing } + type App = StateT AppState IO + + runApp :: App a -> IO (a, AppState) + runApp k = runStateT k def keyvalue :: [(String, String)] -> String -> String keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit keyvalue [] _ = "" + parseKeyValue :: String -> Char -> [(String, String)] + parseKeyValue text delimit = map parsePair (lines text) + where + parsePair line = + let delimitIndex = fromJust $ delimit `elemIndex` line + (key, value) = splitAt delimitIndex line + in (key, tail value) + semicolon :: String -> String semicolon text = unlines $ map (++ ";") (lines text) block :: String -> String -> String block blockName content = blockName ++ " {\n" ++ indent content ++ "}" - writeFileIfMissing :: FilePath -> String -> IO () - writeFileIfMissing path content = do - exists <- doesFileExist path + execIfMissing :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f () + execIfMissing path action = do + exists <- liftIO $ doesFileExist path - when (not exists) $ do - writeFile path content + when (not exists) action + + writeFileIfMissing :: FilePath -> String -> IO () + writeFileIfMissing path content = execIfMissing path (writeFile path content) renameFileIfMissing :: FilePath -> String -> IO () - renameFileIfMissing path content = do - exists <- doesFileExist path - - when (not exists) $ do - renameFile path content + renameFileIfMissing path content = execIfMissing path (renameFile path content) appendAfter :: String -> String -> String -> String appendAfter content after line = @@ -55,40 +95,144 @@ module System.Serverman.Utils ( keyvalue indent :: String -> String indent s = unlines $ map ("\t" ++) (lines s) + quote :: String -> String + quote input = "'" ++ input ++ "'" + + removeTrailingNewline :: String -> String + removeTrailingNewline input + | (reverse . take 1 . reverse) input == "\n" = take (length input - 1) input + | otherwise = input + commandError :: String -> String commandError command = "[Error] an error occured while running: " ++ command ++ "\nplease try running the command manually." - execute :: String -> [String] -> String -> Bool -> IO (Either String String) + execute :: String -> [String] -> String -> Bool -> App (Either String String) execute cmd args stdin logErrors = exec cmd args stdin Nothing logErrors - exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> IO (Either String String) + exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> App (Either String String) exec cmd args stdin cwd logErrors = do - let command = cmd ++ " " ++ intercalate " " args - cp = (proc cmd args) { cwd = cwd } + (AppState { remoteMode }) <- get - process <- async $ do - result <- tryIOError $ readCreateProcessWithExitCode cp stdin + if isJust remoteMode then do + let (addr, key) = fromJust remoteMode - case result of - Right (ExitSuccess, stdout, _) -> return $ Right stdout + execRemote addr (Just key) (Just "serverman") "" cmd args stdin cwd logErrors + else liftIO $ do + let command = escape $ cmd ++ " " ++ intercalate " " args + cp = (proc (escape cmd) (map escape args)) { cwd = cwd } - Right (ExitFailure code, stdout, stderr) -> do - when logErrors $ do - putStrLn $ "exit code: " ++ show code - putStrLn stdout - putStrLn stderr - putStrLn $ commandError command - return $ Left stdout - Left err -> do - when logErrors $ do - putStrLn $ show err - putStrLn $ commandError command - return $ Left (show err) + process <- async $ do + result <- tryIOError $ readCreateProcessWithExitCode cp stdin - wait process + case result of + Right (ExitSuccess, stdout, _) -> return $ Right stdout - restartService :: String -> IO (Either String String) + Right (ExitFailure code, stdout, stderr) -> do + when logErrors $ do + putStrLn $ "exit code: " ++ show code + putStrLn stdout + putStrLn stderr + putStrLn $ commandError command + return $ Left stdout + Left err -> do + when logErrors $ do + putStrLn $ show err + putStrLn $ commandError command + return $ Left (show err) + + wait process + + where + escape :: String -> String + escape string = foldl' (\str char -> replace str char ('\\':char)) string specialCharacters + where + specialCharacters = ["$"] + + type Host = String + type Port = String + type User = String + data Address = Address Host Port User + + instance Read Address where + readsPrec _ addr + | '@' `elem` addr = + let (user, rest) = (takeWhile (/= '@') addr, tail $ dropWhile (/= '@') addr) + (host, port) = readHostPort rest + in [(Address host port user, [])] + | otherwise = + let (host, port) = readHostPort addr + in [(Address host port "", [])] + + where + readHostPort str = (takeWhile (/= ':') str, tail $ dropWhile (/= ':') str) + + instance Show Address where + show (Address host port user) + | (not . null) user = user ++ "@" ++ show (Address host port "") + | (not . null) port = show (Address host "" "") ++ ":" ++ port + | otherwise = host + + execRemote :: Address -> Maybe String -> Maybe String -> String -> String -> [String] -> String -> Maybe String -> Bool -> App (Either String String) + execRemote addr@(Address host port user) maybeKey maybeUser password cmd args stdin cwd logErrors = do + let userArgument = if isJust maybeUser then ["echo", password, "|", "sudo -S", "-u", fromJust maybeUser] else [] + keyArgument = if isJust maybeKey then ["-o", "IdentityFile=" ++ fromJust maybeKey] ++ noPassword else noKey + p = if null port then [] else ["-p", port] + connection = takeWhile (/= ':') (show addr) + + cumulated = p ++ keyArgument ++ options + command = userArgument ++ ["sh -c \"", cmd] ++ args ++ ["\""] + + (backupEnv, passwordFile) <- liftIO $ do + backupEnv <- getEnvironment + + writeFile passwordFile $ "echo " ++ password + setFileMode passwordFile ownerExecuteMode + setEnv "SSH_ASKPASS" passwordFile True + + return (backupEnv, passwordFile) + + state <- get + let (AppState { remoteMode = backup }) = state + put $ state { remoteMode = Nothing } + result <- exec "setsid" ("ssh" : cumulated ++ [connection] ++ command) stdin cwd logErrors + put $ state { remoteMode = backup } + + liftIO $ do + setEnvironment backupEnv + removeFile passwordFile + + return result + where + passwordFile = "/tmp/serverman/pw" + noPassword = ["-o", "PasswordAuthentication=no", "-o", "PubkeyAuthentication=yes"] + noKey = ["-o", "PubkeyAuthentication=no", "-o", "PasswordAuthentication=yes"] + options = ["-o", "StrictHostKeyChecking=no"] + + replace :: String -> String -> String -> String + replace str replacable alt = + foldl' rep "" str + where + rep acc n + | takeEnd (l - 1) acc ++ [n] == replacable = (dropEnd (l - 1) acc) ++ alt + | otherwise = acc ++ [n] + + l = length replacable + takeEnd n = reverse . take n . reverse + dropEnd n = reverse . drop n . reverse + + restartService :: String -> App (Either String String) restartService service = executeRoot "systemctl" ["restart", service] "" True - executeRoot :: String -> [String] -> String -> Bool -> IO (Either String String) + executeRoot :: String -> [String] -> String -> Bool -> App (Either String String) executeRoot cmd args stdin logErrors = execute "sudo" (cmd:args) stdin logErrors + + getPassword :: IO String + getPassword = do + tc <- getTerminalAttributes stdInput + setTerminalAttributes stdInput (withoutMode tc EnableEcho) Immediately + password <- getLine + setTerminalAttributes stdInput tc Immediately + return password + + liftedAsync :: MonadBaseControl IO m => m a -> m (Async (StM m a)) + liftedAsync m = liftBaseWith $ \runInIO -> async (runInIO m) diff --git a/src/System/Term.hs b/src/System/Term.hs index 3ff7cd8..37c871a 100644 --- a/src/System/Term.hs +++ b/src/System/Term.hs @@ -13,6 +13,7 @@ module System.Term ( initialize ) where import Data.Monoid import Data.Maybe import Control.Monad + import Control.Monad.State initialize = do args <- getArgs @@ -58,6 +59,7 @@ module System.Term ( initialize ) where , wService :: String , ssl :: Bool , email :: String + , wRemote :: String } | DatabaseParams { databaseName :: String , dService :: String @@ -65,6 +67,7 @@ module System.Term ( initialize ) where , dUser :: String , dPass :: String , dHost :: String + , dRemote :: String } | FileSharingParams { fDirectory :: String @@ -76,9 +79,10 @@ module System.Term ( initialize ) where , fAnonymousWrite :: Bool , fRecreateUser :: Bool , fService :: String + , fRemote :: String } - | InstallParams { iService :: String } + | InstallParams { iService :: String, remote :: String } deriving (Show, Data, Typeable) @@ -89,6 +93,7 @@ module System.Term ( initialize ) where , ssl = False &= help "create a letsencrypt certificate for this domain, defaults to false" , email = def &= help "email required for registering your certificate" , wService = "nginx" &= help "service to build config for: nginx, defaults to nginx" &= explicit &= name "service" + , wRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" } &= explicit &= name "webserver" database = DatabaseParams { databaseName = "test" &= help "database name, defaults to test" &= explicit &= name "name" @@ -97,6 +102,7 @@ module System.Term ( initialize ) where , dUser = "root" &= help "database's username, defaults to root" &= explicit &= name "user" , dPass = "" &= help "database's password, defaults to blank string" &= explicit &= name "password" , dHost = "127.0.0.1" &= help "database's host, defaults to localhost" &= explicit &= name "host" + , dRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" } &= explicit &= name "database" filesharing = FileSharingParams { fDirectory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory" @@ -108,78 +114,99 @@ module System.Term ( initialize ) where , fPort = "21" &= help "service port, defaults to 21" &= explicit &= name "port" , fService = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service" , fRecreateUser = False &= help "recreate the user" &= explicit &= name "recreate-user" + , fRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" } &= explicit &= name "filesharing" install = InstallParams { iService = def &= argPos 0 + , remote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" } &= explicit &= name "install" - webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email }) = do - when (ssl && null email) $ die "Email is required for generating a certificate" + webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email, wRemote }) = do + remoteSetup wRemote $ do + when (ssl && null email) $ die "Email is required for generating a certificate" - let serverType - | (not . null) forward = S.PortForwarding - | otherwise = S.Static + let serverType + | (not . null) forward = S.PortForwarding + | otherwise = S.Static - let serviceName = read wService :: Service + let serviceName = read wService :: Service - let portNumber - | (not . null) port = port - | ssl = "443" - | otherwise = "80" + let portNumber + | (not . null) port = port + | ssl = "443" + | otherwise = "80" - absoluteDirectory <- makeAbsolute directory + 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 - } - S.run $ S.detectOS >>= (S.install serviceName) - >> S.detectOS >>= (S.start serviceName) - >> S.newServer params + 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 - manualInstall (InstallParams { iService }) = do - let serviceName = read iService :: Service + manualInstall (InstallParams { iService, remote }) = + remoteSetup remote $ do + let serviceName = read iService :: Service - S.run $ S.detectOS >>= (S.install serviceName) - >> S.detectOS >>= (S.start serviceName) + return $ S.detectOS >>= (S.install serviceName) + >> S.detectOS >>= (S.start serviceName) - databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost }) = do - let serviceName = read dService + databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do + remoteSetup dRemote $ do + let serviceName = read dService - let params = S.DatabaseParams { S.database = databaseName - , S.databaseService = serviceName - , S.dummyData = dummyData - , S.databaseUser = dUser - , S.databasePass = dPass - , S.databaseHost = dHost - } + let params = S.DatabaseParams { S.database = databaseName + , S.databaseService = serviceName + , S.dummyData = dummyData + , S.databaseUser = dUser + , S.databasePass = dPass + , S.databaseHost = dHost + } - S.run $ S.detectOS >>= (S.install serviceName) - >> S.detectOS >>= (S.start serviceName) - >> S.newDatabase params + return $ S.detectOS >>= (S.install serviceName) + >> S.detectOS >>= (S.start serviceName) + >> S.newDatabase params - fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) = do - let serviceName = read fService + fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser, fRemote }) = do + remoteSetup fRemote $ do + let serviceName = read fService - let params = S.FileSharingParams { S.fDirectory = fDirectory - , S.fUser = fUser - , S.fPass = fPass - , S.fPort = fPort - , S.fAnonymous = fAnonymous - , S.fAnonymousWrite = fAnonymousWrite - , S.fWritable = fWritable - , S.fService = serviceName - , S.fRecreateUser = fRecreateUser - } + let params = S.FileSharingParams { S.fDirectory = fDirectory + , S.fUser = fUser + , S.fPass = fPass + , S.fPort = fPort + , S.fAnonymous = fAnonymous + , S.fAnonymousWrite = fAnonymousWrite + , S.fWritable = fWritable + , S.fService = serviceName + , S.fRecreateUser = fRecreateUser + } - S.run $ S.detectOS >>= (S.install serviceName) - >> S.detectOS >>= (S.start serviceName) - >> S.newFileSharing params + return $ S.detectOS >>= (S.install serviceName) + >> S.detectOS >>= (S.start serviceName) + >> S.newFileSharing params + remoteSetup file generateAction + | null file = do + action <- generateAction + S.runApp $ + S.run action + + return () + + | otherwise = do + list <- liftIO $ map read . lines <$> readFile file + action <- generateAction + S.runApp $ S.run $ S.remote list action + + return () +