thereadme/serverman
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

feat(progress-text): progressText

Browse Source 
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
Download Patch File Download Diff File Expand all files Collapse all files

6
src/System/Serverman/Actions/Call.hs
View File

@@ -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 }

4
src/System/Serverman/Actions/Install.hs
View File

@@ -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,7 +33,6 @@ 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
@@ -41,5 +40,4 @@ module System.Serverman.Actions.Install (installService) where
Left err -> return ()
Right _ -> info $ "installed " ++ show s
liftIO $ wait process
return ()

55
src/System/Serverman/Actions/Remote.hs
View File

@@ -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"
-- check if a connection to SSH server using public key is possible
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
-- check if a connection to SSH server using public key is possible
execute "fusermount" ["-u", path] "" False
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 ()

20
src/System/Serverman/Actions/Repository.hs
View File

@@ -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")

36
src/System/Serverman/Log.hs
View File

@@ -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

8
src/System/Serverman/Types.hs
View File

@@ -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

40
src/System/Serverman/Utils.hs
View File

@@ -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,15 +226,14 @@ 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
result <- ST.liftIO . tryIOError $ readCreateProcessWithExitCode cp stdin
verbose "command executed"
case result of
@@ -254,9 +256,6 @@ module System.Serverman.Utils ( App (..)
err $ show e
return $ Left (show e)
(result, _) <- liftIO $ wait process
return result
where
escape :: String -> String
escape string = foldl' (\str char -> replace str char ('\\':char)) string specialCharacters
@@ -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 }

10
src/System/Term.hs
View File

@@ -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