feat(log): colored logging using termcolor
This commit is contained in:
Mahdi Dibaiee
parent
d8aa65ea4d
commit
4f4a51ae8c
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
83
src/System/Serverman/Log.hs
Normal file
83
src/System/Serverman/Log.hs
Normal 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;"
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 [] = []
|
||||
|
||||
@ -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
4
test/Utils.hs
Normal file
@ -0,0 +1,4 @@
|
||||
import System.Serverman.Utils
|
||||
import Test.QuickCheck
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user