feat(progress-text): progressText

fix(progress): improve progress
fix: add more logging to different parts
This commit is contained in:
Mahdi Dibaiee 2017-04-01 12:00:22 +04:30
parent 94333e26a4
commit 9fe858ea5a
8 changed files with 148 additions and 85 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -16,6 +16,7 @@ module System.Term ( initialize ) where
import System.FilePath import System.FilePath
import Data.List import Data.List
import System.Process import System.Process
import Control.Concurrent
import System.Serverman.Utils hiding (liftIO) import System.Serverman.Utils hiding (liftIO)
import System.Serverman.Actions.Repository import System.Serverman.Actions.Repository
@ -99,12 +100,19 @@ module System.Term ( initialize ) where
_ -> servermanHelp _ -> servermanHelp
-- after the program is done, terminate remaining processes -- 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_ (liftIO . terminateProcess) processes
mapM_ clearTemp temps
return () return ()
where 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 -- if remote mode is set, read the file and run the action
-- on servers, otherwise run action locally -- on servers, otherwise run action locally
handleRemote (Params { remote = Just file }) action = do handleRemote (Params { remote = Just file }) action = do