feat: remote action

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

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
 

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

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) 

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

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, [])]

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

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

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

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

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

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