diff --git a/serverman.cabal b/serverman.cabal index 7c38cd5..67e29b5 100644 --- a/serverman.cabal +++ b/serverman.cabal @@ -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 diff --git a/src/System/Serverman.hs b/src/System/Serverman.hs index 601c04c..cf44cec 100644 --- a/src/System/Serverman.hs +++ b/src/System/Serverman.hs @@ -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 diff --git a/src/System/Serverman/Action.hs b/src/System/Serverman/Action.hs index 14fec1e..5eba4d9 100644 --- a/src/System/Serverman/Action.hs +++ b/src/System/Serverman/Action.hs @@ -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 () diff --git a/src/System/Serverman/Actions/Call.hs b/src/System/Serverman/Actions/Call.hs index bc3b20f..b46ec4c 100644 --- a/src/System/Serverman/Actions/Call.hs +++ b/src/System/Serverman/Actions/Call.hs @@ -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) diff --git a/src/System/Serverman/Actions/Env.hs b/src/System/Serverman/Actions/Env.hs index 8d4771b..64864fc 100644 --- a/src/System/Serverman/Actions/Env.hs +++ b/src/System/Serverman/Actions/Env.hs @@ -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 diff --git a/src/System/Serverman/Actions/Install.hs b/src/System/Serverman/Actions/Install.hs index f69ac65..60988f0 100644 --- a/src/System/Serverman/Actions/Install.hs +++ b/src/System/Serverman/Actions/Install.hs @@ -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 () diff --git a/src/System/Serverman/Actions/Manage.hs b/src/System/Serverman/Actions/Manage.hs index d6089dd..e49d96e 100644 --- a/src/System/Serverman/Actions/Manage.hs +++ b/src/System/Serverman/Actions/Manage.hs @@ -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 diff --git a/src/System/Serverman/Actions/Remote.hs b/src/System/Serverman/Actions/Remote.hs index eda9f85..be57556 100644 --- a/src/System/Serverman/Actions/Remote.hs +++ b/src/System/Serverman/Actions/Remote.hs @@ -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 diff --git a/src/System/Serverman/Actions/Repository.hs b/src/System/Serverman/Actions/Repository.hs index 9acff30..626545b 100644 --- a/src/System/Serverman/Actions/Repository.hs +++ b/src/System/Serverman/Actions/Repository.hs @@ -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 diff --git a/src/System/Serverman/Log.hs b/src/System/Serverman/Log.hs new file mode 100644 index 0000000..349d8c6 --- /dev/null +++ b/src/System/Serverman/Log.hs @@ -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;" diff --git a/src/System/Serverman/Types.hs b/src/System/Serverman/Types.hs index 28e24ea..21a47f1 100644 --- a/src/System/Serverman/Types.hs +++ b/src/System/Serverman/Types.hs @@ -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) + diff --git a/src/System/Serverman/Utils.hs b/src/System/Serverman/Utils.hs index 33a0443..b20f36c 100644 --- a/src/System/Serverman/Utils.hs +++ b/src/System/Serverman/Utils.hs @@ -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 `\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 `` 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: ` {\n\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 diff --git a/src/System/Term.hs b/src/System/Term.hs index 2375f05..0bf19d6 100644 --- a/src/System/Term.hs +++ b/src/System/Term.hs @@ -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 ", "install a service") + , ("repository list", "list services") + , ("repository update", "update repository") + , ("service start ", "start the service") + , ("service stop ", "stop the service") + , ("--remote ", "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 --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 [] = [] diff --git a/stack.yaml b/stack.yaml index 19bbc88..0d4878b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ flags: {} extra-package-dbs: [] packages: - '.' +- '../termcolors' extra-deps: - concurrent-extra-0.7.0.10 - stack-1.3.2 diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 index 0000000..99e5b4f --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,4 @@ +import System.Serverman.Utils +import Test.QuickCheck + +