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 , mongoDB >= 2.1.1.1 && < 3
, text , text
, bytestring , bytestring
, unix
, Unixutils
, mtl
, monad-control
default-language: Haskell2010 default-language: Haskell2010
executable serverman executable serverman

View File

@ -29,7 +29,7 @@ module System.Serverman ( run
import Control.Monad.Free import Control.Monad.Free
run :: Action r -> IO r run :: Action r -> App r
run (Pure r) = return r run (Pure r) = return r
run (Free (DetectOS next)) = getOS >>= run . next run (Free (DetectOS next)) = getOS >>= run . next
run (Free (Start os service next)) = startService os service >> run next run (Free (Start 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 Data.List
import System.IO.Error import System.IO.Error
import Data.Either import Data.Either
import Data.Char
data OS = Debian | Arch | Mac | Unknown deriving (Show, Eq) 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 deb_release <- execute "cat" ["/etc/lsb-release"] "" False
mac_release <- execute "sw_vers" ["-productName"] "" 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 distro
| or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian | or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian
| "arch" `isInfixOf` release = Arch | "arch" `isInfixOf` release = Arch

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module System.Serverman.Actions.Install (installService, package, dependencies) where module System.Serverman.Actions.Install (installService, package, dependencies) where
import System.Serverman.Action import System.Serverman.Action
import System.Serverman.Utils import System.Serverman.Utils
@ -8,8 +10,9 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
import System.IO.Error import System.IO.Error
import System.Process import System.Process
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Monad.Free
import Control.Monad import Control.Monad
import Control.Monad.State
import Control.Monad.Trans.Control
class Installable a where class Installable a where
dependencies :: a -> [a] dependencies :: a -> [a]
@ -32,7 +35,7 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
package SSHFs _ = "sshfs" package SSHFs _ = "sshfs"
installService :: Service -> OS -> IO () installService :: Service -> OS -> App ()
installService service os = do installService service os = do
forM_ (dependencies service) (`installService` os) forM_ (dependencies service) (`installService` os)
@ -43,11 +46,13 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
_ -> ("echo", ["Unknown operating system"]) _ -> ("echo", ["Unknown operating system"])
pkg = package service os pkg = package service os
process <- async $ do process <- liftedAsync $ do
result <- executeRoot (fst base) (snd base ++ [pkg]) "" True result <- executeRoot (fst base) (snd base ++ [pkg]) "" True
case result of case result of
Left err -> return () Left err -> return ()
Right _ -> do Right _ -> do
putStrLn $ "installed " ++ show service ++ "." liftIO $ putStrLn $ "installed " ++ show service ++ "."
wait process
liftIO $ wait process
return ()

View File

@ -8,10 +8,11 @@ module System.Serverman.Actions.MongoDB (mongodb) where
import Data.List hiding (delete) import Data.List hiding (delete)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad import Control.Monad
import Control.Monad.State
import System.IO.Error import System.IO.Error
mongodb :: DatabaseParams -> IO () mongodb :: DatabaseParams -> App ()
mongodb (DatabaseParams { database, dummyData, databaseHost }) = do mongodb (DatabaseParams { database, dummyData, databaseHost }) = liftIO $ do
result <- tryIOError $ connect (readHostPort databaseHost) result <- tryIOError $ connect (readHostPort databaseHost)
case result of case result of

View File

@ -7,9 +7,10 @@ module System.Serverman.Actions.MySQL (mysql) where
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.List import Data.List
import Control.Monad import Control.Monad
import Control.Monad.State
mysql :: DatabaseParams -> IO () mysql :: DatabaseParams -> App ()
mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = do mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = liftIO $ do
conn <- connect $ defaultConnectInfo { connectUser = databaseUser, connectPassword = databasePass, connectHost = databaseHost } conn <- connect $ defaultConnectInfo { connectUser = databaseUser, connectPassword = databasePass, connectHost = databaseHost }
query conn $ BS.pack ("CREATE DATABASE IF NOT EXISTS " ++ database) 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 System.Process
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Monad import Control.Monad
import Control.Monad.State
import Control.Monad.Free import Control.Monad.Free
import Data.List import Data.List
nginx :: ServerParams -> IO () nginx :: ServerParams -> App ()
nginx params@(ServerParams { ssl, serverService, domain, wDirectory, serverType, email }) = nginx params@(ServerParams { ssl, serverService, domain, wDirectory, serverType, email }) =
do do
-- Turn SSL off at first, because we have not yet received a certificate -- Turn SSL off at first, because we have not yet received a certificate
@ -25,6 +26,7 @@ module System.Serverman.Actions.Nginx (nginx) where
path = parent </> domain path = parent </> domain
targetDir = wDirectory targetDir = wDirectory
liftIO $ do
createDirectoryIfMissing True targetDir createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent createDirectoryIfMissing True parent
@ -39,48 +41,51 @@ module System.Serverman.Actions.Nginx (nginx) where
putStrLn $ "wrote your configuration file to " ++ path putStrLn $ "wrote your configuration file to " ++ path
wait =<< restart liftIO . wait =<< restart
when ssl $ do when ssl $ do
let dhparamPath = "/etc/ssl/certs/dhparam.pem" let dhparamPath = "/etc/ssl/certs/dhparam.pem"
dhExists <- doesFileExist dhparamPath dhExists <- liftIO $ doesFileExist dhparamPath
when (not dhExists) $ do when (not dhExists) $ do
dhparam <- async $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True dhparam <- liftedAsync $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True
wait dhparam liftIO $ wait dhparam
return () return ()
case serverType of case serverType of
Static -> do Static -> do
letsencrypt <- async $ createCert path "letsencrypt" letsencrypt <- liftedAsync $ createCert path "letsencrypt"
wait letsencrypt liftIO $ wait letsencrypt
_ -> do return ()
_ -> liftIO $ do
putStrLn $ "you should use letsencrypt to create a certificate for your domain" putStrLn $ "you should use letsencrypt to create a certificate for your domain"
putStrLn $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem" putStrLn $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem"
putStrLn $ "my suggestion is running this command:" putStrLn $ "my suggestion is running this command:"
putStrLn $ "sudo letsencrypt certonly --webroot --webroot-path <YOUR_APPLICATION_DIRECTORY> -d " ++ domain 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 () return ()
where where
restart = async $ do restart = liftedAsync $ do
result <- restartService "nginx" result <- restartService "nginx"
case result of case result of
Left err -> return () Left err -> return ()
Right _ -> Right _ ->
putStrLn $ "restarted " ++ show serverService liftIO $ putStrLn $ "restarted " ++ show serverService
createCert path cmd = do createCert path cmd = do
result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", wDirectory, "-d", domain, "--email", email, "--agree-tos", "-n"] "" False result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", wDirectory, "-d", domain, "--email", email, "--agree-tos", "-n"] "" False
case result of case result of
Left _ -> if cmd == "letsencrypt" then createCert path "certbot" else return () Left _ -> if cmd == "letsencrypt" then createCert path "certbot" else return ()
Right stdout -> do Right stdout -> do
putStrLn stdout liftIO $ putStrLn stdout
when (not ("error" `isInfixOf` stdout)) $ do when (not ("error" `isInfixOf` stdout)) $ do
writeFile path (show params) liftIO $ writeFile path (show params)
wait =<< restart liftIO . wait =<< restart
return ()
writeIncludeStatementIfMissing path target = do writeIncludeStatementIfMissing path target = do
content <- readFile path content <- readFile path

View File

@ -1,38 +1,89 @@
module System.Serverman.Actions.Remote ( runRemotely module System.Serverman.Actions.Remote ( runRemotely
, Address) where , Address) where
import System.Serverman.Utils import System.Serverman.Utils
import System.Unix.Chroot
import Data.List import Data.List
import System.Directory import System.Directory
import System.IO import System.IO
import System.FilePath 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 import Debug.Trace
type Port = String
type User = String
data Address = Address Host Port User
runRemotely :: Address -> IO r -> IO () runRemotely :: Address -> App r -> App ()
runRemotely addr@(Address host port user) action = do 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 () return ()
instance Read Address where Left _ -> do
readsPrec _ addr liftIO $ do
| '@' `elem` addr = putStrLn $ "it seems to be the first time you are using serverman for configuring " ++ show addr
let (user, rest) = span (== '@') addr putStrLn $ "remotely. serverman will create a user, and add it to sudoers file. an ssh key will be created"
(host, port) = readHostPort rest putStrLn $ "and that will be used for connecting to the server from now on."
in [(Address host port user, [])] putStrLn $ "you might be prompted for password if you are not using SSH key authentication."
| otherwise =
let (host, port) = readHostPort addr putStrLn $ "Enter password for " ++ connection
in [(Address host port "", [])]
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 ()
where where
readHostPort str = span (== ':') str noPassword = ["-o", "PasswordAuthentication=no", "-o", "PubkeyAuthentication=yes"]
chroot path (key, value)
| key == "PATH" = (key, path ++ concatMap (modPath path) value)
| otherwise = (key, value)
modPath path c
| c == ':' = ":" ++ path
| otherwise = [c]
instance Show Address where
show (Address host port user) = user ++ "@" ++ host ++ ":" ++ port

View File

@ -4,9 +4,11 @@ module System.Serverman.Actions.Start (startService) where
import System.Serverman.Actions.Install import System.Serverman.Actions.Install
import System.Serverman.Services import System.Serverman.Services
startService :: Service -> OS -> IO () import Control.Monad.State
startService :: Service -> OS -> App ()
startService service os 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 | otherwise = executeRoot "systemctl" ["start", package service os] "" True
>> execute "sleep" ["5s"] "" True >> execute "sleep" ["5s"] "" True
>> return () >> return ()

View File

@ -15,8 +15,9 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where
import Control.Monad.Free import Control.Monad.Free
import Data.List import Data.List
import Data.Either 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 }) = vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) =
do do
let content = show params 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 executeRoot "useradd" [fUser, "-d", fDirectory, "-G", "ftp", "-p", encryptedPassword] "" True
liftIO $ do
renameFileIfMissing original (original ++ ".backup") renameFileIfMissing original (original ++ ".backup")
writeFile original content writeFile original content
writeFile userList fUser writeFile userList fUser
result <- restartService "vsftpd" result <- restartService "vsftpd"
case result of case result of
Left err -> return () Left err -> return ()
Right _ -> 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 , semicolon
, block , block
, indent , indent
, quote
, removeTrailingNewline
, execIfMissing
, writeFileIfMissing , writeFileIfMissing
, renameFileIfMissing , renameFileIfMissing
, commandError , commandError
, appendAfter , appendAfter
, exec , exec
, execute , execute
, execRemote
, Address (..)
, liftedAsync
, restartService , restartService
, getPassword
, executeRoot) where , executeRoot) where
import System.IO import System.IO
@ -20,30 +34,56 @@ module System.Serverman.Utils ( keyvalue
import Data.List import Data.List
import Control.Exception import Control.Exception
import System.Exit 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 :: [(String, String)] -> String -> String
keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit
keyvalue [] _ = "" 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 :: String -> String
semicolon text = unlines $ map (++ ";") (lines text) semicolon text = unlines $ map (++ ";") (lines text)
block :: String -> String -> String block :: String -> String -> String
block blockName content = blockName ++ " {\n" ++ indent content ++ "}" block blockName content = blockName ++ " {\n" ++ indent content ++ "}"
writeFileIfMissing :: FilePath -> String -> IO () execIfMissing :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
writeFileIfMissing path content = do execIfMissing path action = do
exists <- doesFileExist path exists <- liftIO $ doesFileExist path
when (not exists) $ do when (not exists) action
writeFile path content
writeFileIfMissing :: FilePath -> String -> IO ()
writeFileIfMissing path content = execIfMissing path (writeFile path content)
renameFileIfMissing :: FilePath -> String -> IO () renameFileIfMissing :: FilePath -> String -> IO ()
renameFileIfMissing path content = do renameFileIfMissing path content = execIfMissing path (renameFile path content)
exists <- doesFileExist path
when (not exists) $ do
renameFile path content
appendAfter :: String -> String -> String -> String appendAfter :: String -> String -> String -> String
appendAfter content after line = appendAfter content after line =
@ -55,16 +95,31 @@ module System.Serverman.Utils ( keyvalue
indent :: String -> String indent :: String -> String
indent s = unlines $ map ("\t" ++) (lines s) 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 :: String -> String
commandError command = "[Error] an error occured while running: " ++ command ++ "\nplease try running the command manually." 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 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 exec cmd args stdin cwd logErrors = do
let command = cmd ++ " " ++ intercalate " " args (AppState { remoteMode }) <- get
cp = (proc cmd args) { cwd = cwd }
if isJust remoteMode then do
let (addr, key) = fromJust remoteMode
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 }
process <- async $ do process <- async $ do
result <- tryIOError $ readCreateProcessWithExitCode cp stdin result <- tryIOError $ readCreateProcessWithExitCode cp stdin
@ -87,8 +142,97 @@ module System.Serverman.Utils ( keyvalue
wait process wait process
restartService :: String -> IO (Either String String) 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 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 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.Monoid
import Data.Maybe import Data.Maybe
import Control.Monad import Control.Monad
import Control.Monad.State
initialize = do initialize = do
args <- getArgs args <- getArgs
@ -58,6 +59,7 @@ module System.Term ( initialize ) where
, wService :: String , wService :: String
, ssl :: Bool , ssl :: Bool
, email :: String , email :: String
, wRemote :: String
} }
| DatabaseParams { databaseName :: String | DatabaseParams { databaseName :: String
, dService :: String , dService :: String
@ -65,6 +67,7 @@ module System.Term ( initialize ) where
, dUser :: String , dUser :: String
, dPass :: String , dPass :: String
, dHost :: String , dHost :: String
, dRemote :: String
} }
| FileSharingParams { fDirectory :: String | FileSharingParams { fDirectory :: String
@ -76,9 +79,10 @@ module System.Term ( initialize ) where
, fAnonymousWrite :: Bool , fAnonymousWrite :: Bool
, fRecreateUser :: Bool , fRecreateUser :: Bool
, fService :: String , fService :: String
, fRemote :: String
} }
| InstallParams { iService :: String } | InstallParams { iService :: String, remote :: String }
deriving (Show, Data, Typeable) 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" , ssl = False &= help "create a letsencrypt certificate for this domain, defaults to false"
, email = def &= help "email required for registering your certificate" , email = def &= help "email required for registering your certificate"
, wService = "nginx" &= help "service to build config for: nginx, defaults to nginx" &= explicit &= name "service" , 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" } &= explicit &= name "webserver"
database = DatabaseParams { databaseName = "test" &= help "database name, defaults to test" &= explicit &= name "name" 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" , dUser = "root" &= help "database's username, defaults to root" &= explicit &= name "user"
, dPass = "" &= help "database's password, defaults to blank string" &= explicit &= name "password" , 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" , 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" } &= explicit &= name "database"
filesharing = FileSharingParams { fDirectory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory" filesharing = FileSharingParams { fDirectory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory"
@ -108,13 +114,16 @@ module System.Term ( initialize ) where
, fPort = "21" &= help "service port, defaults to 21" &= explicit &= name "port" , 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" , 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" , 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" } &= explicit &= name "filesharing"
install = InstallParams { iService = def &= argPos 0 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" } &= explicit &= name "install"
webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email }) = do 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" when (ssl && null email) $ die "Email is required for generating a certificate"
let serverType let serverType
@ -139,18 +148,20 @@ module System.Term ( initialize ) where
, S.serverService = serviceName , S.serverService = serviceName
, S.email = email , S.email = email
} }
S.run $ S.detectOS >>= (S.install serviceName) return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName) >> S.detectOS >>= (S.start serviceName)
>> S.newServer params >> S.newServer params
manualInstall (InstallParams { iService }) = do manualInstall (InstallParams { iService, remote }) =
remoteSetup remote $ do
let serviceName = read iService :: Service let serviceName = read iService :: Service
S.run $ S.detectOS >>= (S.install serviceName) return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName) >> S.detectOS >>= (S.start serviceName)
databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost }) = do databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do
remoteSetup dRemote $ do
let serviceName = read dService let serviceName = read dService
let params = S.DatabaseParams { S.database = databaseName let params = S.DatabaseParams { S.database = databaseName
@ -161,11 +172,12 @@ module System.Term ( initialize ) where
, S.databaseHost = dHost , S.databaseHost = dHost
} }
S.run $ S.detectOS >>= (S.install serviceName) return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName) >> S.detectOS >>= (S.start serviceName)
>> S.newDatabase params >> S.newDatabase params
fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) = do fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser, fRemote }) = do
remoteSetup fRemote $ do
let serviceName = read fService let serviceName = read fService
let params = S.FileSharingParams { S.fDirectory = fDirectory let params = S.FileSharingParams { S.fDirectory = fDirectory
@ -179,7 +191,22 @@ module System.Term ( initialize ) where
, S.fRecreateUser = fRecreateUser , S.fRecreateUser = fRecreateUser
} }
S.run $ S.detectOS >>= (S.install serviceName) return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName) >> S.detectOS >>= (S.start serviceName)
>> S.newFileSharing params >> 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 ()