fix: liftIO to act on server's files

serverman

@@ -0,0 +1 @@
+Subproject commit 57d23feac5fd5b60cd383cda2e491918d56a5638

serverman.cabal

@@ -48,6 +48,7 @@ library
                      , containers
                      , hint
                      , stack
+                     , exceptions
   default-language:    Haskell2010
 
 executable serverman

src/System/Serverman.hs

@@ -26,7 +26,7 @@ module System.Serverman ( run
   run (Free (Stop service next)) = stopService service >> run next
   run (Free (Install service next)) = installService service >> run next
 
-  run (Free (Call service next)) = callService service >> run next
+  run (Free (Call service remote next)) = callService service remote >> run next
 
   run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next
 

src/System/Serverman/Action.hs

@@ -28,7 +28,7 @@ module System.Serverman.Action ( ActionF(..)
   import System.IO.Error
   import Data.Char
 
-  data ActionF x = Call Service x
+  data ActionF x = Call Service (Maybe FilePath) x
                  | DetectOS x
                  | Install Service x
                  | Remote [Address] (Action ()) x
@@ -37,7 +37,7 @@ module System.Serverman.Action ( ActionF(..)
                  | Stop Service x
 
   instance Functor ActionF where
-    fmap f (Call service x) = Call service (f x)
+    fmap f (Call service remote x) = Call service remote (f x)
     fmap f (Install service x) = Install service (f x)
     fmap f (Start service x) = Start service (f x)
     fmap f (Stop service x) = Stop service (f x)
@@ -47,8 +47,8 @@ module System.Serverman.Action ( ActionF(..)
 
   type Action = Free ActionF
 
-  call :: Service -> Action ()
+  call :: Service -> Maybe FilePath -> Action ()
-  call service = liftF $ Call service ()
+  call service remote = liftF $ Call service remote ()
 
   install :: Service -> Action ()
   install service = liftF $ Install service ()

src/System/Serverman/Actions/Call.hs

@@ -5,18 +5,20 @@ module System.Serverman.Actions.Call (callService) where
   import System.Serverman.Types
   import System.Serverman.Utils
   import qualified System.Serverman.Actions.Repository
+  import System.Serverman.Actions.Remote
 
   import System.Directory
   import System.FilePath
-  import Language.Haskell.Interpreter hiding (get, name)
+  import Language.Haskell.Interpreter hiding (get, name, liftIO)
-  import Control.Monad.State
+  import Control.Monad.State hiding (liftIO)
   import System.Posix.Env
   import Data.List
   import Stack.Package
 
-  callService :: Service -> App ()
+  callService :: Service -> Maybe FilePath -> App ()
-  callService s@(Service { name, version }) = do
+  callService s@(Service { name, version }) remote = do
     state@(AppState { repositoryURL }) <- get
+    put $ state { remoteMode = Nothing }
 
     dir <- liftIO $ getAppUserDataDirectory "serverman"
     let path = dir </> "repository" </> "services" </> name
@@ -27,16 +29,21 @@ module System.Serverman.Actions.Call (callService) where
     let include = [source, src]
         includeArgs = map ("-i"++) include
 
-    (Right stackEnv) <- exec "stack" ["install", "--dependencies-only"] "" (Just path) True
+    exec "stack" ["setup", "--allow-different-user"] "" (Just path) True
-    (Right stackEnv) <- exec "stack" ["exec", "env"] "" (Just path) True
+    exec "stack" ["install", "--dependencies-only", "--allow-different-user"] "" (Just path) True
+    exec "stack" ["install", "--dependencies-only", "--allow-different-user"] "" (Just source) True
+
+    (Right stackEnv) <- exec "stack" ["exec", "env", "--allow-different-user"] "" (Just path) True
+    (Right stackSourceEnv) <- exec "stack" ["exec", "env", "--allow-different-user"] "" (Just source) True
+    let finalEnv = map (mergeEnv $ parseKeyValue stackSourceEnv '=') (parseKeyValue stackEnv '=')
 
     backupEnv <- liftIO $ getEnvironment
-    liftIO $ setEnvironment $ parseKeyValue stackEnv '='
+    liftIO $ setEnvironment finalEnv
 
     func <- liftIO $ runInterpreter (interpreter include entry)
 
     case func of
-      Right fn -> fn s
+      Right fn -> handleRemote remote $ fn s
       Left err -> liftIO $ do
         putStrLn $ "error reading `call` from module " ++ entry
         case err of
@@ -48,6 +55,18 @@ module System.Serverman.Actions.Call (callService) where
 
     return ()
 
+    where
+      handleRemote (Just file) action = do
+        list <- liftIO $ map read . lines <$> readFile file
+        mapM_ (`runRemotely` action) list
+      handleRemote _ action = action
+
+      mergeEnv other (key, value)
+        | key `elem` ["GHC_PACKAGE_PATH", "HASKELL_PACKAGE_SANDBOXES"] = 
+          let (Just alt) = lookup key other
+          in (key, value ++ ":" ++ alt)
+        | otherwise = (key, value)
+
   interpreter :: [FilePath] -> FilePath -> Interpreter (Service -> App ())
   interpreter path entry = do
     set [searchPath := path]

src/System/Serverman/Actions/Env.hs

@@ -1,4 +1,4 @@
-module System.Serverman.Actions.Env (OS(..), getOS) where
+module System.Serverman.Actions.Env (OS(..), getOS, releaseToOS) where
   import System.Serverman.Utils
   import System.Serverman.Types
 
@@ -12,16 +12,17 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
   getOS = do
     arch_release <- execute "cat" ["/etc/os-release"] "" False
     deb_release <- execute "cat" ["/etc/lsb-release"] "" False
-    mac_release <- execute "sw_vers" ["-productName"] "" False
 
-    let release = map toLower . head . rights $ [arch_release, deb_release, mac_release] 
+    let release = map toLower . head . rights $ [arch_release, deb_release] 
-        distro
+        distro = releaseToOS release
-            | or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian
-            | "arch" `isInfixOf` release = Arch
-            | "Mac" `isInfixOf` release = Mac
-            | otherwise = Unknown
 
     state <- get
     put $ state { os = distro }
 
     return ()
+
+  releaseToOS :: String -> OS
+  releaseToOS release
+    | or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian
+    | "arch" `isInfixOf` release = Arch
+    | otherwise = Unknown

src/System/Serverman/Actions/Install.hs

@@ -13,7 +13,7 @@ module System.Serverman.Actions.Install (installService) where
   import System.Process
   import Control.Concurrent.Async
   import Control.Monad
-  import Control.Monad.State
+  import Control.Monad.State hiding (liftIO)
   import Control.Monad.Trans.Control
   import Data.List
   import Data.Maybe
@@ -28,7 +28,6 @@ module System.Serverman.Actions.Install (installService) where
     let base = case os of
           Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"])
           Debian -> ("apt-get", ["install", "-y"])
-          Mac -> ("brew", ["install", "-y"])
           _ -> ("echo", ["Unknown operating system"])
         pkg = packageByOS s os
 

src/System/Serverman/Actions/Manage.hs

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

src/System/Serverman/Actions/Remote.hs

@@ -1,8 +1,8 @@
 module System.Serverman.Actions.Remote ( runRemotely
                                        , Address) where
   import System.Serverman.Utils
+  import System.Serverman.Actions.Env
 
-  import System.Unix.Chroot
   import Data.List
   import System.Directory
   import System.IO
@@ -11,16 +11,27 @@ module System.Serverman.Actions.Remote ( runRemotely
   import System.Posix.Files
   import Control.Monad
   import Data.Maybe
+  import Control.Monad.State hiding (liftIO)
   import Data.IORef
-  import Control.Monad.State
+  import Data.Either
+  import Control.Concurrent
 
   runRemotely :: Address -> App r -> App ()
   runRemotely addr@(Address host port user) action = do
+    tmp <- liftIO getTemporaryDirectory
+    (Right userID) <- execute "id" ["-u"] "" True
+
     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
+        path = tmp </> smConnection
+        uid = ["-o", "uid=" ++ userID, "-o", "gid=" ++ userID]
+
+        serverPaths = ["/usr/lib/openssh/sftp-server", "/usr/lib/ssh/sftp-server"]
+
+        options = ["-o", "nonempty",
+                   "-o", "sftp_server=sudo " ++ head serverPaths]
 
     home <- liftIO getHomeDirectory
 
@@ -29,21 +40,24 @@ module System.Serverman.Actions.Remote ( runRemotely
 
     liftIO $ createDirectoryIfMissing True path
 
+    -- check if a connection to SSH server using public key is possible
+    -- result <- execRemote servermanAddr (Just keyPath) Nothing "" "echo" [] "" Nothing False
     execute "fusermount" ["-u", path] "" False
+    result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" True
 
-    let sftpOptions = ["-o", "sftp_server=sudo -u serverman /usr/lib/openssh/sftp-server"]
+    liftIO $ threadDelay 500
-
-    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) }
+        getOS
         action
 
         return ()
 
-      Left _ -> do
+      Left err -> do
+        liftIO $ print err
         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"
@@ -66,9 +80,12 @@ module System.Serverman.Actions.Remote ( runRemotely
         runCommand "useradd" ["-m", "-p", (quote . removeTrailingNewline) encryptedPassword, "serverman"]
         runCommand "echo" ["'serverman ALL=(ALL) NOPASSWD: ALL'", ">>", "/etc/sudoers"]
 
-        runServerman "mkdir" ["/home/serverman/.ssh", "-p"]
+        runCommand "mkdir" ["/home/serverman/.ssh", "-p"]
-        runServerman "touch" ["/home/serverman/.ssh/authorized_keys"]
+        runCommand "touch" ["/home/serverman/.ssh/authorized_keys"]
-        runServerman "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"]
+        runCommand "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"]
+        runCommand "chown" ["-R", "serverman", "/home/serverman"]
+
+        runRemotely addr action
 
         return ()
 
@@ -77,10 +94,6 @@ module System.Serverman.Actions.Remote ( runRemotely
     where
       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]

src/System/Serverman/Actions/Repository.hs

@@ -16,7 +16,7 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where
   import Data.Aeson.Types
   import GHC.Generics
   import qualified Data.Map as M
-  import Control.Monad.State
+  import Control.Monad.State hiding (liftIO)
   import qualified Data.ByteString.Lazy.Char8 as BS
   import qualified Data.Text as T
   import Data.List

src/System/Serverman/Types.hs

@@ -40,20 +40,18 @@ module System.Serverman.Types ( Service (..)
       | otherwise = host
 
 
-  data OS = Debian | Arch | Mac | Unknown deriving (Eq)
+  data OS = Debian | Arch | Unknown deriving (Eq)
 
   instance Read OS where
     readsPrec _ os
       | os == "debian" = [(Debian, [])]
       | os == "arch" = [(Arch, [])]
-      | os == "mac" = [(Mac, [])]
       | os == "_" = [(Unknown, [])]
 
   instance Show OS where
     show os
       | os == Debian = "debian"
       | os == Arch = "arch"
-      | os == Mac = "mac"
       | os == Unknown = "_"
 
   data Service = Service { name         :: String

src/System/Serverman/Utils.hs

@@ -14,6 +14,7 @@ module System.Serverman.Utils ( App (..)
                               , quote
                               , removeTrailingNewline
                               , execIfMissing
+                              , execIfExists
                               , writeFileIfMissing
                               , renameFileIfMissing
                               , commandError
@@ -23,6 +24,7 @@ module System.Serverman.Utils ( App (..)
                               , execRemote
                               , Address (..)
                               , liftedAsync
+                              , liftIO
                               , restartService
                               , getPassword
                               , executeRoot) where
@@ -30,6 +32,7 @@ module System.Serverman.Utils ( App (..)
   import System.IO
   import Control.Monad
   import System.Directory
+  import System.FilePath
   import System.Process
   import System.IO.Error
   import Control.Concurrent.Async
@@ -42,12 +45,29 @@ module System.Serverman.Utils ( App (..)
   import Data.Maybe
   import System.Posix.Files
   import System.Posix.Env
-  import Control.Monad.State
+  import qualified Control.Monad.State as ST
+  import Control.Monad.State hiding (liftIO)
   import Control.Monad.Trans.Control
   import Data.Default.Class
+  import System.Unix.Chroot
+  import Control.Monad.Catch
 
   import System.Serverman.Types
 
+  liftIO :: (MonadIO m, MonadState AppState m, MonadMask m) => IO a -> m a
+  {-liftIO :: IO a -> App a-}
+  liftIO action = do
+    state@(AppState { remoteMode }) <- get
+
+    case remoteMode of
+      Nothing -> ST.liftIO action
+
+      Just (Address host port user, _) -> do
+        tmp <- ST.liftIO getTemporaryDirectory
+        let path = tmp </> (user ++ "@" ++ host)
+        
+        fchroot path $ ST.liftIO action
+
   keyvalue :: [(String, String)] -> String -> String
   keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit
   keyvalue [] _ = ""
@@ -82,15 +102,21 @@ module System.Serverman.Utils ( App (..)
 
   execIfMissing :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
   execIfMissing path action = do
-    exists <- liftIO $ doesPathExist path
+    exists <- ST.liftIO $ doesPathExist path
     
     when (not exists) action
 
+  execIfExists :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
+  execIfExists path action = do
+    exists <- ST.liftIO $ doesPathExist path
+    
+    when exists action
+
   writeFileIfMissing :: FilePath -> String -> IO ()
   writeFileIfMissing path content = execIfMissing path (writeFile path content)
 
   renameFileIfMissing :: FilePath -> String -> IO ()
-  renameFileIfMissing path content = execIfMissing path (renameFile path content)
+  renameFileIfMissing path content = execIfMissing content (renameFile path content)
 
   appendAfter :: String -> String -> String -> String
   appendAfter content after line =
@@ -157,6 +183,9 @@ module System.Serverman.Utils ( App (..)
 
   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
+    tmp <- liftIO getTemporaryDirectory
+    let passwordFile = tmp </> "pw"
+
     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]
@@ -169,7 +198,7 @@ module System.Serverman.Utils ( App (..)
       backupEnv <- getEnvironment 
 
       writeFile passwordFile $ "echo " ++ password
-      setFileMode passwordFile ownerExecuteMode
+      setFileMode passwordFile accessModes
       setEnv "SSH_ASKPASS" passwordFile True
 
       return (backupEnv, passwordFile)
@@ -186,7 +215,6 @@ module System.Serverman.Utils ( App (..)
 
     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"]

src/System/Term.hs

@@ -16,7 +16,7 @@ module System.Term ( initialize ) where
   import System.FilePath
   import Data.List
 
-  import System.Serverman.Utils
+  import System.Serverman.Utils hiding (liftIO)
   import System.Serverman.Actions.Repository
 
   initialize = do
@@ -39,17 +39,20 @@ module System.Term ( initialize ) where
       case params of
         (Params { listServices = True }) -> liftIO $ do
           mapM_ print repository
-        (Params { install = Just service }) -> do
+        p@(Params { install = Just service }) -> do
           ms <- findService service
           case ms of
-            Just s -> S.run (S.install s)
+            Just s -> handleRemote p $ S.install s
             Nothing -> liftIO $ putStrLn $ "service not found: " ++ service
-        (Params { rest = (x:xs) }) -> do
+        p@(Params { rest = (x:xs), remote }) -> do
           case x of
             (service, Nothing) -> do
               ms <- findService service
               case ms of
-                Just s -> S.run (S.call s)
+                Just s -> do
+                  handleRemote p $ S.install s
+                  S.run $ S.call s remote
+
                 Nothing -> liftIO $ putStrLn $ "could not find any service matching " ++ service
             _ -> liftIO $ putStrLn $ "could not understand your input"
 
@@ -58,6 +61,10 @@ module System.Term ( initialize ) where
     return ()
 
     where
+      handleRemote (Params { remote = Just file }) action = do
+        list <- liftIO $ map read . lines <$> readFile file
+        S.run (S.remote list action)
+      handleRemote (Params { remote = Nothing }) action = S.run action
 
 
   data Manage = Start | Stop deriving (Eq, Show)
@@ -103,163 +110,3 @@ module System.Term ( initialize ) where
       flagName = isPrefixOf "-"
       value = not . flagName
       getWord = dropWhile (== '-')
-
-   {-WEB SERVER -}
-  {-data Params = WebServerParams { directory :: String-}
-                                {-, domain    :: String-}
-                                {-, port      :: String-}
-                                {-, forward   :: String-}
-                                {-, wService  :: String-}
-                                {-, ssl       :: Bool-}
-                                {-, email     :: String-}
-                                {-, wRemote   :: String-}
-                                {-}-}
-              {-| DatabaseParams { databaseName :: String-}
-                               {-, dService     :: String-}
-                               {-, dummyData    :: Bool-}
-                               {-, dUser        :: String-}
-                               {-, dPass        :: String-}
-                               {-, dHost        :: String-}
-                               {-, dRemote      :: String-}
-                               {-}-}
-
-              {-| FileSharingParams { fDirectory      :: String-}
-                                  {-, fUser           :: String-}
-                                  {-, fPass           :: String-}
-                                  {-, fPort           :: String-}
-                                  {-, fWritable       :: Bool-}
-                                  {-, fAnonymous      :: Bool-}
-                                  {-, fAnonymousWrite :: Bool-}
-                                  {-, fRecreateUser   :: Bool-}
-                                  {-, fService        :: String-}
-                                  {-, fRemote         :: String-}
-                                  {-}-}
-
-              {-| InstallParams { iService :: String, remote :: String }-}
-
-              {-deriving (Show, Data, Typeable)-}
-
-  {-webserver = WebServerParams { directory = "/var/www/html/" &= typDir &= help "directory to serve static files from, defaults to /var/www/html/" -}
-                              {-, domain    = "test.dev" &= typ "DOMAIN" &= help "domain/server name, defaults to test.dev"-}
-                              {-, port      = def &= typ "PORT" &= help "port number to listen to, defaults to 80 for http and 443 for https"-}
-                              {-, forward   = def &= typ "PORT" &= help "the port to forward to (in case of a port-forwarding server)"-}
-                              {-, ssl       = False &= help "create a letsencrypt certificate for this domain, defaults to false"-}
-                              {-, email     = def &= help "email required for registering your certificate"-}
-                              {-, 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"-}
-                            {-, dService     = "mysql" &= help "service to setup: mysql, defaults to mysql" &= explicit &= name "service"-}
-                            {-, dummyData    = False &= help "generate dummy data in the database" &= explicit &= name "dummy-data"-}
-                            {-, 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"-}
-                                  {-, fUser           = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user"-}
-                                  {-, fPass           = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password"-}
-                                  {-, fAnonymous      = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous"-}
-                                  {-, fAnonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write"-}
-                                  {-, fWritable       = True &= help "allow write operations, defaults to True" &= explicit &= name "writable"-}
-                                  {-, 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, 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 serviceName = read wService-}
-
-      {-let portNumber-}
-            {-| (not . null) port = port-}
-            {-| ssl = "443"-}
-            {-| otherwise = "80"-}
-
-      {-absoluteDirectory <- makeAbsolute directory-}
-
-      {-let params = S.ServerParams { S.wDirectory    = absoluteDirectory-}
-                                  {-, S.domain        = domain-}
-                                  {-, S.port          = portNumber-}
-                                  {-, S.ssl           = ssl-}
-                                  {-, S.forward       = forward-}
-                                  {-, S.serverType    = serverType-}
-                                  {-, S.serverService = serviceName-}
-                                  {-, S.email         = email-}
-                                  {-}-}
-      {-return $ S.detectOS >>= (S.install serviceName)-}
-            {->> S.detectOS >>= (S.start serviceName)-}
-            {->> S.newServer params-}
-
-  {-manualInstall (InstallParams { iService, remote }) =-}
-    {-remoteSetup remote $ do-}
-      {-let serviceName = read iService-}
-
-      {-return $ S.detectOS >>= (S.install serviceName)-}
-             {->> S.detectOS >>= (S.start serviceName)-}
-    
-
-  {-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-}
-                                    {-}-}
-
-      {-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, 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-}
-                                      {-}-}
-
-      {-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 ()-}
- 

stack.yaml

@@ -3,6 +3,7 @@ extra-package-dbs: []
 packages:
 - '.'
 extra-deps:
+- concurrent-extra-0.7.0.10
 - stack-1.3.2
 - store-0.3.1
 - store-core-0.3