From d8aa65ea4d92043b8e517b90025998ac3b852f06 Mon Sep 17 00:00:00 2001 From: Mahdi Dibaiee Date: Tue, 21 Mar 2017 13:35:17 +0330 Subject: [PATCH] fix: liftIO to act on server's files --- serverman | 1 + serverman.cabal | 1 + src/System/Serverman.hs | 2 +- src/System/Serverman/Action.hs | 8 +- src/System/Serverman/Actions/Call.hs | 35 +++- src/System/Serverman/Actions/Env.hs | 17 +- src/System/Serverman/Actions/Install.hs | 3 +- src/System/Serverman/Actions/Manage.hs | 8 +- src/System/Serverman/Actions/Remote.hs | 41 +++-- src/System/Serverman/Actions/Repository.hs | 2 +- src/System/Serverman/Types.hs | 4 +- src/System/Serverman/Utils.hs | 38 +++- src/System/Term.hs | 191 ++------------------- stack.yaml | 1 + 14 files changed, 127 insertions(+), 225 deletions(-) create mode 160000 serverman diff --git a/serverman b/serverman new file mode 160000 index 0000000..57d23fe --- /dev/null +++ b/serverman @@ -0,0 +1 @@ +Subproject commit 57d23feac5fd5b60cd383cda2e491918d56a5638 diff --git a/serverman.cabal b/serverman.cabal index c1b8a1c..7c38cd5 100644 --- a/serverman.cabal +++ b/serverman.cabal @@ -48,6 +48,7 @@ library , containers , hint , stack + , exceptions default-language: Haskell2010 executable serverman diff --git a/src/System/Serverman.hs b/src/System/Serverman.hs index 36a052d..601c04c 100644 --- a/src/System/Serverman.hs +++ b/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 diff --git a/src/System/Serverman/Action.hs b/src/System/Serverman/Action.hs index 8f0ab68..14fec1e 100644 --- a/src/System/Serverman/Action.hs +++ b/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 = liftF $ Call service () + call :: Service -> Maybe FilePath -> Action () + call service remote = liftF $ Call service remote () install :: Service -> Action () install service = liftF $ Install service () diff --git a/src/System/Serverman/Actions/Call.hs b/src/System/Serverman/Actions/Call.hs index f7311c0..bc3b20f 100644 --- a/src/System/Serverman/Actions/Call.hs +++ b/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 Control.Monad.State + import Language.Haskell.Interpreter hiding (get, name, liftIO) + import Control.Monad.State hiding (liftIO) import System.Posix.Env import Data.List import Stack.Package - callService :: Service -> App () - callService s@(Service { name, version }) = do + callService :: Service -> Maybe FilePath -> App () + 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 - (Right stackEnv) <- exec "stack" ["exec", "env"] "" (Just path) True + exec "stack" ["setup", "--allow-different-user"] "" (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] diff --git a/src/System/Serverman/Actions/Env.hs b/src/System/Serverman/Actions/Env.hs index 83e0d8e..8d4771b 100644 --- a/src/System/Serverman/Actions/Env.hs +++ b/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] - distro - | or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian - | "arch" `isInfixOf` release = Arch - | "Mac" `isInfixOf` release = Mac - | otherwise = Unknown + let release = map toLower . head . rights $ [arch_release, deb_release] + distro = releaseToOS release 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 diff --git a/src/System/Serverman/Actions/Install.hs b/src/System/Serverman/Actions/Install.hs index be993b6..f69ac65 100644 --- a/src/System/Serverman/Actions/Install.hs +++ b/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 diff --git a/src/System/Serverman/Actions/Manage.hs b/src/System/Serverman/Actions/Manage.hs index 2b4a171..d6089dd 100644 --- a/src/System/Serverman/Actions/Manage.hs +++ b/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 () diff --git a/src/System/Serverman/Actions/Remote.hs b/src/System/Serverman/Actions/Remote.hs index 9b432b9..eda9f85 100644 --- a/src/System/Serverman/Actions/Remote.hs +++ b/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"] - - result <- execute "sshfs" (p ++ noPassword ++ sftpOptions ++ ["-o", "nonempty", "-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" True + liftIO $ threadDelay 500 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"] - runServerman "touch" ["/home/serverman/.ssh/authorized_keys"] - runServerman "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"] + runCommand "mkdir" ["/home/serverman/.ssh", "-p"] + runCommand "touch" ["/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] diff --git a/src/System/Serverman/Actions/Repository.hs b/src/System/Serverman/Actions/Repository.hs index 3955d7c..9acff30 100644 --- a/src/System/Serverman/Actions/Repository.hs +++ b/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 diff --git a/src/System/Serverman/Types.hs b/src/System/Serverman/Types.hs index 3f84d04..28e24ea 100644 --- a/src/System/Serverman/Types.hs +++ b/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 diff --git a/src/System/Serverman/Utils.hs b/src/System/Serverman/Utils.hs index a1ec79f..33a0443 100644 --- a/src/System/Serverman/Utils.hs +++ b/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"] diff --git a/src/System/Term.hs b/src/System/Term.hs index 2277b9c..2375f05 100644 --- a/src/System/Term.hs +++ b/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) @@ -72,13 +79,13 @@ module System.Term ( initialize ) where instance Default Params where def = Params { listServices = False - , install = Nothing - , manage = Nothing - , remote = Nothing - , update = False - , help = False - , rest = [] - } + , install = Nothing + , manage = Nothing + , remote = Nothing + , update = False + , help = False + , rest = [] + } parseParams :: [String] -> Params parseParams ("repository":"list":xs) = (parseParams xs) { listServices = True } @@ -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 ()-} - diff --git a/stack.yaml b/stack.yaml index 06dca8c..19bbc88 100644 --- a/stack.yaml +++ b/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