feat(remote): run commands on remote machines

This commit is contained in:
Mahdi Dibaiee 2017-03-11 13:51:38 +03:30
parent 3a2e331d1a
commit f9d802ee71
12 changed files with 395 additions and 154 deletions

View File

@ -48,6 +48,10 @@ library
, mongoDB >= 2.1.1.1 && < 3
, text
, bytestring
, unix
, Unixutils
, mtl
, monad-control
default-language: Haskell2010
executable serverman

View File

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

View File

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

View File

@ -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 ()

View File

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

View File

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

View File

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

View File

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

View File

@ -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 ()

View File

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

View File

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

View File

@ -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 ()