diff --git a/src/System/Serverman/Actions/Call.hs b/src/System/Serverman/Actions/Call.hs index b46ec4c..4ff0b12 100644 --- a/src/System/Serverman/Actions/Call.hs +++ b/src/System/Serverman/Actions/Call.hs @@ -3,7 +3,7 @@ module System.Serverman.Actions.Call (callService) where import System.Serverman.Types - import System.Serverman.Utils + import System.Serverman.Utils hiding (liftIO) import System.Serverman.Log import qualified System.Serverman.Actions.Repository import System.Serverman.Actions.Remote @@ -11,7 +11,7 @@ module System.Serverman.Actions.Call (callService) where import System.Directory import System.FilePath import Language.Haskell.Interpreter hiding (get, name, liftIO) - import Control.Monad.State hiding (liftIO) + import Control.Monad.State import System.Posix.Env import Data.List import Stack.Package @@ -19,7 +19,7 @@ module System.Serverman.Actions.Call (callService) where callService :: Service -> Maybe FilePath -> App () callService s@(Service { name, version }) remote = do - done <- progress + done <- progressText $ "running service " ++ show s state@(AppState { repositoryURL, helpArg }) <- get put $ state { remoteMode = Nothing } diff --git a/src/System/Serverman/Actions/Install.hs b/src/System/Serverman/Actions/Install.hs index 60988f0..8dab761 100644 --- a/src/System/Serverman/Actions/Install.hs +++ b/src/System/Serverman/Actions/Install.hs @@ -21,7 +21,7 @@ module System.Serverman.Actions.Install (installService) where installService :: Service -> App () installService s@(Service { dependencies, packages }) = do - done <- progress + done <- progressText $ "installing " ++ show s (AppState { os }) <- get deps <- catMaybes <$> mapM findService dependencies @@ -33,13 +33,11 @@ module System.Serverman.Actions.Install (installService) where _ -> ("echo", ["Unknown operating system"]) pkg = packageByOS s os - process <- liftedAsync $ do - result <- executeRoot (fst base) (snd base ++ pkg) "" True - done + result <- executeRoot (fst base) (snd base ++ pkg) "" True + done + + case result of + Left err -> return () + Right _ -> info $ "installed " ++ show s - case result of - Left err -> return () - Right _ -> info $ "installed " ++ show s - - liftIO $ wait process return () diff --git a/src/System/Serverman/Actions/Remote.hs b/src/System/Serverman/Actions/Remote.hs index be57556..9dc46f7 100644 --- a/src/System/Serverman/Actions/Remote.hs +++ b/src/System/Serverman/Actions/Remote.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE NamedFieldPuns #-} + module System.Serverman.Actions.Remote ( runRemotely , Address) where - import System.Serverman.Utils + import System.Serverman.Utils hiding (liftIO) import System.Serverman.Actions.Env + import System.Serverman.Log import Data.List import System.Directory @@ -9,9 +12,10 @@ module System.Serverman.Actions.Remote ( runRemotely import System.FilePath import System.Posix.Env import System.Posix.Files + import System.Posix.Types import Control.Monad import Data.Maybe - import Control.Monad.State hiding (liftIO) + import Control.Monad.State import Control.Concurrent import Data.IORef import Data.Either @@ -20,6 +24,8 @@ module System.Serverman.Actions.Remote ( runRemotely runRemotely :: Address -> App r -> App () runRemotely addr@(Address host port user) action = do + done <- progressText $ "connecting to server " ++ show addr + tmp <- liftIO getTemporaryDirectory (Right userID) <- execute "id" ["-u"] "" True @@ -28,7 +34,7 @@ module System.Serverman.Actions.Remote ( runRemotely connection = takeWhile (/= ':') (show addr) smConnection = "serverman@" ++ host path = tmp smConnection - uid = ["-o", "uid=" ++ userID, "-o", "gid=" ++ userID] + uid = ["-o", "uid=" ++ removeTrailingNewline userID, "-o", "gid=" ++ removeTrailingNewline userID] serverPaths = ["/usr/lib/openssh/sftp-server", "/usr/lib/ssh/sftp-server"] @@ -40,35 +46,54 @@ module System.Serverman.Actions.Remote ( runRemotely let keyPath = home ".ssh/serverman" pubPath = keyPath <.> "pub" - liftIO $ createDirectoryIfMissing True path - -- check if a connection to SSH server using public key is possible - execute "fusermount" ["-u", path] "" False - result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" False + result <- do + exists <- liftIO $ doesPathExist path + content <- if exists then liftIO $ listDirectory path else return [] + + if not exists || null content then do + liftIO $ createDirectoryIfMissing True path + + verbose $ "mounting SSHFs: " ++ path + + result <- execute "sshfs" (p ++ noPassword ++ uid ++ options ++ ["-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" False + + state@(AppState { temps }) <- get + put $ state { temps = path:temps } + + return result + else do + verbose $ "SSHFs already mounted on " ++ path ++ ", continuing" + return $ Right "already mounted" + + done case result of Right _ -> do state <- get - liftIO $ threadDelay actionDelay + liftIO $ do + threadDelay actionDelay + put $ state { remoteMode = Just (servermanAddr, keyPath) } getOS action return () - Left err -> do - liftIO $ print err - liftIO $ do - putStrLn $ "it seems to be the first time you are using serverman for configuring " ++ show addr - putStrLn $ "remotely. serverman will create a user, and add it to sudoers file. an ssh key will be created" - putStrLn $ "and that will be used for connecting to the server from now on." - putStrLn $ "you might be prompted for password if you are not using SSH key authentication." + Left e -> do + info $ "it seems to be the first time you are using serverman for configuring " ++ show addr + write $ "remotely. serverman will create a user, and add it to sudoers file. an ssh key will be created" + write $ "and that will be used for connecting to the server from now on" + write $ "you will not be prompted for a password to connect to server with" + write $ "please enable password authentication temporarily on your server for this step" - putStrLn $ "Enter password for " ++ connection + write $ "Enter password for " ++ connection home <- liftIO getHomeDirectory password <- liftIO getPassword + done <- progressText $ "setting up serverman user in server " ++ show addr + execIfMissing keyPath $ execute "ssh-keygen" ["-N", "", "-f", keyPath] "" True >> return () publicKey <- liftIO $ readFile pubPath @@ -85,6 +110,8 @@ module System.Serverman.Actions.Remote ( runRemotely runCommand "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"] runCommand "chown" ["-R", "serverman", "/home/serverman"] + done + runRemotely addr action return () diff --git a/src/System/Serverman/Actions/Repository.hs b/src/System/Serverman/Actions/Repository.hs index 626545b..bfc7509 100644 --- a/src/System/Serverman/Actions/Repository.hs +++ b/src/System/Serverman/Actions/Repository.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Serverman.Actions.Repository (fetchRepo, findService) where - import System.Serverman.Utils + import System.Serverman.Utils hiding (liftIO) import System.Directory import System.Serverman.Services hiding (info) import System.Serverman.Actions.Env @@ -17,7 +17,7 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where import Data.Aeson.Types import GHC.Generics import qualified Data.Map as M - import Control.Monad.State hiding (liftIO) + import Control.Monad.State import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Text as T import Data.List @@ -41,22 +41,38 @@ module System.Serverman.Actions.Repository (fetchRepo, findService) where execIfMissing path $ do verbose "repository missing... cloning repository" + + done <- progressText "downloading repository" + info $ "cloning " ++ repositoryURL ++ " in " ++ path execute "git" ["clone", repositoryURL, path] "" True + + done + info $ "downloaded repository" return () execIfMissing source $ do verbose "serverman source missing... cloning repository" + done <- progressText "downloading serverman source" + info $ "cloning " ++ sourceURL ++ " in " ++ source execute "git" ["clone", sourceURL, source] "" True + + done + info $ "downloaded serverman source" return () when update $ do verbose "updating repository" + done <- progressText "updating repository" + exec "git" ["pull", "origin", "master"] "" (Just path) True exec "git" ["pull", "origin", "master"] "" (Just source) True + + done + info $ "updated repository" return () content <- liftIO $ readFile (path "repository.json") diff --git a/src/System/Serverman/Log.hs b/src/System/Serverman/Log.hs index 349d8c6..4a969c5 100644 --- a/src/System/Serverman/Log.hs +++ b/src/System/Serverman/Log.hs @@ -5,10 +5,10 @@ module System.Serverman.Log ( verbose , info , write , progress + , progressText , warning , err - , die - , progressListener) where + , die) where import System.Serverman.Types @@ -46,33 +46,46 @@ module System.Serverman.Log ( verbose die str = liftIO . E.die . format . bold . F.red $ read ("[fatal error] " ++ str) progress :: App (App ()) - progress = do + progress = progressText "working" + + clearLine :: IO () + clearLine = do + putStr $ "\ESC[2K\ESC[0;" + hFlush stdout + + backward :: Int -> IO () + backward n = do + putStr $ "\ESC[" ++ (show n) ++ "D\ESC[0;" + + progressText :: String -> App (App ()) + progressText str = do state <- get - p <- progressListener + p <- progressListener str return p - - progressPrefix = "working " progressCharacters = [". ", ".. ", "...", " ..", " .", " "] progressDelay = 200000 - progressListener :: App (App ()) - progressListener = do + progressListener :: String -> App (App ()) + progressListener text = do + liftIO $ putStr $ replicate strLength '.' + p <- liftedAsync $ mapM start (cycle [0..length progressCharacters]) return $ stop p where + strLength = 2 + length text + length (head progressCharacters) start n = do liftIO . threadDelay $ progressDelay liftedAsync $ do - let str = progressPrefix ++ (progressCharacters !! n) + let str = text ++ " " ++ (progressCharacters !! n) liftIO $ do + backward strLength putStr . format . (light . F.blue) $ read str - putStr $ "\ESC[" ++ (show $ length str) ++ "D\ESC[0;" hFlush stdout return () @@ -80,4 +93,5 @@ module System.Serverman.Log ( verbose stop process = do liftIO $ do cancel process - putStr "\ESC[0;" + backward strLength + clearLine diff --git a/src/System/Serverman/Types.hs b/src/System/Serverman/Types.hs index 21a47f1..b15c4ff 100644 --- a/src/System/Serverman/Types.hs +++ b/src/System/Serverman/Types.hs @@ -87,10 +87,11 @@ module System.Serverman.Types ( Service (..) , verboseMode :: Bool , ports :: [(SourcePort, DestinationPort)] , processes :: [ProcessHandle] + , temps :: [FilePath] } instance Show AppState where - show (AppState { remoteMode, repository, repositoryURL, os, arguments, ports, processes }) = + show (AppState { remoteMode, repository, repositoryURL, os, arguments, ports, processes, temps, verboseMode }) = "remote: " ++ show remoteMode ++ "\n" ++ "repository:\n" ++ " - url: " ++ show repositoryURL ++ "\n" ++ @@ -98,7 +99,9 @@ module System.Serverman.Types ( Service (..) "operating system: " ++ show os ++ "\n" ++ "arguments: " ++ show arguments ++ "\n" ++ "port forwarding: " ++ show ports ++ "\n" ++ - "processes: " ++ show (length processes) + "verbose: " ++ show verboseMode ++ "\n" ++ + "processes: " ++ show (length processes) ++ + "temps: " ++ show (length temps) instance Default AppState where def = AppState { remoteMode = Nothing @@ -110,6 +113,7 @@ module System.Serverman.Types ( Service (..) , verboseMode = False , ports = [] , processes = [] + , temps = [] } type App = StateT AppState IO diff --git a/src/System/Serverman/Utils.hs b/src/System/Serverman/Utils.hs index b20f36c..ebd3ce1 100644 --- a/src/System/Serverman/Utils.hs +++ b/src/System/Serverman/Utils.hs @@ -18,7 +18,6 @@ module System.Serverman.Utils ( App (..) , execIfExists , writeFileIfMissing , renameFileIfMissing - , commandError , appendAfter , exec , execute @@ -40,7 +39,7 @@ module System.Serverman.Utils ( App (..) import Control.Concurrent.Async import Data.List import Control.Exception - import System.Exit + import System.Exit hiding (die) import Data.Maybe import System.Posix.Terminal import System.Posix.IO (stdInput) @@ -50,6 +49,7 @@ module System.Serverman.Utils ( App (..) import qualified Control.Monad.State as ST import Control.Monad.State hiding (liftIO) import Data.Default.Class + import Control.Monad.Catch (catchIOError) import System.Unix.Chroot import Control.Concurrent import Control.Monad.Loops @@ -78,7 +78,9 @@ module System.Serverman.Utils ( App (..) verbose $ "chroot directory " ++ path - fchroot path $ ST.liftIO action + catchIOError + (fchroot path $ ST.liftIO action) + (\e -> err (show e) >> (ST.liftIO $ threadDelay 1000000) >> liftIO action) where portForward (Address host port user, key) (source, destination) = do let forward = source ++ ":" ++ host ++ ":" ++ destination @@ -101,6 +103,9 @@ module System.Serverman.Utils ( App (..) Nothing -> return port Just _ -> do available <- head <$> dropWhileM checkPort range + + verbose $ "using port " ++ available ++ " in place of " ++ port + put $ state { ports = (available, port):ports } return available where @@ -109,6 +114,7 @@ module System.Serverman.Utils ( App (..) -- clear a port clearPort :: String -> App () clearPort port = do + verbose $ "freed port " ++ port state@(AppState { ports, remoteMode }) <- get let newPorts = filter ((/= port) . fst) ports put $ state { ports = newPorts } @@ -207,9 +213,6 @@ module System.Serverman.Utils ( App (..) | (reverse . take 1 . reverse) input == "\n" = take (length input - 1) input | otherwise = input - commandError :: String -> String - commandError command = "[Error] an error occured while running: " ++ command ++ "\nplease try running the command manually." - execute :: String -> [String] -> String -> Bool -> App (Either String String) execute cmd args stdin logErrors = exec cmd args stdin Nothing logErrors @@ -223,39 +226,35 @@ module System.Serverman.Utils ( App (..) if isJust remoteMode then do let (addr, key) = fromJust remoteMode - execRemote addr (Just key) (Just "serverman") "" cmd args stdin cwd logErrors + execRemote addr (Just key) Nothing "" cmd args stdin cwd logErrors else do let command = escape $ cmd ++ " " ++ intercalate " " args cp = (proc (escape cmd) (map escape args)) { cwd = cwd } - verbose $ "executing command " ++ command + verbose $ "executing command |" ++ command ++ "|" - process <- liftedAsync $ do - result <- liftIO . tryIOError $ readCreateProcessWithExitCode cp stdin - verbose "command executed" + result <- ST.liftIO . tryIOError $ readCreateProcessWithExitCode cp stdin + verbose "command executed" - case result of - Right (ExitSuccess, stdout, _) -> do - verbose $ "command successful: " ++ stdout - return $ Right stdout + case result of + 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 - err command - err $ "exit code: " ++ show code - err stdout - err stderr - return $ Left stdout - Left e -> do - when (not logErrors) $ verbose $ "couldn't execute command: " ++ show e - when logErrors $ do - err command - err $ show e - return $ Left (show e) - - (result, _) <- liftIO $ wait process - return result + Right (ExitFailure code, stdout, stderr) -> do + when (not logErrors) $ verbose $ "command failed: " ++ show code ++ ", stderr: " ++ stderr + when logErrors $ do + err command + err $ "exit code: " ++ show code + err stdout + err stderr + return $ Left stdout + Left e -> do + when (not logErrors) $ verbose $ "couldn't execute command: " ++ show e + when logErrors $ do + err command + err $ show e + return $ Left (show e) where escape :: String -> String @@ -271,9 +270,9 @@ module System.Serverman.Utils ( App (..) let userArgument = case maybeUser of Just user -> if (not . null) password then - ["echo", password, "|", "sudo -S", "-u", user] + ["echo", password, "|", "sudo", "-S", "-u", user] else - ["sudo -u", user] + ["sudo", "-u", user] Nothing -> [] keyArgument = case maybeKey of Just key -> @@ -285,13 +284,13 @@ module System.Serverman.Utils ( App (..) cumulated = p ++ keyArgument ++ options command = userArgument ++ ["sh -c \"", cmd] ++ args ++ ["\""] - complete = "ssh" : (cumulated ++ [connection] ++ command) + complete = "-w" : "ssh" : (cumulated ++ [connection] ++ (intersperse " " command)) verbose $ "backing up environment variables" backupEnv <- ST.liftIO getEnvironment - verbose $ "writing passwordFile for SSH " ++ passwordFile - when (not . null $ password) $ + when (not . null $ password) $ do + verbose $ "writing passwordFile for SSH " ++ passwordFile ++ " and setting SSH_ASKPASS" ST.liftIO $ do writeFile passwordFile $ "echo " ++ password setFileMode passwordFile accessModes @@ -301,10 +300,7 @@ module System.Serverman.Utils ( App (..) let (AppState { remoteMode = backup }) = state put $ state { remoteMode = Nothing } - verbose $ "executing command in remote " ++ show complete - - newEnv <- liftIO getEnvironment - verbose $ "env " ++ keyvalue newEnv "=" + verbose $ "executing command |setsid " ++ show complete ++ "|" result <- exec "setsid" complete stdin cwd logErrors put $ state { remoteMode = backup } diff --git a/src/System/Term.hs b/src/System/Term.hs index 0bf19d6..9617f8f 100644 --- a/src/System/Term.hs +++ b/src/System/Term.hs @@ -16,6 +16,7 @@ module System.Term ( initialize ) where import System.FilePath import Data.List import System.Process + import Control.Concurrent import System.Serverman.Utils hiding (liftIO) import System.Serverman.Actions.Repository @@ -99,12 +100,19 @@ module System.Term ( initialize ) where _ -> servermanHelp -- after the program is done, terminate remaining processes - (S.AppState { S.processes }) <- get + -- and unmount/remove leftover temporary directories + state@(S.AppState { S.processes, S.temps }) <- get + put $ state { remoteMode = Nothing } + mapM_ (liftIO . terminateProcess) processes + mapM_ clearTemp temps return () where + clearTemp path = execIfExists path $ do + execute "fusermount" ["-u", path] "" False + liftIO $ removeDirectoryRecursive path -- if remote mode is set, read the file and run the action -- on servers, otherwise run action locally handleRemote (Params { remote = Just file }) action = do