From 3a2e331d1aab1cdc2e8ad5be4cf017d3fc51e0f8 Mon Sep 17 00:00:00 2001 From: Mahdi Dibaiee Date: Sun, 5 Mar 2017 15:49:09 +0330 Subject: [PATCH] feat: remote action --- serverman.cabal | 1 + src/System/Serverman.hs | 2 + src/System/Serverman/Action.hs | 7 +++ src/System/Serverman/Actions/Install.hs | 2 + src/System/Serverman/Actions/Remote.hs | 38 ++++++++++++++++ src/System/Serverman/Services.hs | 2 + src/System/Serverman/Utils.hs | 9 +++- src/System/Term/Database.hs | 45 +++++++++++++++++++ src/System/Term/FileSharing.hs | 53 ++++++++++++++++++++++ src/System/Term/Install.hs | 27 +++++++++++ src/System/Term/Remote.hs | 10 +++++ src/System/Term/WebServer.hs | 60 +++++++++++++++++++++++++ 12 files changed, 254 insertions(+), 2 deletions(-) create mode 100644 src/System/Serverman/Actions/Remote.hs create mode 100644 src/System/Term/Database.hs create mode 100644 src/System/Term/FileSharing.hs create mode 100644 src/System/Term/Install.hs create mode 100644 src/System/Term/Remote.hs create mode 100644 src/System/Term/WebServer.hs diff --git a/serverman.cabal b/serverman.cabal index 0a64c88..55ec6bd 100644 --- a/serverman.cabal +++ b/serverman.cabal @@ -33,6 +33,7 @@ library , System.Serverman.Actions.Install , System.Serverman.Actions.Env , System.Serverman.Actions.Start + , System.Serverman.Actions.Remote , System.Serverman.Services build-depends: base >= 4.7 && < 5 , free >= 4.12.4 && < 5 diff --git a/src/System/Serverman.hs b/src/System/Serverman.hs index feb4199..1cb672e 100644 --- a/src/System/Serverman.hs +++ b/src/System/Serverman.hs @@ -15,6 +15,7 @@ module System.Serverman ( run import System.Serverman.Actions.Env import System.Serverman.Actions.Install import System.Serverman.Actions.Start + import System.Serverman.Actions.Remote import System.Serverman.Actions.WebServer import System.Serverman.Actions.Nginx @@ -47,4 +48,5 @@ module System.Serverman ( run | fService params == VsFTPd = vsftpd params >> run next | otherwise = 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 a5f16a3..aa6f08d 100644 --- a/src/System/Serverman/Action.hs +++ b/src/System/Serverman/Action.hs @@ -7,12 +7,14 @@ module System.Serverman.Action ( ActionF(..) , newFileSharing , start , install + , remote , detectOS) where import System.Serverman.Actions.WebServer import System.Serverman.Actions.FileSharing import System.Serverman.Actions.Database import System.Serverman.Actions.Env + import System.Serverman.Actions.Remote import System.Serverman.Utils import System.Serverman.Services @@ -31,6 +33,7 @@ module System.Serverman.Action ( ActionF(..) | NewFileSharing FileSharingParams x | DetectOS (OS -> x) | Install Service OS x + | Remote [Address] (Action ()) x | Start Service OS x instance Functor ActionF where @@ -40,6 +43,7 @@ module System.Serverman.Action ( ActionF(..) fmap f (Install service os x) = Install service os (f x) fmap f (Start service os x) = Start service os (f x) fmap f (DetectOS x) = DetectOS (f . x) + fmap f (Remote addr action x) = Remote addr action (f x) type Action = Free ActionF @@ -60,3 +64,6 @@ module System.Serverman.Action ( ActionF(..) detectOS :: Action OS detectOS = liftF $ DetectOS id + + remote :: [Address] -> Action () -> Action () + remote addrs action = liftF $ Remote addrs action () diff --git a/src/System/Serverman/Actions/Install.hs b/src/System/Serverman/Actions/Install.hs index 71a3691..9a975c2 100644 --- a/src/System/Serverman/Actions/Install.hs +++ b/src/System/Serverman/Actions/Install.hs @@ -30,6 +30,8 @@ module System.Serverman.Actions.Install (installService, package, dependencies) package VsFTPd _ = "vsftpd" + package SSHFs _ = "sshfs" + installService :: Service -> OS -> IO () installService service os = do forM_ (dependencies service) (`installService` os) diff --git a/src/System/Serverman/Actions/Remote.hs b/src/System/Serverman/Actions/Remote.hs new file mode 100644 index 0000000..6e87ade --- /dev/null +++ b/src/System/Serverman/Actions/Remote.hs @@ -0,0 +1,38 @@ +module System.Serverman.Actions.Remote ( runRemotely + , Address) where + import System.Serverman.Utils + import Data.List + import System.Directory + import System.IO + import System.FilePath + + type Host = String + type Port = String + type User = String + data Address = Address Host Port User + + runRemotely :: Address -> IO r -> IO () + runRemotely addr@(Address host port user) action = do + let path = "/tmp/serverman/" show addr + + createDirectoryIfMissing True path + + execute "sshfs" [show addr, path] "" True + + 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 + readHostPort str = span (== ':') str + + instance Show Address where + show (Address host port user) = user ++ "@" ++ host ++ ":" ++ port diff --git a/src/System/Serverman/Services.hs b/src/System/Serverman/Services.hs index c054828..f6d30ae 100644 --- a/src/System/Serverman/Services.hs +++ b/src/System/Serverman/Services.hs @@ -6,6 +6,7 @@ module System.Serverman.Services ( Service(..) | MongoDB | VsFTPd | LetsEncrypt + | SSHFs deriving (Eq, Show) class Configurable a where @@ -24,3 +25,4 @@ module System.Serverman.Services ( Service(..) | service == "mongodb" = [(MongoDB, [])] | service == "vsftpd" = [(VsFTPd, [])] | service == "letsencrypt" = [(LetsEncrypt, [])] + | service == "sshfs" = [(SSHFs, [])] diff --git a/src/System/Serverman/Utils.hs b/src/System/Serverman/Utils.hs index 07336ae..30c1e02 100644 --- a/src/System/Serverman/Utils.hs +++ b/src/System/Serverman/Utils.hs @@ -6,6 +6,7 @@ module System.Serverman.Utils ( keyvalue , renameFileIfMissing , commandError , appendAfter + , exec , execute , restartService , executeRoot) where @@ -58,11 +59,15 @@ module System.Serverman.Utils ( keyvalue 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 cmd args stdin logErrors = do + execute cmd args stdin logErrors = exec cmd args stdin Nothing logErrors + + exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> IO (Either String String) + exec cmd args stdin cwd logErrors = do let command = cmd ++ " " ++ intercalate " " args + cp = (proc cmd args) { cwd = cwd } process <- async $ do - result <- tryIOError $ readProcessWithExitCode cmd args stdin + result <- tryIOError $ readCreateProcessWithExitCode cp stdin case result of Right (ExitSuccess, stdout, _) -> return $ Right stdout diff --git a/src/System/Term/Database.hs b/src/System/Term/Database.hs new file mode 100644 index 0000000..810c366 --- /dev/null +++ b/src/System/Term/Database.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} + +module System.Term.Database (mode, handle, Params(..)) where + import System.Console.CmdArgs hiding (name) + import qualified System.Console.CmdArgs as C (name) + import qualified System.Serverman as S + import qualified System.Term.Remote as R + import Control.Monad + import System.Exit + import System.Directory + + data Params = Params { name :: String + , service :: String + , dummyData :: Bool + , user :: String + , pass :: String + , host :: String + , remote :: FilePath + } deriving (Show, Data, Typeable) + + mode = Params { name = "test" &= help "database name, defaults to test" + , service = "mysql" &= help "service to setup: mysql, defaults to mysql" + , dummyData = False &= help "generate dummy data in the database" &= explicit &= C.name "dummy-data" + , user = "root" &= help "database's username, defaults to root" + , pass = "" &= help "database's password, defaults to blank string" + , host = "127.0.0.1" &= help "database's host, defaults to localhost" + , remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir + } &= explicit &= C.name "database" + + handle (Params { name, service, dummyData, user, pass, host, remote }) = + R.handle remote $ do + let serviceName = read service + + let params = S.DatabaseParams { S.database = name + , S.databaseService = serviceName + , S.dummyData = dummyData + , S.databaseUser = user + , S.databasePass = pass + , S.databaseHost = host + } + + return $ S.detectOS >>= (S.install serviceName) + >> S.detectOS >>= (S.start serviceName) + >> S.newDatabase params diff --git a/src/System/Term/FileSharing.hs b/src/System/Term/FileSharing.hs new file mode 100644 index 0000000..7a1f0d3 --- /dev/null +++ b/src/System/Term/FileSharing.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} + +module System.Term.FileSharing (mode, handle, Params(..)) where + import System.Console.CmdArgs + import qualified System.Serverman as S + import qualified System.Term.Remote as R + import Control.Monad + import System.Exit + import System.Directory hiding (writable) + + data Params = Params { directory :: String + , user :: String + , pass :: String + , port :: String + , writable :: Bool + , anonymous :: Bool + , anonymousWrite :: Bool + , recreateUser :: Bool + , service :: String + , remote :: FilePath + } deriving (Show, Data, Typeable) + + mode = Params { directory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory" + , user = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user" + , pass = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password" + , anonymous = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous" + , anonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write" + , writable = True &= help "allow write operations, defaults to True" &= explicit &= name "writable" + , port = "21" &= help "service port, defaults to 21" &= explicit &= name "port" + , service = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service" + , recreateUser = False &= help "recreate the user" &= explicit &= name "recreate-user" + , remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote" + } &= explicit &= name "filesharing" + + handle (Params { directory, user, pass, port, anonymous, anonymousWrite, writable, service, recreateUser, remote }) = + R.handle remote $ do + let serviceName = read service + + let params = S.FileSharingParams { S.fDirectory = directory + , S.fUser = user + , S.fPass = pass + , S.fPort = port + , S.fAnonymous = anonymous + , S.fAnonymousWrite = anonymousWrite + , S.fWritable = writable + , S.fService = serviceName + , S.fRecreateUser = recreateUser + } + + return $ S.detectOS >>= (S.install serviceName) + >> S.detectOS >>= (S.start serviceName) + >> S.newFileSharing params diff --git a/src/System/Term/Install.hs b/src/System/Term/Install.hs new file mode 100644 index 0000000..8c325f3 --- /dev/null +++ b/src/System/Term/Install.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} + +module System.Term.Install (mode, handle, Params(..)) where + import System.Console.CmdArgs + import qualified System.Serverman as S + import qualified System.Term.Remote as R + import Control.Monad + import System.Exit + import System.Directory + + data Params = Params { service :: String + , remote :: FilePath + } deriving (Show, Data, Typeable) + + mode = Params { service = def &= argPos 0 + , remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote" + } + + handle (Params { service, remote }) = + R.handle remote $ do + let serviceName = read service + + return $ S.detectOS >>= (S.install serviceName) + >> S.detectOS >>= (S.start serviceName) + + diff --git a/src/System/Term/Remote.hs b/src/System/Term/Remote.hs new file mode 100644 index 0000000..7fcccef --- /dev/null +++ b/src/System/Term/Remote.hs @@ -0,0 +1,10 @@ +module System.Term.Remote (handle) where + import qualified System.Serverman as S + + handle file generateAction + | null file = S.run =<< generateAction + | otherwise = do + list <- map read . lines <$> readFile file + action <- generateAction + + S.run $ S.remote list action diff --git a/src/System/Term/WebServer.hs b/src/System/Term/WebServer.hs new file mode 100644 index 0000000..06ac75c --- /dev/null +++ b/src/System/Term/WebServer.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} + +module System.Term.WebServer (mode, handle, Params(..)) where + import System.Console.CmdArgs + import qualified System.Serverman as S + import qualified System.Term.Remote as R + import Control.Monad + import System.Exit + import System.Directory + + data Params = Params { directory :: String + , domain :: String + , port :: String + , forward :: String + , service :: String + , ssl :: Bool + , email :: String + , remote :: FilePath + } deriving (Show, Data, Typeable) + + mode = Params { 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" + , service = "nginx" &= help "service to build config for: nginx, defaults to nginx" + , remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote" + } &= explicit &= name "webserver" + + handle (Params { directory, domain, port, ssl, forward, service, email, remote }) = + R.handle remote $ 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 service :: S.Service + + 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