feat(progress-text): progressText

fix(progress): improve progress
fix: add more logging to different parts

src/System/Serverman/Actions/Call.hs

@@ -3,7 +3,7 @@
 
 module System.Serverman.Actions.Call (callService) where
   import System.Serverman.Types
-  import System.Serverman.Utils
+  import System.Serverman.Utils hiding (liftIO)
   import System.Serverman.Log
   import qualified System.Serverman.Actions.Repository
   import System.Serverman.Actions.Remote
@@ -11,7 +11,7 @@ module System.Serverman.Actions.Call (callService) where
   import System.Directory
   import System.FilePath
   import Language.Haskell.Interpreter hiding (get, name, liftIO)
-  import Control.Monad.State hiding (liftIO)
+  import Control.Monad.State
   import System.Posix.Env
   import Data.List
   import Stack.Package
@@ -19,7 +19,7 @@ module System.Serverman.Actions.Call (callService) where
 
   callService :: Service -> Maybe FilePath -> App ()
   callService s@(Service { name, version }) remote = do
-    done <- progress
+    done <- progressText $ "running service " ++ show s
 
     state@(AppState { repositoryURL, helpArg }) <- get
     put $ state { remoteMode = Nothing }

src/System/Serverman/Actions/Install.hs

@@ -21,7 +21,7 @@ module System.Serverman.Actions.Install (installService) where
 
   installService :: Service -> App ()
   installService s@(Service { dependencies, packages }) = do
-    done <- progress
+    done <- progressText $ "installing " ++ show s
     (AppState { os }) <- get
 
     deps <- catMaybes <$> mapM findService dependencies
@@ -33,13 +33,11 @@ module System.Serverman.Actions.Install (installService) where
           _ -> ("echo", ["Unknown operating system"])
         pkg = packageByOS s os
 
-    process <- liftedAsync $ do
-      result <- executeRoot (fst base) (snd base ++ pkg) "" True
-      done
+    result <- executeRoot (fst base) (snd base ++ pkg) "" True
+    done
 
-      case result of
-        Left err -> return ()
-        Right _ -> info $ "installed " ++ show s
+    case result of
+      Left err -> return ()
+      Right _ -> info $ "installed " ++ show s
 
-    liftIO $ wait process
     return ()

src/System/Serverman/Actions/Remote.hs

@@ -1,7 +1,10 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 module System.Serverman.Actions.Remote ( runRemotely
                                        , Address) where
-  import System.Serverman.Utils
+  import System.Serverman.Utils hiding (liftIO)
   import System.Serverman.Actions.Env
+  import System.Serverman.Log
 
   import Data.List
   import System.Directory
@@ -9,9 +12,10 @@ module System.Serverman.Actions.Remote ( runRemotely
   import System.FilePath
   import System.Posix.Env
   import System.Posix.Files
+  import System.Posix.Types
   import Control.Monad
   import Data.Maybe
-  import Control.Monad.State hiding (liftIO)
+  import Control.Monad.State
   import Control.Concurrent
   import Data.IORef
   import Data.Either
@@ -20,6 +24,8 @@ module System.Serverman.Actions.Remote ( runRemotely
 
   runRemotely :: Address -> App r -> App ()
   runRemotely addr@(Address host port user) action = do
+    done <- progressText $ "connecting to server " ++ show addr
+
     tmp <- liftIO getTemporaryDirectory
     (Right userID) <- execute "id" ["-u"] "" True
 
@@ -28,7 +34,7 @@ module System.Serverman.Actions.Remote ( runRemotely
         connection = takeWhile (/= ':') (show addr)
         smConnection = "serverman@" ++ host
         path = tmp </> smConnection
-        uid = ["-o", "uid=" ++ userID, "-o", "gid=" ++ userID]
+        uid = ["-o", "uid=" ++ removeTrailingNewline userID, "-o", "gid=" ++ removeTrailingNewline userID]
 
         serverPaths = ["/usr/lib/openssh/sftp-server", "/usr/lib/ssh/sftp-server"]
 
@@ -40,35 +46,54 @@ module System.Serverman.Actions.Remote ( runRemotely
     let keyPath = home </> ".ssh/serverman"
         pubPath = keyPath <.> "pub"
 
-    liftIO $ createDirectoryIfMissing True path
-
     -- check if a connection to SSH server using public key is possible
-    execute "fusermount" ["-u", path] "" False
-    result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" False
+    result <- do
+      exists <- liftIO $ doesPathExist path
+      content <- if exists then liftIO $ listDirectory path else return []
+
+      if not exists || null content then do
+        liftIO $ createDirectoryIfMissing True path
+
+        verbose $ "mounting SSHFs: " ++ path
+
+        result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" False
+
+        state@(AppState { temps }) <- get
+        put $ state { temps = path:temps }
+
+        return result
+      else do
+        verbose $ "SSHFs already mounted on " ++ path ++ ", continuing"
+        return $ Right "already mounted"
+
+    done
 
     case result of
       Right _ -> do
         state <- get
-        liftIO $ threadDelay actionDelay
+        liftIO $ do
+          threadDelay actionDelay
+
         put $ state { remoteMode = Just (servermanAddr, keyPath) }
         getOS
         action
 
         return ()
 
-      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"
-          putStrLn $ "and that will be used for connecting to the server from now on."
-          putStrLn $ "you might be prompted for password if you are not using SSH key authentication."
+      Left e -> do
+        info $ "it seems to be the first time you are using serverman for configuring " ++ show addr
+        write $ "remotely. serverman will create a user, and add it to sudoers file. an ssh key will be created"
+        write $ "and that will be used for connecting to the server from now on"
+        write $ "you will not be prompted for a password to connect to server with"
+        write $ "please enable password authentication temporarily on your server for this step"
 
-          putStrLn $ "Enter password for " ++ connection
+        write $ "Enter password for " ++ connection
 
         home <- liftIO getHomeDirectory
         password <- liftIO getPassword
 
+        done <- progressText $ "setting up serverman user in server " ++ show addr
+
         execIfMissing keyPath $ execute "ssh-keygen" ["-N", "", "-f", keyPath] "" True >> return ()
 
         publicKey <- liftIO $ readFile pubPath
@@ -85,6 +110,8 @@ module System.Serverman.Actions.Remote ( runRemotely
         runCommand "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"]
         runCommand "chown" ["-R", "serverman", "/home/serverman"]
 
+        done
+
         runRemotely addr action
 
         return ()

src/System/Serverman/Actions/Repository.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 
 module System.Serverman.Actions.Repository (fetchRepo, findService) where
-  import System.Serverman.Utils
+  import System.Serverman.Utils hiding (liftIO)
   import System.Directory
   import System.Serverman.Services hiding (info)
   import System.Serverman.Actions.Env
@@ -17,7 +17,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 hiding (liftIO)
+  import Control.Monad.State
   import qualified Data.ByteString.Lazy.Char8 as BS
   import qualified Data.Text as T
   import Data.List
@@ -41,22 +41,38 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where
 
     execIfMissing path $ do
       verbose "repository missing... cloning repository"
+
+      done <- progressText "downloading repository"
+
       info $ "cloning " ++ repositoryURL ++ " in " ++ path
       execute "git" ["clone", repositoryURL, path] "" True
+
+      done
+      info $ "downloaded repository"
       return ()
 
     execIfMissing source $ do
       verbose "serverman source missing... cloning repository"
 
+      done <- progressText "downloading serverman source"
+
       info $ "cloning " ++ sourceURL ++ " in " ++ source
       execute "git" ["clone", sourceURL, source] "" True
+
+      done
+      info $ "downloaded serverman source"
       return ()
 
     when update $ do
       verbose "updating repository"
 
+      done <- progressText "updating repository"
+
       exec "git" ["pull", "origin", "master"] "" (Just path) True
       exec "git" ["pull", "origin", "master"] "" (Just source) True
+
+      done
+      info $ "updated repository"
       return ()
 
     content <- liftIO $ readFile (path </> "repository.json")

src/System/Serverman/Log.hs

@@ -5,10 +5,10 @@ module System.Serverman.Log ( verbose
                             , info
                             , write
                             , progress
+                            , progressText
                             , warning
                             , err
-                            , die
-                            , progressListener) where
+                            , die) where
 
   import System.Serverman.Types
 
@@ -46,33 +46,46 @@ module System.Serverman.Log ( verbose
   die str = liftIO . E.die . format . bold . F.red $ read ("[fatal error] " ++ str)
 
   progress :: App (App ())
-  progress = do
+  progress = progressText "working"
+
+  clearLine :: IO ()
+  clearLine = do
+    putStr $ "\ESC[2K\ESC[0;"
+    hFlush stdout
+  
+  backward :: Int -> IO ()
+  backward n = do
+    putStr $ "\ESC[" ++ (show n) ++ "D\ESC[0;"
+
+  progressText :: String -> App (App ())
+  progressText str = do
     state <- get
-    p <- progressListener
+    p <- progressListener str
 
     return p
 
-
-  progressPrefix = "working "
   progressCharacters = [".  ", ".. ", "...", " ..", "  .", "   "]
   progressDelay = 200000
-  progressListener :: App (App ())
-  progressListener = do
+  progressListener :: String -> App (App ())
+  progressListener text = do
+    liftIO $ putStr $ replicate strLength '.'
+
     p <- liftedAsync $
       mapM start (cycle [0..length progressCharacters])
 
     return $ stop p
 
     where
+        strLength = 2 + length text + length (head progressCharacters)
         start n = do
           liftIO . threadDelay $ progressDelay
 
           liftedAsync $ do
-            let str = progressPrefix ++ (progressCharacters !! n)
+            let str = text ++ " " ++ (progressCharacters !! n)
 
             liftIO $ do
+              backward strLength
               putStr . format . (light . F.blue) $ read str
-              putStr $ "\ESC[" ++ (show $ length str) ++ "D\ESC[0;"
               hFlush stdout
 
             return ()
@@ -80,4 +93,5 @@ module System.Serverman.Log ( verbose
         stop process = do
           liftIO $ do
             cancel process
-            putStr "\ESC[0;"
+            backward strLength
+            clearLine

src/System/Serverman/Types.hs

@@ -87,10 +87,11 @@ module System.Serverman.Types ( Service (..)
                            , verboseMode   :: Bool
                            , ports         :: [(SourcePort, DestinationPort)]
                            , processes     :: [ProcessHandle]
+                           , temps         :: [FilePath]
                            }
 
   instance Show AppState where
-    show (AppState { remoteMode, repository, repositoryURL, os, arguments, ports, processes }) = 
+    show (AppState { remoteMode, repository, repositoryURL, os, arguments, ports, processes, temps, verboseMode }) = 
       "remote: " ++ show remoteMode ++ "\n" ++
       "repository:\n" ++
       "  - url: " ++ show repositoryURL ++ "\n" ++
@@ -98,7 +99,9 @@ module System.Serverman.Types ( Service (..)
       "operating system: " ++ show os ++ "\n" ++
       "arguments: " ++ show arguments ++ "\n" ++
       "port forwarding: " ++ show ports ++ "\n" ++
-      "processes: " ++ show (length processes)
+      "verbose: " ++ show verboseMode ++ "\n" ++
+      "processes: " ++ show (length processes) ++
+      "temps: " ++ show (length temps)
 
   instance Default AppState where
     def = AppState { remoteMode    = Nothing
@@ -110,6 +113,7 @@ module System.Serverman.Types ( Service (..)
                    , verboseMode   = False
                    , ports         = []
                    , processes     = []
+                   , temps         = []
                    }
   type App = StateT AppState IO
 

src/System/Serverman/Utils.hs

@@ -18,7 +18,6 @@ module System.Serverman.Utils ( App (..)
                               , execIfExists
                               , writeFileIfMissing
                               , renameFileIfMissing
-                              , commandError
                               , appendAfter
                               , exec
                               , execute
@@ -40,7 +39,7 @@ module System.Serverman.Utils ( App (..)
   import Control.Concurrent.Async
   import Data.List
   import Control.Exception
-  import System.Exit
+  import System.Exit hiding (die)
   import Data.Maybe
   import System.Posix.Terminal
   import System.Posix.IO (stdInput)
@@ -50,6 +49,7 @@ module System.Serverman.Utils ( App (..)
   import qualified Control.Monad.State as ST
   import Control.Monad.State hiding (liftIO)
   import Data.Default.Class
+  import Control.Monad.Catch (catchIOError)
   import System.Unix.Chroot
   import Control.Concurrent
   import Control.Monad.Loops
@@ -78,7 +78,9 @@ module System.Serverman.Utils ( App (..)
 
         verbose $ "chroot directory " ++ path
 
-        fchroot path $ ST.liftIO action
+        catchIOError 
+          (fchroot path $ ST.liftIO action)
+          (\e -> err (show e) >> (ST.liftIO $ threadDelay 1000000) >> liftIO action)
     where
       portForward (Address host port user, key) (source, destination) = do
         let forward = source ++ ":" ++ host ++ ":" ++ destination
@@ -101,6 +103,9 @@ module System.Serverman.Utils ( App (..)
       Nothing -> return port
       Just _ -> do
         available <- head <$> dropWhileM checkPort range
+
+        verbose $ "using port " ++ available ++ " in place of " ++ port
+
         put $ state { ports = (available, port):ports }
         return available
     where
@@ -109,6 +114,7 @@ module System.Serverman.Utils ( App (..)
   -- clear a port
   clearPort :: String -> App ()
   clearPort port = do
+    verbose $ "freed port " ++ port
     state@(AppState { ports, remoteMode }) <- get
     let newPorts = filter ((/= port) . fst) ports
     put $ state { ports = newPorts }
@@ -207,9 +213,6 @@ module System.Serverman.Utils ( App (..)
     | (reverse . take 1 . reverse) input == "\n" = take (length input - 1) input
     | otherwise = input
 
-  commandError :: String -> String
-  commandError command = "[Error] an error occured while running: " ++ command ++ "\nplease try running the command manually."
-
   execute :: String -> [String] -> String -> Bool -> App (Either String String)
   execute cmd args stdin logErrors = exec cmd args stdin Nothing logErrors
 
@@ -223,39 +226,35 @@ module System.Serverman.Utils ( App (..)
     if isJust remoteMode then do
       let (addr, key) = fromJust remoteMode
 
-      execRemote addr (Just key) (Just "serverman") "" cmd args stdin cwd logErrors
+      execRemote addr (Just key) Nothing "" cmd args stdin cwd logErrors
     else do
       let command = escape $ cmd ++ " " ++ intercalate " " args
           cp = (proc (escape cmd) (map escape args)) { cwd = cwd }
 
-      verbose $ "executing command " ++ command
+      verbose $ "executing command |" ++ command ++ "|"
 
-      process <- liftedAsync $ do
-        result <- liftIO . tryIOError $ readCreateProcessWithExitCode cp stdin
-        verbose "command executed"
+      result <- ST.liftIO . tryIOError $ readCreateProcessWithExitCode cp stdin
+      verbose "command executed"
 
-        case result of
-          Right (ExitSuccess, stdout, _) -> do
-            verbose $ "command successful: " ++ stdout
-            return $ Right stdout
+      case result of
+        Right (ExitSuccess, stdout, _) -> do
+          verbose $ "command successful: " ++ stdout
+          return $ Right stdout
 
-          Right (ExitFailure code, stdout, stderr) -> do
-            when (not logErrors) $ verbose $ "command failed: " ++ show code ++ ", stderr: " ++ stderr
-            when logErrors $ do
-              err command
-              err $ "exit code: " ++ show code
-              err stdout
-              err stderr
-            return $ Left stdout
-          Left e -> do
-            when (not logErrors) $ verbose $ "couldn't execute command: " ++ show e
-            when logErrors $ do
-              err command
-              err $ show e
-            return $ Left (show e)
-
-      (result, _) <- liftIO $ wait process
-      return result
+        Right (ExitFailure code, stdout, stderr) -> do
+          when (not logErrors) $ verbose $ "command failed: " ++ show code ++ ", stderr: " ++ stderr
+          when logErrors $ do
+            err command
+            err $ "exit code: " ++ show code
+            err stdout
+            err stderr
+          return $ Left stdout
+        Left e -> do
+          when (not logErrors) $ verbose $ "couldn't execute command: " ++ show e
+          when logErrors $ do
+            err command
+            err $ show e
+          return $ Left (show e)
 
     where
       escape :: String -> String
@@ -271,9 +270,9 @@ module System.Serverman.Utils ( App (..)
 
     let userArgument = case maybeUser of
                          Just user -> if (not . null) password then
-                                        ["echo", password, "|", "sudo -S", "-u", user]
+                                        ["echo", password, "|", "sudo", "-S", "-u", user]
                                       else
-                                        ["sudo -u", user]
+                                        ["sudo", "-u", user]
                          Nothing -> []
         keyArgument = case maybeKey of
                         Just key -> 
@@ -285,13 +284,13 @@ module System.Serverman.Utils ( App (..)
 
         cumulated = p ++ keyArgument ++ options
         command = userArgument ++ ["sh -c \"", cmd] ++ args ++ ["\""]
-        complete = "ssh" : (cumulated ++ [connection] ++ command)
+        complete = "-w" : "ssh" : (cumulated ++ [connection] ++ (intersperse " " command))
 
     verbose $ "backing up environment variables"
     backupEnv <- ST.liftIO getEnvironment
 
-    verbose $ "writing passwordFile for SSH " ++ passwordFile
-    when (not . null $ password) $ 
+    when (not . null $ password) $ do
+      verbose $ "writing passwordFile for SSH " ++ passwordFile ++ " and setting SSH_ASKPASS"
       ST.liftIO $ do
         writeFile passwordFile $ "echo " ++ password
         setFileMode passwordFile accessModes
@@ -301,10 +300,7 @@ module System.Serverman.Utils ( App (..)
     let (AppState { remoteMode = backup }) = state
     put $ state { remoteMode = Nothing }
 
-    verbose $ "executing command in remote " ++ show complete
-
-    newEnv <- liftIO getEnvironment
-    verbose $ "env " ++ keyvalue newEnv "="
+    verbose $ "executing command |setsid " ++ show complete ++ "|"
 
     result <- exec "setsid" complete stdin cwd logErrors
     put $ state { remoteMode = backup }

src/System/Term.hs

@@ -16,6 +16,7 @@ module System.Term ( initialize ) where
   import System.FilePath
   import Data.List
   import System.Process
+  import Control.Concurrent
 
   import System.Serverman.Utils hiding (liftIO)
   import System.Serverman.Actions.Repository
@@ -99,12 +100,19 @@ module System.Term ( initialize ) where
         _ -> servermanHelp
 
       -- after the program is done, terminate remaining processes
-      (S.AppState { S.processes }) <- get
+      -- and unmount/remove leftover temporary directories
+      state@(S.AppState { S.processes, S.temps }) <- get
+      put $ state { remoteMode = Nothing }
+
       mapM_ (liftIO . terminateProcess) processes
+      mapM_ clearTemp temps
 
     return ()
 
     where
+      clearTemp path = execIfExists path $ do
+        execute "fusermount" ["-u", path] "" False
+        liftIO $ removeDirectoryRecursive path
       -- if remote mode is set, read the file and run the action
       -- on servers, otherwise run action locally
       handleRemote (Params { remote = Just file }) action = do