feat: remote action

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