feat(log): colored logging using termcolor

This commit is contained in:
Mahdi Dibaiee 2017-03-30 23:00:40 +04:30
parent d8aa65ea4d
commit 4f4a51ae8c
15 changed files with 445 additions and 89 deletions

View File

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

View File

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

View File

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

View File

@ -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
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
done
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 ())
interpreter path entry = do
getCall :: [FilePath] -> FilePath -> Interpreter (Service -> App ())
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)

View File

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

View File

@ -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
liftIO $ putStrLn $ "installed " ++ show s ++ "."
Right _ -> info $ "installed " ++ show s
liftIO $ wait process
return ()

View File

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

View File

@ -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
liftIO $ threadDelay 500
result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" False
case result of
Right _ -> do
state <- get
liftIO $ threadDelay actionDelay
put $ state { remoteMode = Just (servermanAddr, keyPath) }
getOS
action

View File

@ -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 = do
fetchRepo :: Bool -> App Repository
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-}
{-exec "git" ["pull", "origin", "master"] "" (Just source) True-}
when update $ do
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

View File

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

View File

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

View File

@ -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
{-liftIO :: IO a -> App a-}
-- lift IO to App, also applying remote mode and port forwarding:
-- 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
result <- tryIOError $ readCreateProcessWithExitCode cp stdin
verbose $ "executing command " ++ command
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
putStrLn stdout
putStrLn stderr
putStrLn $ commandError command
err command
err $ "exit code: " ++ show code
err stdout
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
putStrLn $ commandError command
return $ Left (show err)
err command
err $ show e
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 []
keyArgument = if isJust maybeKey then ["-o", "IdentityFile=" ++ fromJust maybeKey] ++ noPassword else noKey
let userArgument = case maybeUser of
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
backupEnv <- getEnvironment
verbose $ "backing up environment variables"
backupEnv <- ST.liftIO getEnvironment
writeFile passwordFile $ "echo " ++ password
setFileMode passwordFile accessModes
setEnv "SSH_ASKPASS" passwordFile True
return (backupEnv, passwordFile)
verbose $ "writing passwordFile for SSH " ++ passwordFile
when (not . null $ password) $
ST.liftIO $ do
writeFile passwordFile $ "echo " ++ password
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))
liftedAsync m = liftBaseWith $ \runInIO -> async (runInIO m)
-- make tabularized help string
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

View File

@ -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"
let path = dir </> "repository"
dir <- getAppUserDataDirectory "serverman"
-- 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
mapM_ print repository
-- list services in 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
_ -> liftIO $ putStrLn $ "could not understand your input"
Nothing -> do
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 ("-h":xs) = (parseParams xs) { help = True }
parseParams [] = def { help = True }
parseParams ("--verbose":xs) = (parseParams xs) { verboseM = True }
parseParams x = def { rest = toPairs x }
where
toPairs [] = []

View File

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

4
test/Utils.hs Normal file
View File

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