summaryrefslogtreecommitdiff
path: root/Propellor
diff options
context:
space:
mode:
authorJoey Hess2014-03-31 18:31:08 -0400
committerJoey Hess2014-03-31 18:31:08 -0400
commitc246a8ee745723140150c8b8d35b7a7121c90c11 (patch)
treedf25d3e13ef919e14ee51f1c70e82073c1077209 /Propellor
parent549df2612c0e12d44bf4e998cabdfcf3bb0a7344 (diff)
propellor spin
Diffstat (limited to 'Propellor')
-rw-r--r--Propellor/CmdLine.hs51
-rw-r--r--Propellor/Engine.hs29
-rw-r--r--Propellor/Message.hs40
-rw-r--r--Propellor/PrivData.hs2
-rw-r--r--Propellor/Types.hs13
5 files changed, 81 insertions, 54 deletions
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)