From c246a8ee745723140150c8b8d35b7a7121c90c11 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 31 Mar 2014 18:31:08 -0400 Subject: propellor spin --- Propellor/CmdLine.hs | 51 ++++++++++++++++++++++++--------------------------- Propellor/Engine.hs | 29 +++-------------------------- Propellor/Message.hs | 40 ++++++++++++++++++++++++++++++++++++++++ Propellor/PrivData.hs | 2 +- Propellor/Types.hs | 13 +++++++++++++ 5 files changed, 81 insertions(+), 54 deletions(-) create mode 100644 Propellor/Message.hs (limited to 'Propellor') diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 74b2cab1..a5ce9dda 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -38,15 +38,15 @@ processCmdLine = go =<< getArgs go ("--add-key":k:[]) = return $ AddKey k go ("--set":h:f:[]) = case readish f of Just pf -> return $ Set h pf - Nothing -> error $ "Unknown privdata field " ++ f + Nothing -> errorMessage $ "Unknown privdata field " ++ f go ("--continue":s:[]) =case readish s of Just cmdline -> return $ Continue cmdline - Nothing -> error "--continue serialization failure" + Nothing -> errorMessage "--continue serialization failure" go (h:[]) = return $ Run h go [] = do s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] if null s - then error "Cannot determine hostname! Pass it on the command line." + then errorMessage "Cannot determine hostname! Pass it on the command line." else return $ Run s go _ = usage @@ -64,7 +64,7 @@ defaultMain getprops = go True =<< processCmdLine withprops host a = maybe (unknownhost host) a (getprops host) unknownhost :: HostName -> IO a -unknownhost h = error $ unwords +unknownhost h = errorMessage $ unwords [ "Unknown host:", h , "(perhaps you should specify the real hostname on the command line?)" ] @@ -96,7 +96,7 @@ updateFirst cmdline next = do then do putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging" hFlush stdout - else error $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!" + else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!" oldsha <- getCurrentGitSha1 branchref void $ boolSystem "git" [Param "merge", Param originbranch] @@ -104,13 +104,10 @@ updateFirst cmdline next = do if oldsha == newsha then next - else do - putStrLn "Rebuilding propeller.." - hFlush stdout - ifM (boolSystem "make" [Param "build"]) - ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] - , error "Propellor build failed!" - ) + else ifM (actionMessage "Rebuilding propellor" $ boolSystem "make" [Param "build"]) + ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] + , errorMessage "Propellor build failed!" + ) getCurrentGitSha1 :: String -> IO String getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] @@ -131,7 +128,7 @@ spin host = do void $ tryIO $ forever $ showremote =<< hGetLine fromh hClose fromh - status <- getstatus fromh `catchIO` error "protocol error" + status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error") case status of Ready -> finish NeedGitClone -> do @@ -166,22 +163,22 @@ spin host = do Just status -> return status showremote s = putStrLn s - senddata toh f marker s = do - putStr $ "Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host ++ "..." - hFlush stdout - hPutStrLn toh $ toMarked marker s - hFlush toh - putStrLn "done" + senddata toh f marker s = void $ + actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do + hFlush stdout + hPutStrLn toh $ toMarked marker s + hFlush toh + return True sendGitClone :: HostName -> String -> IO () -sendGitClone host url = do - putStrLn $ "Pushing git repository to " ++ host - withTmpFile "gitbundle" $ \tmp _ -> do +sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ + withTmpFile "gitbundle" $ \tmp _ -> allM id -- TODO: ssh connection caching, or better push method -- with less connections. - void $ boolSystem "git" [Param "bundle", Param "create", Param "-2", File tmp, Param "HEAD"] - void $ boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)] - void $ boolSystem "ssh" [Param ("root@"++host), Param unpackcmd] + [ boolSystem "git" [Param "bundle", Param "create", Param "-2", File tmp, Param "HEAD"] + , boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)] + , boolSystem "ssh" [Param ("root@"++host), Param unpackcmd] + ] where remotebundle = "/usr/local/propellor.git" unpackcmd = shellWrap $ intercalate " && " @@ -265,10 +262,10 @@ localdir :: FilePath localdir = "/usr/local/propellor" getUrl :: IO String -getUrl = fromMaybe nourl <$> getM get urls +getUrl = maybe nourl return =<< getM get urls where urls = ["remote.deploy.url", "remote.origin.url"] - nourl = error $ "Cannot find deploy url in " ++ show urls + nourl = errorMessage $ "Cannot find deploy url in " ++ show urls get u = do v <- catchMaybeIO $ takeWhile (/= '\n') diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs index a220ec77..e35e4c84 100644 --- a/Propellor/Engine.hs +++ b/Propellor/Engine.hs @@ -1,11 +1,12 @@ module Propellor.Engine where -import System.Console.ANSI import System.Exit import System.IO import Data.Monoid +import System.Console.ANSI import Propellor.Types +import Propellor.Message import Utility.Exception ensureProperty :: Property -> IO Result @@ -25,29 +26,5 @@ ensureProperties' ps = ensure ps NoChange where ensure [] rs = return rs ensure (l:ls) rs = do - setTitle $ propertyDesc l - hFlush stdout - r <- ensureProperty l - clearFromCursorToLineBeginning - setCursorColumn 0 - putStr $ propertyDesc l ++ "... " - case r of - FailedChange -> do - setSGR [SetColor Foreground Vivid Red] - putStrLn "failed" - NoChange -> do - setSGR [SetColor Foreground Dull Green] - putStrLn "unchanged" - MadeChange -> do - setSGR [SetColor Foreground Vivid Green] - putStrLn "done" - setSGR [] - hFlush stdout + r <- actionMessage (propertyDesc l) (ensureProperty l) ensure ls (r <> rs) - -warningMessage :: String -> IO () -warningMessage s = do - setSGR [SetColor Foreground Vivid Red] - putStrLn $ "** warning: " ++ s - setSGR [] - hFlush stdout diff --git a/Propellor/Message.hs b/Propellor/Message.hs new file mode 100644 index 00000000..a7ceff91 --- /dev/null +++ b/Propellor/Message.hs @@ -0,0 +1,40 @@ +module Propellor.Message where + +import System.Console.ANSI +import System.IO + +import Propellor.Types + +-- | Shows a message while performing an action, with a colored status +-- display. +actionMessage :: ActionResult r => Desc -> IO r -> IO r +actionMessage desc a = do + setTitle desc + showdesc + putStrLn "starting" + hFlush stdout + + r <- a + + let (msg, intensity, color) = getActionResult r + showdesc + setSGR [SetColor Foreground intensity color] + putStrLn msg + setSGR [] + hFlush stdout + + return r + where + showdesc = putStr $ desc ++ " ... " + +warningMessage :: String -> IO () +warningMessage s = do + setSGR [SetColor Foreground Vivid Red] + putStrLn $ "** warning: " ++ s + setSGR [] + hFlush stdout + +errorMessage :: String -> IO a +errorMessage s = do + warningMessage s + error "Propellor failed!" diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index ce52d576..98a1da62 100644 --- a/Propellor/PrivData.hs +++ b/Propellor/PrivData.hs @@ -9,7 +9,7 @@ import Data.Maybe import Control.Monad import Propellor.Types -import Propellor.Engine +import Propellor.Message import Utility.Monad import Utility.PartialPrelude import Utility.Exception diff --git a/Propellor/Types.hs b/Propellor/Types.hs index ec472ffe..5874863c 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -1,6 +1,7 @@ module Propellor.Types where import Data.Monoid +import System.Console.ANSI type HostName = String type UserName = String @@ -24,3 +25,15 @@ instance Monoid Result where mappend MadeChange _ = MadeChange mappend _ MadeChange = MadeChange mappend NoChange NoChange = NoChange + +class ActionResult a where + getActionResult :: a -> (String, ColorIntensity, Color) + +instance ActionResult Bool where + getActionResult False = ("ok", Vivid, Red) + getActionResult True = ("failed", Vivid, Green) + +instance ActionResult Result where + getActionResult NoChange = ("unchanged", Dull, Green) + getActionResult MadeChange = ("done", Vivid, Green) + getActionResult FailedChange = ("failed", Vivid, Red) -- cgit v1.2.3