summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-27 16:19:15 -0400
committerJoey Hess2015-10-27 16:19:15 -0400
commit6e3b0022fa451181fdce8abd145e27a64a777711 (patch)
tree89e360698db6c6029cd639668865cef420966042
parent56c3394144abbb9862dc67379d3253c76ae4df97 (diff)
use a shared global for the MessageHandle
-rw-r--r--src/Propellor/Engine.hs3
-rw-r--r--src/Propellor/Message.hs69
-rw-r--r--src/Propellor/Property/Chroot.hs2
-rw-r--r--src/Propellor/Property/Docker.hs2
4 files changed, 36 insertions, 40 deletions
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index a811724a..f0bcdac8 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -38,8 +38,7 @@ mainProperties :: Host -> IO ()
mainProperties host = do
ret <- runPropellor host $
ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
- h <- mkMessageHandle
- whenConsole h $
+ whenConsole $
setTitle "propellor: done"
hFlush stdout
case ret of
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 94892da8..9c6cb57c 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -9,10 +9,11 @@ import System.Log.Formatter
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple
import "mtl" Control.Monad.Reader
-import Data.Maybe
import Control.Applicative
import System.Directory
import Control.Monad.IfElse
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Concurrent
import Propellor.Types
import Utility.Monad
@@ -20,27 +21,26 @@ import Utility.Env
import Utility.Process
import Utility.Exception
-data MessageHandle
- = ConsoleMessageHandle
- | TextMessageHandle
+data MessageHandle = MessageHandle
+ { isConsole :: Bool
+ }
-mkMessageHandle :: IO MessageHandle
-mkMessageHandle = do
- ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
- ( return ConsoleMessageHandle
- , return TextMessageHandle
- )
+-- | A shared global variable for the MessageHandle.
+{-# NOINLINE globalMessageHandle #-}
+globalMessageHandle :: MVar MessageHandle
+globalMessageHandle = unsafePerformIO $ do
+ c <- hIsTerminalDevice stdout
+ newMVar $ MessageHandle c
-forceConsole :: IO ()
-forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True
+getMessageHandle :: IO MessageHandle
+getMessageHandle = readMVar globalMessageHandle
-isConsole :: MessageHandle -> Bool
-isConsole ConsoleMessageHandle = True
-isConsole _ = False
+forceConsole :: IO ()
+forceConsole = modifyMVar_ globalMessageHandle $ \mh ->
+ pure (mh { isConsole = True })
-whenConsole :: MessageHandle -> IO () -> IO ()
-whenConsole ConsoleMessageHandle a = a
-whenConsole _ _ = return ()
+whenConsole :: IO () -> IO ()
+whenConsole a = whenM (isConsole <$> getMessageHandle) a
-- | Shows a message while performing an action, with a colored status
-- display.
@@ -54,49 +54,46 @@ actionMessageOn = actionMessage' . Just
actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' mhn desc a = do
- h <- liftIO mkMessageHandle
- liftIO $ whenConsole h $ do
+ liftIO $ whenConsole $ do
setTitle $ "propellor: " ++ desc
hFlush stdout
r <- a
liftIO $ do
- whenConsole h $
+ whenConsole $
setTitle "propellor: running"
- showhn h mhn
+ showhn mhn
putStr $ desc ++ " ... "
let (msg, intensity, color) = getActionResult r
- colorLine h intensity color msg
+ colorLine intensity color msg
hFlush stdout
return r
where
- showhn _ Nothing = return ()
- showhn h (Just hn) = do
- whenConsole h $
+ showhn Nothing = return ()
+ showhn (Just hn) = do
+ whenConsole $
setSGR [SetColor Foreground Dull Cyan]
putStr (hn ++ " ")
- whenConsole h $
+ whenConsole $
setSGR []
warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ do
- h <- mkMessageHandle
- colorLine h Vivid Magenta $ "** warning: " ++ s
+warningMessage s = liftIO $
+ colorLine Vivid Magenta $ "** warning: " ++ s
errorMessage :: MonadIO m => String -> m a
errorMessage s = liftIO $ do
- h <- mkMessageHandle
- colorLine h Vivid Red $ "** error: " ++ s
+ colorLine Vivid Red $ "** error: " ++ s
error "Cannot continue!"
-colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO ()
-colorLine h intensity color msg = do
- whenConsole h $
+colorLine :: ColorIntensity -> Color -> String -> IO ()
+colorLine intensity color msg = do
+ whenConsole $
setSGR [SetColor Foreground intensity color]
putStr msg
- whenConsole h $
+ whenConsole $
setSGR []
-- Note this comes after the color is reset, so that
-- the color set and reset happen in the same line.
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 20871a12..8b923aab 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -193,7 +193,7 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr
toChain :: HostName -> Chroot -> Bool -> IO CmdLine
toChain parenthost (Chroot loc _ _) systemdonly = do
- onconsole <- isConsole <$> mkMessageHandle
+ onconsole <- isConsole <$> getMessageHandle
return $ ChrootChain parenthost loc systemdonly onconsole
chain :: [Host] -> CmdLine -> IO ()
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 2b0e7e7e..5f41209a 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -555,7 +555,7 @@ provisionContainer :: ContainerId -> Property NoInfo
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
- msgh <- mkMessageHandle
+ msgh <- getMessageHandle
let p = inContainerProcess cid
(if isConsole msgh then ["-it"] else [])
(shim : params)