propellor spin

Propellor.hs

@@ -31,6 +31,7 @@ module Propellor (
 	, module Propellor.Property.Cmd
 	, module Propellor.PrivData
 	, module Propellor.Engine
+	, module Propellor.Message
 
 	, module X
 ) where
@@ -40,6 +41,7 @@ import Propellor.Property
 import Propellor.Engine
 import Propellor.Property.Cmd
 import Propellor.PrivData
+import Propellor.Message
 
 import Utility.PartialPrelude as X
 import Utility.Process as X

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,12 +104,9 @@ updateFirst cmdline next = do
 
 	if oldsha == newsha
 		then next
-		else do
+		else ifM (actionMessage "Rebuilding propellor" $ boolSystem "make" [Param "build"])
-			putStrLn "Rebuilding propeller.."
-			hFlush stdout
-			ifM (boolSystem "make" [Param "build"])
 			( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
-				, error "Propellor build failed!" 
+			, errorMessage "Propellor build failed!" 
 			)
 
 getCurrentGitSha1 :: String -> IO String
@@ -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
+	senddata toh f marker s = void $
-		putStr $ "Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host ++ "..."
+		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do
 			hFlush stdout
 			hPutStrLn toh $ toMarked marker s
 			hFlush toh
-		putStrLn "done"
+			return True
 
 sendGitClone :: HostName -> String -> IO ()
-sendGitClone host url = do
+sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $
-	putStrLn $ "Pushing git repository to " ++ host
+	withTmpFile "gitbundle" $ \tmp _ -> allM id
-	withTmpFile "gitbundle" $ \tmp _ -> do
 		-- TODO: ssh connection caching, or better push method
 		-- with less connections.
-		void $ boolSystem "git" [Param "bundle", Param "create", Param "-2", File tmp, Param "HEAD"]
+		[ boolSystem "git" [Param "bundle", Param "create", Param "-2", File tmp, Param "HEAD"]
-		void $ boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]
+		, boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]
-		void $ boolSystem "ssh" [Param ("root@"++host), Param unpackcmd]
+		, 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') 

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
+		r <- actionMessage (propertyDesc l) (ensureProperty 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
 		ensure ls (r <> rs)
-
-warningMessage :: String -> IO ()
-warningMessage s = do
-	setSGR [SetColor Foreground Vivid Red]
-	putStrLn $ "** warning: " ++ s
-	setSGR []
-	hFlush stdout

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!"

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

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)

propellor.cabal

@@ -60,6 +60,7 @@ Library
     Propellor.Property.Tor
     Propellor.Property.User
     Propellor.CmdLine
+    Propellor.Message
     Propellor.PrivData
     Propellor.Engine
     Propellor.Types