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
, System.Serverman.Utils , System.Serverman.Utils
, System.Serverman.Action , System.Serverman.Action
, System.Serverman.Log
, System.Serverman.Actions.Install , System.Serverman.Actions.Install
, System.Serverman.Actions.Env , System.Serverman.Actions.Env
@ -49,6 +50,8 @@ library
, hint , hint
, stack , stack
, exceptions , exceptions
, monad-loops
, termcolor
default-language: Haskell2010 default-language: Haskell2010
executable serverman executable serverman
@ -66,6 +69,7 @@ test-suite serverman-test
main-is: Spec.hs main-is: Spec.hs
build-depends: base build-depends: base
, serverman , serverman
, quickcheck
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010 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 (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 , Action
, call , call
, fetchRepository , fetchRepository
, updateRepository
, start , start
, stop , stop
, install , install
@ -33,6 +34,7 @@ module System.Serverman.Action ( ActionF(..)
| Install Service x | Install Service x
| Remote [Address] (Action ()) x | Remote [Address] (Action ()) x
| FetchRepository x | FetchRepository x
| UpdateRepository x
| Start Service x | Start Service x
| Stop Service x | Stop Service x
@ -44,6 +46,7 @@ module System.Serverman.Action ( ActionF(..)
fmap f (DetectOS x) = DetectOS (f x) fmap f (DetectOS x) = DetectOS (f x)
fmap f (Remote addr action x) = Remote addr action (f x) fmap f (Remote addr action x) = Remote addr action (f x)
fmap f (FetchRepository x) = FetchRepository (f x) fmap f (FetchRepository x) = FetchRepository (f x)
fmap f (UpdateRepository x) = UpdateRepository (f x)
type Action = Free ActionF type Action = Free ActionF
@ -67,3 +70,6 @@ module System.Serverman.Action ( ActionF(..)
fetchRepository :: Action () fetchRepository :: Action ()
fetchRepository = liftF $ FetchRepository () fetchRepository = liftF $ FetchRepository ()
updateRepository :: Action ()
updateRepository = liftF $ UpdateRepository ()

View File

@ -4,6 +4,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
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
@ -14,10 +15,13 @@ module System.Serverman.Actions.Call (callService) where
import System.Posix.Env import System.Posix.Env
import Data.List import Data.List
import Stack.Package import Stack.Package
import Data.Maybe
callService :: Service -> Maybe FilePath -> App () callService :: Service -> Maybe FilePath -> App ()
callService s@(Service { name, version }) remote = do callService s@(Service { name, version }) remote = do
state@(AppState { repositoryURL }) <- get done <- progress
state@(AppState { repositoryURL, helpArg }) <- get
put $ state { remoteMode = Nothing } put $ state { remoteMode = Nothing }
dir <- liftIO $ getAppUserDataDirectory "serverman" 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 stackEnv) <- exec "stack" ["exec", "env", "--allow-different-user"] "" (Just path) True
(Right stackSourceEnv) <- exec "stack" ["exec", "env", "--allow-different-user"] "" (Just source) True (Right stackSourceEnv) <- exec "stack" ["exec", "env", "--allow-different-user"] "" (Just source) True
let finalEnv = map (mergeEnv $ parseKeyValue stackSourceEnv '=') (parseKeyValue stackEnv '=') let finalEnv = map (mergeEnv $ parseKeyValue stackSourceEnv '=') (parseKeyValue stackEnv '=')
backupEnv <- liftIO $ getEnvironment backupEnv <- liftIO $ getEnvironment
liftIO $ setEnvironment finalEnv liftIO $ setEnvironment finalEnv
func <- liftIO $ runInterpreter (interpreter include entry) func <- liftIO $ runInterpreter (getCall include entry)
helpOutput <- liftIO $ runInterpreter (getHelp include entry)
done
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 case func of
Right fn -> handleRemote remote $ fn s Right fn -> handleRemote remote $ fn s
Left err -> liftIO $ do Left e -> do
putStrLn $ "error reading `call` from module " ++ entry err $ "couldn't read `call` from module " ++ entry
case err of case e of
WontCompile errs -> mapM_ (putStrLn . errMsg) errs WontCompile errs -> mapM_ (write . errMsg) errs
x -> print x GhcException ie -> err ie
UnknownError ie -> err ie
NotAllowed ie -> err ie
liftIO $ setEnvironment backupEnv liftIO $ setEnvironment backupEnv
@ -62,15 +84,22 @@ module System.Serverman.Actions.Call (callService) where
handleRemote _ action = action handleRemote _ action = action
mergeEnv other (key, value) 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 let (Just alt) = lookup key other
in (key, value ++ ":" ++ alt) in (key, value ++ ":" ++ alt)
| key == "LD_PRELOAD" = (key, "")
| otherwise = (key, value) | 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] set [searchPath := path]
loadModules [entry] loadModules [entry]
setTopLevelModules ["Main"] setTopLevelModules ["Main"]
interpret "call" (as :: Service -> App ()) 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 module System.Serverman.Actions.Env (OS(..), getOS, releaseToOS) where
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Types import System.Serverman.Types
import System.Serverman.Log
import System.Process import System.Process
import Data.List import Data.List
@ -10,6 +11,8 @@ module System.Serverman.Actions.Env (OS(..), getOS, releaseToOS) where
import Control.Monad.State import Control.Monad.State
getOS = do getOS = do
verbose "detecting os"
arch_release <- execute "cat" ["/etc/os-release"] "" False arch_release <- execute "cat" ["/etc/os-release"] "" False
deb_release <- execute "cat" ["/etc/lsb-release"] "" False deb_release <- execute "cat" ["/etc/lsb-release"] "" False

View File

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

View File

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

View File

@ -12,9 +12,11 @@ module System.Serverman.Actions.Remote ( runRemotely
import Control.Monad import Control.Monad
import Data.Maybe import Data.Maybe
import Control.Monad.State hiding (liftIO) import Control.Monad.State hiding (liftIO)
import Control.Concurrent
import Data.IORef import Data.IORef
import Data.Either import Data.Either
import Control.Concurrent
actionDelay = 1000000
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
@ -41,15 +43,13 @@ module System.Serverman.Actions.Remote ( runRemotely
liftIO $ createDirectoryIfMissing True path 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
-- result <- execRemote servermanAddr (Just keyPath) Nothing "" "echo" [] "" Nothing False
execute "fusermount" ["-u", path] "" 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 case result of
Right _ -> do Right _ -> do
state <- get state <- get
liftIO $ threadDelay actionDelay
put $ state { remoteMode = Just (servermanAddr, keyPath) } put $ state { remoteMode = Just (servermanAddr, keyPath) }
getOS getOS
action action

View File

@ -5,8 +5,9 @@
module System.Serverman.Actions.Repository (fetchRepo, findService) where module System.Serverman.Actions.Repository (fetchRepo, findService) where
import System.Serverman.Utils import System.Serverman.Utils
import System.Directory import System.Directory
import System.Serverman.Services import System.Serverman.Services hiding (info)
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Log
import System.Serverman.Types import System.Serverman.Types
import System.FilePath import System.FilePath
@ -26,27 +27,37 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where
findService :: String -> App (Maybe Service) findService :: String -> App (Maybe Service)
findService n = do findService n = do
(AppState { repository }) <- get (AppState { repository }) <- get
verbose $ "searching for service " ++ n
return $ find (\a -> name a == n) repository 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 state@(AppState { repositoryURL }) <- get
dir <- liftIO $ getAppUserDataDirectory "serverman" dir <- liftIO $ getAppUserDataDirectory "serverman"
let path = dir </> "repository" let path = dir </> "repository"
let source = dir </> "source" let source = dir </> "source"
execIfMissing path $ do 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 execute "git" ["clone", repositoryURL, path] "" True
return () return ()
execIfMissing source $ do 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 execute "git" ["clone", sourceURL, source] "" True
return () 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") content <- liftIO $ readFile (path </> "repository.json")
@ -65,10 +76,10 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where
return $ rights list return $ rights list
Nothing -> do 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 [] return []
Nothing -> do 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 [] return []
where 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 DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module System.Serverman.Types ( Service (..) module System.Serverman.Types ( Service (..)
, Repository , Repository
@ -8,10 +9,14 @@ module System.Serverman.Types ( Service (..)
, App , App
, Address (..) , Address (..)
, Params , Params
, runApp) where , runApp
, liftedAsync) where
import Data.Default.Class import Data.Default.Class
import GHC.Generics import GHC.Generics
import Control.Monad.State import Control.Monad.State
import Control.Concurrent.Async
import Control.Monad.Trans.Control
import System.Process
type Host = String type Host = String
type Port = String type Port = String
@ -71,12 +76,29 @@ module System.Serverman.Types ( Service (..)
type Repository = [Service] type Repository = [Service]
type SourcePort = String
type DestinationPort = String
data AppState = AppState { remoteMode :: Maybe (Address, String) data AppState = AppState { remoteMode :: Maybe (Address, String)
, repository :: Repository , repository :: Repository
, repositoryURL :: String , repositoryURL :: String
, os :: OS , os :: OS
, arguments :: [(String, Maybe String)] , 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 instance Default AppState where
def = AppState { remoteMode = Nothing def = AppState { remoteMode = Nothing
@ -84,9 +106,16 @@ module System.Serverman.Types ( Service (..)
, repositoryURL = "https://github.com/mdibaiee/serverman-repository" , repositoryURL = "https://github.com/mdibaiee/serverman-repository"
, os = Unknown , os = Unknown
, arguments = [] , arguments = []
, helpArg = False
, verboseMode = False
, ports = []
, processes = []
} }
type App = StateT AppState IO type App = StateT AppState IO
runApp :: App a -> IO (a, AppState) runApp :: App a -> IO (a, AppState)
runApp k = runStateT k def 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 , splitAtElem
, semicolon , semicolon
, block , block
, mkHelp
, indent , indent
, commas , commas
, quote , quote
@ -23,8 +24,9 @@ module System.Serverman.Utils ( App (..)
, execute , execute
, execRemote , execRemote
, Address (..) , Address (..)
, liftedAsync
, liftIO , liftIO
, usingPort
, clearPort
, restartService , restartService
, getPassword , getPassword
, executeRoot) where , executeRoot) where
@ -34,7 +36,7 @@ module System.Serverman.Utils ( App (..)
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Process import System.Process
import System.IO.Error import System.IO.Error (tryIOError)
import Control.Concurrent.Async import Control.Concurrent.Async
import Data.List import Data.List
import Control.Exception import Control.Exception
@ -47,31 +49,90 @@ module System.Serverman.Utils ( App (..)
import System.Posix.Env import System.Posix.Env
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 Control.Monad.Trans.Control
import Data.Default.Class import Data.Default.Class
import System.Unix.Chroot import System.Unix.Chroot
import Control.Monad.Catch import Control.Concurrent
import Control.Monad.Loops
import System.Serverman.Types 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 liftIO action = do
state@(AppState { remoteMode }) <- get state@(AppState { remoteMode, ports }) <- get
verbose $ "liftIO " ++ show remoteMode ++ ", " ++ show ports
case remoteMode of case remoteMode of
Nothing -> ST.liftIO action Nothing -> ST.liftIO action
Just (Address host port user, _) -> do Just rm@(Address host port user, key) -> do
tmp <- ST.liftIO getTemporaryDirectory tmp <- ST.liftIO getTemporaryDirectory
let path = tmp </> (user ++ "@" ++ host) 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 :: [(String, String)] -> String -> String
keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit
keyvalue [] _ = "" keyvalue [] _ = ""
-- parse a `<key><delimiter><value>` string into a list of (key, value) pairs
parseKeyValue :: String -> Char -> [(String, String)] parseKeyValue :: String -> Char -> [(String, String)]
parseKeyValue text delimit = map parsePair (lines text) parseKeyValue text delimit = map parsePair (lines text)
where where
@ -80,6 +141,7 @@ module System.Serverman.Utils ( App (..)
(key, value) = splitAt delimitIndex line (key, value) = splitAt delimitIndex line
in (key, tail value) in (key, tail value)
-- split string at character
splitAtElem :: String -> Char -> [String] splitAtElem :: String -> Char -> [String]
splitAtElem "" _ = [] splitAtElem "" _ = []
splitAtElem str char = splitAtElem str char =
@ -91,21 +153,27 @@ module System.Serverman.Utils ( App (..)
where where
charIndex = char `elemIndex` str charIndex = char `elemIndex` str
-- add a semicolon to end of each line in string
semicolon :: String -> String semicolon :: String -> String
semicolon text = unlines $ map (++ ";") (lines text) 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 :: String -> String -> String
block blockName content = blockName ++ " {\n" ++ indent content ++ "}" block blockName content = blockName ++ " {\n" ++ indent content ++ "}"
-- alias for |intercalate ", "|
commas :: [String] -> String 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 :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
execIfMissing path action = do execIfMissing path action = do
exists <- ST.liftIO $ doesPathExist path exists <- ST.liftIO $ doesPathExist path
when (not exists) action when (not exists) action
-- execute an action if a path exists
execIfExists :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f () execIfExists :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
execIfExists path action = do execIfExists path action = do
exists <- ST.liftIO $ doesPathExist path exists <- ST.liftIO $ doesPathExist path
@ -118,6 +186,7 @@ module System.Serverman.Utils ( App (..)
renameFileIfMissing :: FilePath -> String -> IO () renameFileIfMissing :: FilePath -> String -> IO ()
renameFileIfMissing path content = execIfMissing content (renameFile path content) renameFileIfMissing path content = execIfMissing content (renameFile path content)
-- append a line after a specific string
appendAfter :: String -> String -> String -> String appendAfter :: String -> String -> String -> String
appendAfter content after line = appendAfter content after line =
let ls = lines content let ls = lines content
@ -125,9 +194,11 @@ module System.Serverman.Utils ( App (..)
in unlines appended in unlines appended
-- indent all lines forward using \t
indent :: String -> String indent :: String -> String
indent s = unlines $ map ("\t" ++) (lines s) indent s = unlines $ map ("\t" ++) (lines s)
-- put single quotes around a text
quote :: String -> String quote :: String -> String
quote input = "'" ++ input ++ "'" quote input = "'" ++ input ++ "'"
@ -142,38 +213,49 @@ module System.Serverman.Utils ( App (..)
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
-- execute a command in operating system
-- if in remote mode, runs `execRemote`
exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> App (Either String String) exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> App (Either String String)
exec cmd args stdin cwd logErrors = do exec cmd args stdin cwd logErrors = do
verbose $ "exec: " ++ cmd ++ " " ++ show args
(AppState { remoteMode }) <- get (AppState { remoteMode }) <- get
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) (Just "serverman") "" cmd args stdin cwd logErrors
else liftIO $ 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 }
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 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 Right (ExitFailure code, stdout, stderr) -> do
when (not logErrors) $ verbose $ "command failed: " ++ show code ++ ", stderr: " ++ stderr
when logErrors $ do 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 return $ Left stdout
Left err -> do Left e -> do
when (not logErrors) $ verbose $ "couldn't execute command: " ++ show e
when logErrors $ do 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 where
escape :: String -> String escape :: String -> String
@ -181,37 +263,56 @@ module System.Serverman.Utils ( App (..)
where where
specialCharacters = ["$"] 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 :: 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 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 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] p = if null port then [] else ["-p", port]
connection = takeWhile (/= ':') (show addr) connection = takeWhile (/= ':') (show addr)
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)
(backupEnv, passwordFile) <- liftIO $ do verbose $ "backing up environment variables"
backupEnv <- getEnvironment backupEnv <- ST.liftIO getEnvironment
verbose $ "writing passwordFile for SSH " ++ passwordFile
when (not . null $ password) $
ST.liftIO $ do
writeFile passwordFile $ "echo " ++ password writeFile passwordFile $ "echo " ++ password
setFileMode passwordFile accessModes setFileMode passwordFile accessModes
setEnv "SSH_ASKPASS" passwordFile True setEnv "SSH_ASKPASS" passwordFile True
return (backupEnv, passwordFile)
state <- get state <- get
let (AppState { remoteMode = backup }) = state let (AppState { remoteMode = backup }) = state
put $ state { remoteMode = Nothing } 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 } put $ state { remoteMode = backup }
liftIO $ do verbose $ "reseting environment and deleting password file"
ST.liftIO $ do
setEnvironment backupEnv setEnvironment backupEnv
removeFile passwordFile execIfExists passwordFile $ removeFile passwordFile
return result return result
where where
@ -219,6 +320,7 @@ module System.Serverman.Utils ( App (..)
noKey = ["-o", "PubkeyAuthentication=no", "-o", "PasswordAuthentication=yes"] noKey = ["-o", "PubkeyAuthentication=no", "-o", "PasswordAuthentication=yes"]
options = ["-o", "StrictHostKeyChecking=no"] options = ["-o", "StrictHostKeyChecking=no"]
-- replace in string
replace :: String -> String -> String -> String replace :: String -> String -> String -> String
replace str replacable alt = replace str replacable alt =
foldl' rep "" str foldl' rep "" str
@ -232,11 +334,15 @@ module System.Serverman.Utils ( App (..)
dropEnd n = reverse . drop n . reverse dropEnd n = reverse . drop n . reverse
restartService :: String -> App (Either String String) 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 :: String -> [String] -> String -> Bool -> App (Either String String)
executeRoot cmd args stdin logErrors = execute "sudo" (cmd:args) stdin logErrors 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 :: IO String
getPassword = do getPassword = do
tc <- getTerminalAttributes stdInput tc <- getTerminalAttributes stdInput
@ -245,5 +351,10 @@ module System.Serverman.Utils ( App (..)
setTerminalAttributes stdInput tc Immediately setTerminalAttributes stdInput tc Immediately
return password 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

View File

@ -4,10 +4,10 @@
module System.Term ( initialize ) where module System.Term ( initialize ) where
import qualified System.Serverman as S import qualified System.Serverman as S
import System.Serverman.Log
import System.Environment import System.Environment
import System.Directory import System.Directory
import System.Exit
import Data.Monoid import Data.Monoid
import Data.Maybe import Data.Maybe
import Control.Monad import Control.Monad
@ -15,57 +15,116 @@ module System.Term ( initialize ) where
import Data.Default.Class import Data.Default.Class
import System.FilePath import System.FilePath
import Data.List import Data.List
import System.Process
import System.Serverman.Utils hiding (liftIO) import System.Serverman.Utils hiding (liftIO)
import System.Serverman.Actions.Repository import System.Serverman.Actions.Repository
initialize = do initialize = do
-- read arguments
args <- getArgs args <- getArgs
dir <- liftIO $ getAppUserDataDirectory "serverman" dir <- getAppUserDataDirectory "serverman"
let path = dir </> "repository"
-- parse parameters
let params = parseParams args let params = parseParams args
liftIO $ print params isHelp = or $ map (`elem` args) ["help", "--help", "-h", "-?"]
-- Fetch repository first -- Fetch repository first
S.runApp $ do 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) S.run (S.fetchRepository)
-- detect local operating system
S.run (S.detectOS) S.run (S.detectOS)
state@(S.AppState { S.repository }) <- get state@(S.AppState { S.repository }) <- get
put $ state { arguments = rest params } put $ state { arguments = rest params, helpArg = isHelp }
case params of 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 p@(Params { install = Just service }) -> do
verbose $ "preparing to install " ++ service
ms <- findService service ms <- findService service
case ms of case ms of
Just s -> handleRemote p $ S.install s Just s -> handleRemote p $ S.install s
Nothing -> liftIO $ putStrLn $ "service not found: " ++ service Nothing -> die $ "service not found: " ++ service
p@(Params { rest = (x:xs), remote }) -> do
case x of p@(Params { update = True }) -> S.run (S.updateRepository)
(service, Nothing) -> do
p@(Params { manage = Just (act, service) }) -> do
verbose $ "preparing to " ++ show act ++ " " ++ service
ms <- findService service ms <- findService service
case ms of case ms of
Just s -> do 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
when (not isHelp) $ do
handleRemote p $ S.install s handleRemote p $ S.install s
S.run $ S.call s remote 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 () return ()
where 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 handleRemote (Params { remote = Just file }) action = do
list <- liftIO $ map read . lines <$> readFile file list <- liftIO $ map read . lines <$> readFile file
S.run (S.remote list action) S.run (S.remote list action)
handleRemote (Params { remote = Nothing }) action = S.run 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 Manage = Start | Stop deriving (Eq, Show)
data Params = Params { listServices :: Bool data Params = Params { listServices :: Bool
@ -73,9 +132,19 @@ module System.Term ( initialize ) where
, manage :: Maybe (Manage, String) , manage :: Maybe (Manage, String)
, update :: Bool , update :: Bool
, remote :: Maybe FilePath , remote :: Maybe FilePath
, help :: Bool
, rest :: [(String, Maybe String)] , 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 instance Default Params where
def = Params { listServices = False def = Params { listServices = False
@ -83,8 +152,8 @@ module System.Term ( initialize ) where
, manage = Nothing , manage = Nothing
, remote = Nothing , remote = Nothing
, update = False , update = False
, help = False
, rest = [] , rest = []
, verboseM = False
} }
parseParams :: [String] -> Params parseParams :: [String] -> Params
@ -94,9 +163,7 @@ module System.Term ( initialize ) where
parseParams ("service":"stop":s:xs) = (parseParams xs) { manage = Just (Stop, s) } parseParams ("service":"stop":s:xs) = (parseParams xs) { manage = Just (Stop, s) }
parseParams ("install":s:xs) = (parseParams xs) { install = Just s } parseParams ("install":s:xs) = (parseParams xs) { install = Just s }
parseParams ("--remote":s:xs) = (parseParams xs) { remote = 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 } parseParams x = def { rest = toPairs x }
where where
toPairs [] = [] toPairs [] = []

View File

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

4
test/Utils.hs Normal file
View File

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