feat(remote): run commands on remote machines

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

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

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

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

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

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)

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

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

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

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

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)

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