thereadme/serverman
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fix: liftIO to act on server's files

Browse Source
This commit is contained in:
Mahdi Dibaiee 2017-03-21 13:35:17 +03:30
parent 7c80963642
commit d8aa65ea4d
14 changed files with 127 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
serverman Submodule

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

1
serverman.cabal
View File

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

2
src/System/Serverman.hs
View File

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

8
src/System/Serverman/Action.hs
View File

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

35
src/System/Serverman/Actions/Call.hs
View File

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

17
src/System/Serverman/Actions/Env.hs
View File

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

3
src/System/Serverman/Actions/Install.hs
View File

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

8
src/System/Serverman/Actions/Manage.hs
View File

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

41
src/System/Serverman/Actions/Remote.hs
View File

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

2
src/System/Serverman/Actions/Repository.hs
View File

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

4
src/System/Serverman/Types.hs
View File

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

38
src/System/Serverman/Utils.hs
View File

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

191
src/System/Term.hs
View File

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

1
stack.yaml
View File

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