feat(log): colored logging using termcolor

serverman.cabal

@@ -19,6 +19,7 @@ library
                      , System.Serverman
                      , System.Serverman.Utils
                      , System.Serverman.Action
+                     , System.Serverman.Log
                      
                      , System.Serverman.Actions.Install
                      , System.Serverman.Actions.Env
@@ -49,6 +50,8 @@ library
                      , hint
                      , stack
                      , exceptions
+                     , monad-loops
+                     , termcolor
   default-language:    Haskell2010
 
 executable serverman
@@ -66,6 +69,7 @@ test-suite serverman-test
   main-is:             Spec.hs
   build-depends:       base
                      , serverman
+                     , quickcheck
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
 

src/System/Serverman.hs

@@ -30,5 +30,6 @@ module System.Serverman ( run
 
   run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next
 
-  run (Free (FetchRepository next)) = fetchRepo >> run next
+  run (Free (FetchRepository next)) = fetchRepo False >> run next
+  run (Free (UpdateRepository next)) = fetchRepo True >> run next
 

src/System/Serverman/Action.hs

@@ -4,6 +4,7 @@ module System.Serverman.Action ( ActionF(..)
                                , Action
                                , call
                                , fetchRepository
+                               , updateRepository
                                , start
                                , stop
                                , install
@@ -33,6 +34,7 @@ module System.Serverman.Action ( ActionF(..)
                  | Install Service x
                  | Remote [Address] (Action ()) x
                  | FetchRepository x
+                 | UpdateRepository x
                  | Start Service x
                  | Stop Service x
 
@@ -44,6 +46,7 @@ module System.Serverman.Action ( ActionF(..)
     fmap f (DetectOS x) = DetectOS (f x)
     fmap f (Remote addr action x) = Remote addr action (f x)
     fmap f (FetchRepository x) = FetchRepository (f x)
+    fmap f (UpdateRepository x) = UpdateRepository (f x)
 
   type Action = Free ActionF
 
@@ -67,3 +70,6 @@ module System.Serverman.Action ( ActionF(..)
 
   fetchRepository :: Action ()
   fetchRepository = liftF $ FetchRepository ()
+
+  updateRepository :: Action ()
+  updateRepository = liftF $ UpdateRepository ()

src/System/Serverman/Actions/Call.hs

@@ -4,6 +4,7 @@
 module System.Serverman.Actions.Call (callService) where
   import System.Serverman.Types
   import System.Serverman.Utils
+  import System.Serverman.Log
   import qualified System.Serverman.Actions.Repository
   import System.Serverman.Actions.Remote
 
@@ -14,10 +15,13 @@ module System.Serverman.Actions.Call (callService) where
   import System.Posix.Env
   import Data.List
   import Stack.Package
+  import Data.Maybe
 
   callService :: Service -> Maybe FilePath -> App ()
   callService s@(Service { name, version }) remote = do
-    state@(AppState { repositoryURL }) <- get
+    done <- progress
+
+    state@(AppState { repositoryURL, helpArg }) <- get
     put $ state { remoteMode = Nothing }
 
     dir <- liftIO $ getAppUserDataDirectory "serverman"
@@ -35,21 +39,39 @@ module System.Serverman.Actions.Call (callService) where
 
     (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 finalEnv
 
-    func <- liftIO $ runInterpreter (interpreter include entry)
+    func <- liftIO $ runInterpreter (getCall include entry)
+    helpOutput <- liftIO $ runInterpreter (getHelp include entry)
 
-    case func of
+    done
-      Right fn -> handleRemote remote $ fn s
-      Left err -> liftIO $ do
-        putStrLn $ "error reading `call` from module " ++ entry
-        case err of
-          WontCompile errs -> mapM_ (putStrLn . errMsg) errs
 
-          x -> print x
+    if helpArg then
+      case helpOutput of
+        Right fn -> write =<< fn
+        Left e -> do
+          write $ "could not find a help entry for " ++ name
+          case e of
+            WontCompile errs -> mapM_ (write . errMsg) errs
+
+            GhcException ie -> err ie
+            UnknownError ie -> err ie
+            NotAllowed ie -> err ie
+    else
+      case func of
+        Right fn -> handleRemote remote $ fn s
+        Left e -> do
+          err $ "couldn't read `call` from module " ++ entry
+          case e of
+            WontCompile errs -> mapM_ (write . errMsg) errs
+
+            GhcException ie -> err ie
+            UnknownError ie -> err ie
+            NotAllowed ie -> err ie
 
     liftIO $ setEnvironment backupEnv
 
@@ -62,15 +84,22 @@ module System.Serverman.Actions.Call (callService) where
       handleRemote _ action = action
 
       mergeEnv other (key, value)
-        | key `elem` ["GHC_PACKAGE_PATH", "HASKELL_PACKAGE_SANDBOXES"] = 
+        | key `elem` ["GHC_PACKAGE_PATH", "HASKELL_PACKAGE_SANDBOXES", "PATH"] = 
           let (Just alt) = lookup key other
           in (key, value ++ ":" ++ alt)
+        | key == "LD_PRELOAD" = (key, "")
         | otherwise = (key, value)
 
-  interpreter :: [FilePath] -> FilePath -> Interpreter (Service -> App ())
+  getCall :: [FilePath] -> FilePath -> Interpreter (Service -> App ())
-  interpreter path entry = do
+  getCall path entry = do
     set [searchPath := path]
     loadModules [entry]
     setTopLevelModules ["Main"]
     interpret "call" (as :: Service -> App ())
 
+  getHelp :: [FilePath] -> FilePath -> Interpreter (App String)
+  getHelp path entry = do
+    set [searchPath := path]
+    loadModules [entry]
+    setTopLevelModules ["Main"]
+    interpret "help" (as :: App String)

src/System/Serverman/Actions/Env.hs

@@ -1,6 +1,7 @@
 module System.Serverman.Actions.Env (OS(..), getOS, releaseToOS) where
   import System.Serverman.Utils
   import System.Serverman.Types
+  import System.Serverman.Log
 
   import System.Process
   import Data.List
@@ -10,6 +11,8 @@ module System.Serverman.Actions.Env (OS(..), getOS, releaseToOS) where
   import Control.Monad.State
   
   getOS = do
+    verbose "detecting os"
+
     arch_release <- execute "cat" ["/etc/os-release"] "" False
     deb_release <- execute "cat" ["/etc/lsb-release"] "" False
 

src/System/Serverman/Actions/Install.hs

@@ -4,10 +4,11 @@
 module System.Serverman.Actions.Install (installService) where
   import System.Serverman.Action
   import System.Serverman.Utils
-  import System.Serverman.Services
+  import System.Serverman.Services hiding (info)
   import System.Serverman.Actions.Env
   import System.Serverman.Actions.Repository
   import System.Serverman.Types
+  import System.Serverman.Log
 
   import System.IO.Error
   import System.Process
@@ -20,6 +21,7 @@ module System.Serverman.Actions.Install (installService) where
 
   installService :: Service -> App ()
   installService s@(Service { dependencies, packages }) = do
+    done <- progress
     (AppState { os }) <- get
 
     deps <- catMaybes <$> mapM findService dependencies
@@ -33,11 +35,11 @@ module System.Serverman.Actions.Install (installService) where
 
     process <- liftedAsync $ do
       result <- executeRoot (fst base) (snd base ++ pkg) "" True
+      done
 
       case result of
         Left err -> return ()
-        Right _ -> do
+        Right _ -> info $ "installed " ++ show s
-          liftIO $ putStrLn $ "installed " ++ show s ++ "."
       
     liftIO $ wait process
     return ()

src/System/Serverman/Actions/Manage.hs

@@ -6,11 +6,14 @@ module System.Serverman.Actions.Manage (startService, stopService) where
   import System.Serverman.Actions.Env
   import System.Serverman.Actions.Install
   import System.Serverman.Services
+  import System.Serverman.Log
 
   import Control.Monad.State hiding (liftIO)
 
   startService :: Service -> App ()
   startService (Service { service }) = do
+    verbose $ "starting service " ++ service
+
     (AppState { os }) <- get
     case os of 
       _   -> do
@@ -20,6 +23,8 @@ module System.Serverman.Actions.Manage (startService, stopService) where
 
   stopService :: Service -> App ()
   stopService (Service { service }) = do
+    verbose $ "stopping service " ++ service
+
     (AppState { os }) <- get
     case os of 
       _   -> do

src/System/Serverman/Actions/Remote.hs

@@ -12,9 +12,11 @@ module System.Serverman.Actions.Remote ( runRemotely
   import Control.Monad
   import Data.Maybe
   import Control.Monad.State hiding (liftIO)
+  import Control.Concurrent
   import Data.IORef
   import Data.Either
-  import Control.Concurrent
+
+  actionDelay = 1000000
 
   runRemotely :: Address -> App r -> App ()
   runRemotely addr@(Address host port user) action = do
@@ -41,15 +43,13 @@ 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
+    result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" False
-
-    liftIO $ threadDelay 500
 
     case result of
       Right _ -> do
         state <- get
+        liftIO $ threadDelay actionDelay
         put $ state { remoteMode = Just (servermanAddr, keyPath) }
         getOS
         action

src/System/Serverman/Actions/Repository.hs

@@ -5,8 +5,9 @@
 module System.Serverman.Actions.Repository (fetchRepo, findService) where
   import System.Serverman.Utils
   import System.Directory
-  import System.Serverman.Services
+  import System.Serverman.Services hiding (info)
   import System.Serverman.Actions.Env
+  import System.Serverman.Log
   import System.Serverman.Types
 
   import System.FilePath
@@ -26,27 +27,37 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where
   findService :: String -> App (Maybe Service)
   findService n = do
     (AppState { repository }) <- get
+    verbose $ "searching for service " ++ n
     return $ find (\a -> name a == n) repository
 
-  fetchRepo :: App Repository
+  fetchRepo :: Bool -> App Repository
-  fetchRepo = do
+  fetchRepo update = do
+    verbose "fetching repository"
+
     state@(AppState { repositoryURL }) <- get
     dir <- liftIO $ getAppUserDataDirectory "serverman"
     let path = dir </> "repository"
     let source = dir </> "source"
 
     execIfMissing path $ do
-      liftIO $ putStrLn $ "cloning " ++ repositoryURL ++ " in " ++ path
+      verbose "repository missing... cloning repository"
+      info $ "cloning " ++ repositoryURL ++ " in " ++ path
       execute "git" ["clone", repositoryURL, path] "" True
       return ()
 
     execIfMissing source $ do
-      liftIO $ putStrLn $ "cloning " ++ sourceURL ++ " in " ++ source
+      verbose "serverman source missing... cloning repository"
+
+      info $ "cloning " ++ sourceURL ++ " in " ++ source
       execute "git" ["clone", sourceURL, source] "" True
       return ()
 
-    {-exec "git" ["pull", "origin", "master"] "" (Just path) True-}
+    when update $ do
-    {-exec "git" ["pull", "origin", "master"] "" (Just source) True-}
+      verbose "updating repository"
+
+      exec "git" ["pull", "origin", "master"] "" (Just path) True
+      exec "git" ["pull", "origin", "master"] "" (Just source) True
+      return ()
 
     content <- liftIO $ readFile (path </> "repository.json")
 
@@ -65,10 +76,10 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where
             return $ rights list
 
           Nothing -> do
-            liftIO $ putStrLn $ "error parsing repository data, please try re-fetching the repository."
+            err $ "parsing repository data failed, please try re-fetching the repository."
             return []
       Nothing -> do
-        liftIO $ putStrLn $ "error parsing repository data, please try re-fetching the repository."
+        err $ "parsing repository data failed, please try re-fetching the repository."
         return []
 
     where

src/System/Serverman/Log.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module System.Serverman.Log ( verbose
+                            , info
+                            , write
+                            , progress
+                            , warning
+                            , err
+                            , die
+                            , progressListener) where
+
+  import System.Serverman.Types
+
+  import Text.Termcolor
+  import Text.Termcolor.Style
+  import qualified Text.Termcolor.Foreground as F
+  import qualified Text.Termcolor.Background as B
+  import qualified System.Exit as E
+  import Control.Concurrent.Async
+  import Control.Monad.State
+  import Control.Concurrent
+  import System.IO
+  import Control.Monad.Trans.Control
+
+  verbose :: String -> App ()
+  verbose str = do
+    (AppState { verboseMode }) <- get
+    liftIO $
+      when verboseMode $ do
+        putStrLn . format . F.gray $ read ("[verbose] " ++ str)
+
+  write :: String -> App ()
+  write str = liftIO . putStrLn . format . reset $ read str
+
+  info :: String -> App ()
+  info str = liftIO . putStrLn . format . reset $ read ("[info] " ++ str)
+
+  warning :: String -> App ()
+  warning str = liftIO . putStrLn . format . F.yellow $ read ("[warning] " ++ str)
+
+  err :: String -> App ()
+  err str = liftIO . putStrLn . format . bold . F.red $ read ("[error] " ++ str)
+
+  die :: String -> App ()
+  die str = liftIO . E.die . format . bold . F.red $ read ("[fatal error] " ++ str)
+
+  progress :: App (App ())
+  progress = do
+    state <- get
+    p <- progressListener
+
+    return p
+
+
+  progressPrefix = "working "
+  progressCharacters = [".  ", ".. ", "...", " ..", "  .", "   "]
+  progressDelay = 200000
+  progressListener :: App (App ())
+  progressListener = do
+    p <- liftedAsync $
+      mapM start (cycle [0..length progressCharacters])
+
+    return $ stop p
+
+    where
+        start n = do
+          liftIO . threadDelay $ progressDelay
+
+          liftedAsync $ do
+            let str = progressPrefix ++ (progressCharacters !! n)
+
+            liftIO $ do
+              putStr . format . (light . F.blue) $ read str
+              putStr $ "\ESC[" ++ (show $ length str) ++ "D\ESC[0;"
+              hFlush stdout
+
+            return ()
+
+        stop process = do
+          liftIO $ do
+            cancel process
+            putStr "\ESC[0;"

src/System/Serverman/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module System.Serverman.Types ( Service (..)
                               , Repository
@@ -8,10 +9,14 @@ module System.Serverman.Types ( Service (..)
                               , App
                               , Address (..)
                               , Params
-                              , runApp) where
+                              , runApp
+                              , liftedAsync) where
   import Data.Default.Class
   import GHC.Generics
   import Control.Monad.State
+  import Control.Concurrent.Async
+  import Control.Monad.Trans.Control
+  import System.Process
 
   type Host = String
   type Port = String
@@ -71,12 +76,29 @@ module System.Serverman.Types ( Service (..)
 
   type Repository = [Service]
 
+  type SourcePort = String
+  type DestinationPort = String
   data AppState = AppState { remoteMode    :: Maybe (Address, String)
                            , repository    :: Repository
                            , repositoryURL :: String
                            , os            :: OS
                            , arguments     :: [(String, Maybe String)]
-                           } deriving (Show)
+                           , helpArg       :: Bool
+                           , verboseMode   :: Bool
+                           , ports         :: [(SourcePort, DestinationPort)]
+                           , processes     :: [ProcessHandle]
+                           }
+
+  instance Show AppState where
+    show (AppState { remoteMode, repository, repositoryURL, os, arguments, ports, processes }) = 
+      "remote: " ++ show remoteMode ++ "\n" ++
+      "repository:\n" ++
+      "  - url: " ++ show repositoryURL ++ "\n" ++
+      "  - packages: " ++ show repository ++ "\n" ++
+      "operating system: " ++ show os ++ "\n" ++
+      "arguments: " ++ show arguments ++ "\n" ++
+      "port forwarding: " ++ show ports ++ "\n" ++
+      "processes: " ++ show (length processes)
 
   instance Default AppState where
     def = AppState { remoteMode    = Nothing
@@ -84,9 +106,16 @@ module System.Serverman.Types ( Service (..)
                    , repositoryURL = "https://github.com/mdibaiee/serverman-repository"
                    , os            = Unknown
                    , arguments     = []
+                   , helpArg       = False
+                   , verboseMode   = False
+                   , ports         = []
+                   , processes     = []
                    }
   type App = StateT AppState IO
 
   runApp :: App a -> IO (a, AppState)
   runApp k = runStateT k def
 
+  liftedAsync :: MonadBaseControl IO m => m a -> m (Async (StM m a))
+  liftedAsync m = liftBaseWith $ \runInIO -> async (runInIO m)
+

src/System/Serverman/Utils.hs

@@ -9,6 +9,7 @@ module System.Serverman.Utils ( App (..)
                               , splitAtElem
                               , semicolon
                               , block
+                              , mkHelp
                               , indent
                               , commas
                               , quote
@@ -23,8 +24,9 @@ module System.Serverman.Utils ( App (..)
                               , execute
                               , execRemote
                               , Address (..)
-                              , liftedAsync
                               , liftIO
+                              , usingPort
+                              , clearPort
                               , restartService
                               , getPassword
                               , executeRoot) where
@@ -34,7 +36,7 @@ module System.Serverman.Utils ( App (..)
   import System.Directory
   import System.FilePath
   import System.Process
-  import System.IO.Error
+  import System.IO.Error (tryIOError)
   import Control.Concurrent.Async
   import Data.List
   import Control.Exception
@@ -47,31 +49,90 @@ module System.Serverman.Utils ( App (..)
   import System.Posix.Env
   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 Control.Concurrent
+  import Control.Monad.Loops
 
   import System.Serverman.Types
+  import System.Serverman.Log
+  import Debug.Trace
 
-  liftIO :: (MonadIO m, MonadState AppState m, MonadMask m) => IO a -> m a
+  -- lift IO to App, also applying remote mode and port forwarding:
-  {-liftIO :: IO a -> App a-}
+  --   if in remote mode, chroot actions to the SSHFS directory
+  --   forward ports declared by `usingPort`
+  liftIO :: IO a -> App a
   liftIO action = do
-    state@(AppState { remoteMode }) <- get
+    state@(AppState { remoteMode, ports }) <- get
+    verbose $ "liftIO " ++ show remoteMode ++ ", " ++ show ports
 
     case remoteMode of
       Nothing -> ST.liftIO action
 
-      Just (Address host port user, _) -> do
+      Just rm@(Address host port user, key) -> do
         tmp <- ST.liftIO getTemporaryDirectory
         let path = tmp </> (user ++ "@" ++ host)
         
-        fchroot path $ ST.liftIO action
+        verbose $ "forwarding ports"
+        mapM_ (portForward rm) ports
 
+        verbose $ "chroot directory " ++ path
+
+        fchroot path $ ST.liftIO action
+    where
+      portForward (Address host port user, key) (source, destination) = do
+        let forward = source ++ ":" ++ host ++ ":" ++ destination
+            connection = user ++ "@" ++ host ++ (if null port then "" else " -p " ++ port)
+            identity = " -o IdentityFile=" ++ key
+
+        (_, _, _, handle) <- ST.liftIO $ runInteractiveCommand $ "ssh -L " ++ forward ++ " " ++ connection ++ identity
+
+        state@(AppState { processes }) <- get
+        put $ state { processes = handle:processes }
+        return ()
+
+  -- take and return a port from open port pool, forwarding the specified port to that port
+  -- this allows connections to ports on a remote server
+  usingPort :: String -> App String
+  usingPort port = do
+    state@(AppState { ports, remoteMode }) <- get
+
+    case remoteMode of
+      Nothing -> return port
+      Just _ -> do
+        available <- head <$> dropWhileM checkPort range
+        put $ state { ports = (available, port):ports }
+        return available
+    where
+      range = map show [8000..9999]
+
+  -- clear a port
+  clearPort :: String -> App ()
+  clearPort port = do
+    state@(AppState { ports, remoteMode }) <- get
+    let newPorts = filter ((/= port) . fst) ports
+    put $ state { ports = newPorts }
+    return ()
+
+  -- check whether a port is open or not
+  checkPort :: String -> App Bool
+  checkPort port = do
+    result <- execute "netstat" ["-an", "|", "grep", port] "" False
+    case result of
+      Left _ -> return False
+      Right output ->
+        if (not . null) output then
+          return True
+        else
+          return False
+
+  -- generates a string in format `<key><delimiter><value>\n`
+  -- e.g. |keyvalue [("first", "line"), ("second", "one")] "="| outputs "first=line\nsecond=one"
   keyvalue :: [(String, String)] -> String -> String
   keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit
   keyvalue [] _ = ""
 
+  -- parse a `<key><delimiter><value>` string into a list of (key, value) pairs
   parseKeyValue :: String -> Char -> [(String, String)]
   parseKeyValue text delimit = map parsePair (lines text)
     where
@@ -80,6 +141,7 @@ module System.Serverman.Utils ( App (..)
             (key, value) = splitAt delimitIndex line
         in (key, tail value)
 
+  -- split string at character
   splitAtElem :: String -> Char -> [String]
   splitAtElem "" _ = []
   splitAtElem str char =
@@ -91,21 +153,27 @@ module System.Serverman.Utils ( App (..)
     where
       charIndex = char `elemIndex` str
 
+  -- add a semicolon to end of each line in string
   semicolon :: String -> String
   semicolon text = unlines $ map (++ ";") (lines text)
 
+  -- create a block with the following format: `<name> {\n<content>\n}`
+  -- content is |indent|ed
   block :: String -> String -> String
   block blockName content = blockName ++ " {\n" ++ indent content ++ "}"
 
+  -- alias for |intercalate ", "|
   commas :: [String] -> String
-  commas text = intercalate ", " text
+  commas = intercalate ", "
 
+  -- execute an action if a path is missing
   execIfMissing :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
   execIfMissing path action = do
     exists <- ST.liftIO $ doesPathExist path
     
     when (not exists) action
 
+  -- execute an action if a path exists
   execIfExists :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
   execIfExists path action = do
     exists <- ST.liftIO $ doesPathExist path
@@ -118,6 +186,7 @@ module System.Serverman.Utils ( App (..)
   renameFileIfMissing :: FilePath -> String -> IO ()
   renameFileIfMissing path content = execIfMissing content (renameFile path content)
 
+  -- append a line after a specific string
   appendAfter :: String -> String -> String -> String
   appendAfter content after line =
     let ls = lines content
@@ -125,9 +194,11 @@ module System.Serverman.Utils ( App (..)
 
     in unlines appended
 
+  -- indent all lines forward using \t
   indent :: String -> String
   indent s = unlines $ map ("\t" ++) (lines s)
 
+  -- put single quotes around a text
   quote :: String -> String
   quote input = "'" ++ input ++ "'"
 
@@ -142,38 +213,49 @@ module System.Serverman.Utils ( App (..)
   execute :: String -> [String] -> String -> Bool -> App (Either String String)
   execute cmd args stdin logErrors = exec cmd args stdin Nothing logErrors
 
+  -- execute a command in operating system
+  -- if in remote mode, runs `execRemote`
   exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> App (Either String String)
   exec cmd args stdin cwd logErrors = do
+    verbose $ "exec: " ++ cmd ++ " " ++ show args
     (AppState { remoteMode }) <- get
 
     if isJust remoteMode then do
       let (addr, key) = fromJust remoteMode
 
       execRemote addr (Just key) (Just "serverman") "" cmd args stdin cwd logErrors
-    else liftIO $ do
+    else do
       let command = escape $ cmd ++ " " ++ intercalate " " args
           cp = (proc (escape cmd) (map escape args)) { cwd = cwd }
 
-      process <- async $ do
+      verbose $ "executing command " ++ command
-        result <- tryIOError $ readCreateProcessWithExitCode cp stdin
+
+      process <- liftedAsync $ do
+        result <- liftIO . tryIOError $ readCreateProcessWithExitCode cp stdin
+        verbose "command executed"
 
         case result of
-          Right (ExitSuccess, stdout, _) -> return $ Right stdout
+          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
-              putStrLn $ "exit code: " ++ show code
+              err command
-              putStrLn stdout
+              err $ "exit code: " ++ show code
-              putStrLn stderr
+              err stdout
-              putStrLn $ commandError command
+              err stderr
             return $ Left stdout
-          Left err -> do
+          Left e -> do
+            when (not logErrors) $ verbose $ "couldn't execute command: " ++ show e
             when logErrors $ do
-              putStrLn $ show err
+              err command
-              putStrLn $ commandError command
+              err $ show e
-            return $ Left (show err)
+            return $ Left (show e)
 
-      wait process
+      (result, _) <- liftIO $ wait process
+      return result
 
     where
       escape :: String -> String
@@ -181,37 +263,56 @@ module System.Serverman.Utils ( App (..)
         where
           specialCharacters = ["$"]
 
+  -- run a command on a server using SSH
   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
+    tmp <- ST.liftIO getTemporaryDirectory
     let passwordFile = tmp </> "pw"
 
-    let userArgument = if isJust maybeUser then ["echo", password, "|", "sudo -S", "-u", fromJust maybeUser] else []
+    let userArgument = case maybeUser of
-        keyArgument = if isJust maybeKey then ["-o", "IdentityFile=" ++ fromJust maybeKey] ++ noPassword else noKey
+                         Just user -> if (not . null) password then
+                                        ["echo", password, "|", "sudo -S", "-u", user]
+                                      else
+                                        ["sudo -u", user]
+                         Nothing -> []
+        keyArgument = case maybeKey of
+                        Just key -> 
+                          ["-o", "IdentityFile=" ++ key] ++ noPassword
+                        Nothing -> noKey
+
         p = if null port then [] else ["-p", port]
         connection = takeWhile (/= ':') (show addr)
 
         cumulated = p ++ keyArgument ++ options
         command = userArgument ++ ["sh -c \"", cmd] ++ args ++ ["\""]
+        complete = "ssh" : (cumulated ++ [connection] ++ command)
 
-    (backupEnv, passwordFile) <- liftIO $ do
+    verbose $ "backing up environment variables"
-      backupEnv <- getEnvironment 
+    backupEnv <- ST.liftIO getEnvironment
 
-      writeFile passwordFile $ "echo " ++ password
+    verbose $ "writing passwordFile for SSH " ++ passwordFile
-      setFileMode passwordFile accessModes
+    when (not . null $ password) $ 
-      setEnv "SSH_ASKPASS" passwordFile True
+      ST.liftIO $ do
-
+        writeFile passwordFile $ "echo " ++ password
-      return (backupEnv, passwordFile)
+        setFileMode passwordFile accessModes
+        setEnv "SSH_ASKPASS" passwordFile True
 
     state <- get
     let (AppState { remoteMode = backup }) = state
     put $ state { remoteMode = Nothing }
-    result <- exec "setsid" ("ssh" : cumulated ++ [connection] ++ command) stdin cwd logErrors
+
+    verbose $ "executing command in remote " ++ show complete
+
+    newEnv <- liftIO getEnvironment
+    verbose $ "env " ++ keyvalue newEnv "="
+
+    result <- exec "setsid" complete stdin cwd logErrors
     put $ state { remoteMode = backup }
 
-    liftIO $ do
+    verbose $ "reseting environment and deleting password file"
+    ST.liftIO $ do
       setEnvironment backupEnv
-      removeFile passwordFile
+      execIfExists passwordFile $ removeFile passwordFile
 
     return result
     where
@@ -219,6 +320,7 @@ module System.Serverman.Utils ( App (..)
       noKey = ["-o", "PubkeyAuthentication=no", "-o", "PasswordAuthentication=yes"]
       options = ["-o", "StrictHostKeyChecking=no"]
 
+  -- replace in string
   replace :: String -> String -> String -> String
   replace str replacable alt =
     foldl' rep "" str
@@ -232,11 +334,15 @@ module System.Serverman.Utils ( App (..)
       dropEnd n = reverse . drop n . reverse
 
   restartService :: String -> App (Either String String)
-  restartService service = executeRoot "systemctl" ["restart", service] "" True
+  restartService service = do
+    verbose $ "restarting service " ++ service
+    executeRoot "systemctl" ["restart", service] "" True
 
+  -- execute using sudo
   executeRoot :: String -> [String] -> String -> Bool -> App (Either String String)
   executeRoot cmd args stdin logErrors = execute "sudo" (cmd:args) stdin logErrors
 
+  -- read password from user input (don't show the input)
   getPassword :: IO String
   getPassword = do
     tc <- getTerminalAttributes stdInput
@@ -245,5 +351,10 @@ module System.Serverman.Utils ( App (..)
     setTerminalAttributes stdInput tc Immediately
     return password
 
-  liftedAsync :: MonadBaseControl IO m => m a -> m (Async (StM m a))
+  -- make tabularized help string
-  liftedAsync m = liftBaseWith $ \runInIO -> async (runInIO m)
+  mkHelp :: String -> [(String, String)] -> String
+  mkHelp name entries = name ++ "\n" ++ 
+                          indent (keyvalue tabularized " ")
+    where
+      maxKey = maximum $ map (length . fst) entries
+      tabularized = map (\(key, value) -> (key ++ (replicate (maxKey - length key + 1) ' '), value)) entries

src/System/Term.hs

@@ -4,10 +4,10 @@
 
 module System.Term ( initialize ) where
   import qualified System.Serverman as S
+  import System.Serverman.Log
 
   import System.Environment
   import System.Directory
-  import System.Exit
   import Data.Monoid
   import Data.Maybe
   import Control.Monad
@@ -15,57 +15,116 @@ module System.Term ( initialize ) where
   import Data.Default.Class
   import System.FilePath
   import Data.List
+  import System.Process
 
   import System.Serverman.Utils hiding (liftIO)
   import System.Serverman.Actions.Repository
 
   initialize = do
+    -- read arguments
     args <- getArgs
 
-    dir <- liftIO $ getAppUserDataDirectory "serverman"
+    dir <- getAppUserDataDirectory "serverman"
-    let path = dir </> "repository"
 
+    -- parse parameters
     let params = parseParams args
-    liftIO $ print params
+        isHelp = or $ map (`elem` args) ["help", "--help", "-h", "-?"]
 
     -- Fetch repository first
     S.runApp $ do
+      when (verboseM params) $ do
+        state <- get
+        put $ state { verboseMode = True }
+        verbose "verbose mode on"
+
+      verbose $ show params
+
+      -- fetch repository if running for the first time, set state
       S.run (S.fetchRepository)
+
+      -- detect local operating system
       S.run (S.detectOS)
 
       state@(S.AppState { S.repository }) <- get
-      put $ state { arguments = rest params }
+      put $ state { arguments = rest params, helpArg = isHelp }
 
       case params of
-        (Params { listServices = True }) -> liftIO $ do
+        -- list services in repository
-          mapM_ print repository
+        (Params { listServices = True }) -> do
+          mapM_ (write . show) repository
+
+        -- install a service
         p@(Params { install = Just service }) -> do
+          verbose $ "preparing to install " ++ service
           ms <- findService service
           case ms of
             Just s -> handleRemote p $ S.install s
-            Nothing -> liftIO $ putStrLn $ "service not found: " ++ service
+            Nothing -> die $ "service not found: " ++ service
+
+        p@(Params { update = True }) -> S.run (S.updateRepository)
+
+        p@(Params { manage = Just (act, service) }) -> do
+          verbose $ "preparing to " ++ show act ++ " " ++ service
+          ms <- findService service
+          case ms of
+            Just s -> do
+              case act of
+                Start -> 
+                  handleRemote p $ S.start s
+                Stop ->
+                  handleRemote p $ S.stop s
+
+            Nothing -> 
+              die $ "could not find any service matching " ++ service
+
+        -- install and call a service
         p@(Params { rest = (x:xs), remote }) -> do
           case x of
             (service, Nothing) -> do
+              verbose $ "preparing to call " ++ service
+
               ms <- findService service
               case ms of
                 Just s -> do
-                  handleRemote p $ S.install s
+                  when (not isHelp) $ do
+                    handleRemote p $ S.install s
+
                   S.run $ S.call s remote
 
-                Nothing -> liftIO $ putStrLn $ "could not find any service matching " ++ service
+                Nothing -> do
-            _ -> liftIO $ putStrLn $ "could not understand your input"
+                  if isHelp then
+                    servermanHelp
+                  else
+                    die $ "could not find any service matching " ++ service
+        _ -> servermanHelp
 
-      {-S.run (S.call (head repository) [])-}
+      -- after the program is done, terminate remaining processes
+      (S.AppState { S.processes }) <- get
+      mapM_ (liftIO . terminateProcess) processes
 
     return ()
 
     where
+      -- 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
         list <- liftIO $ map read . lines <$> readFile file
         S.run (S.remote list action)
       handleRemote (Params { remote = Nothing }) action = S.run action
 
+      servermanHelp = do
+        write "serverman [--options] [command/service] [--service-options]"
+
+        write $ mkHelp "commands"
+                          [ ("install <service>", "install a service")
+                          , ("repository list", "list services")
+                          , ("repository update", "update repository")
+                          , ("service start <service>", "start the service")
+                          , ("service stop <service>", "stop the service")
+                          , ("--remote <file>", "run in remote mode: takes a path to a file containing username@ip:port lines")]
+
+        write "to learn about a service's options, run |serverman <service> --help|"
+
 
   data Manage = Start | Stop deriving (Eq, Show)
   data Params = Params { listServices :: Bool
@@ -73,9 +132,19 @@ module System.Term ( initialize ) where
                        , manage       :: Maybe (Manage, String)
                        , update       :: Bool
                        , remote       :: Maybe FilePath
-                       , help         :: Bool
                        , rest         :: [(String, Maybe String)]
-                       } deriving (Show)
+                       , verboseM     :: Bool
+                       }
+  
+  instance Show Params where
+    show (Params { listServices, install, manage, update, remote, rest, verboseM }) =
+      keyvalue [ ("list-services", show listServices)
+               , ("install", show install)
+               , ("manage", show manage)
+               , ("update", show update)
+               , ("remote", show remote)
+               , ("rest", show rest)
+               , ("verbose", show verboseM)] ": "
 
   instance Default Params where
     def = Params { listServices = False
@@ -83,8 +152,8 @@ module System.Term ( initialize ) where
                  , manage       = Nothing
                  , remote       = Nothing
                  , update       = False
-                 , help         = False
                  , rest         = []
+                 , verboseM     = False
                  }
 
   parseParams :: [String] -> Params
@@ -94,9 +163,7 @@ module System.Term ( initialize ) where
   parseParams ("service":"stop":s:xs) = (parseParams xs) { manage = Just (Stop, s) }
   parseParams ("install":s:xs) = (parseParams xs) { install = Just s }
   parseParams ("--remote":s:xs) = (parseParams xs) { remote = Just s }
-  parseParams ("--help":xs) = (parseParams xs) { help = True }
+  parseParams ("--verbose":xs) = (parseParams xs) { verboseM = True }
-  parseParams ("-h":xs) = (parseParams xs) { help = True }
-  parseParams [] = def { help = True }
   parseParams x = def { rest = toPairs x }
     where
       toPairs [] = []

stack.yaml

@@ -2,6 +2,7 @@ flags: {}
 extra-package-dbs: []
 packages:
 - '.'
+- '../termcolors'
 extra-deps:
 - concurrent-extra-0.7.0.10
 - stack-1.3.2

test/Utils.hs

@@ -0,0 +1,4 @@
+import System.Serverman.Utils
+import Test.QuickCheck
+
+