summaryrefslogtreecommitdiff
path: root/src/Propellor/Message.hs
diff options
context:
space:
mode:
authorJoey Hess2014-11-18 00:19:11 -0400
committerJoey Hess2014-11-18 00:19:11 -0400
commit82d50a57968c73adaa4feb1a245d93403c72ce09 (patch)
treed20f37fc3f9d9bbafda5ee743022af06be04a267 /src/Propellor/Message.hs
parentfcf4ad84646b6c215cd5bc9517aa890d60f65a44 (diff)
Avoid outputting color setting sequences when not run on a terminal.
Currently TERM is checked for every message. Could be memoized, but it would add complexity, and typical propellor output is not going to be more than a few hundred messages, and likely this will be swamped by the actual work.
Diffstat (limited to 'src/Propellor/Message.hs')
-rw-r--r--src/Propellor/Message.hs63
1 files changed, 45 insertions, 18 deletions
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index afbed1ca..99e9ba2c 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -6,8 +6,26 @@ import System.Console.ANSI
import System.IO
import System.Log.Logger
import "mtl" Control.Monad.Reader
+import Data.Maybe
+import Control.Applicative
import Propellor.Types
+import Utility.Env
+import Utility.Monad
+
+data MessageHandle
+ = ConsoleMessageHandle
+ | TextMessageHandle
+
+mkMessageHandle :: IO MessageHandle
+mkMessageHandle = ifM (isJust <$> getEnv "TERM")
+ ( return ConsoleMessageHandle
+ , return TextMessageHandle
+ )
+
+whenConsole :: MessageHandle -> IO () -> IO ()
+whenConsole ConsoleMessageHandle a = a
+whenConsole _ _ = return ()
-- | Shows a message while performing an action, with a colored status
-- display.
@@ -21,46 +39,55 @@ actionMessageOn = actionMessage' . Just
actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' mhn desc a = do
- liftIO $ do
+ h <- liftIO mkMessageHandle
+ liftIO $ whenConsole h $ do
setTitle $ "propellor: " ++ desc
hFlush stdout
r <- a
liftIO $ do
- setTitle "propellor: running"
- showhn mhn
+ whenConsole h $
+ setTitle "propellor: running"
+ showhn h mhn
putStr $ desc ++ " ... "
let (msg, intensity, color) = getActionResult r
- colorLine intensity color msg
+ colorLine h intensity color msg
hFlush stdout
return r
where
- showhn Nothing = return ()
- showhn (Just hn) = do
- setSGR [SetColor Foreground Dull Cyan]
+ showhn _ Nothing = return ()
+ showhn h (Just hn) = do
+ whenConsole h $
+ setSGR [SetColor Foreground Dull Cyan]
putStr (hn ++ " ")
- setSGR []
+ whenConsole h $
+ setSGR []
warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s
+warningMessage s = liftIO $ do
+ h <- mkMessageHandle
+ colorLine h Vivid Magenta $ "** warning: " ++ s
-colorLine :: ColorIntensity -> Color -> String -> IO ()
-colorLine intensity color msg = do
- setSGR [SetColor Foreground intensity color]
+errorMessage :: MonadIO m => String -> m a
+errorMessage s = liftIO $ do
+ h <- mkMessageHandle
+ colorLine h Vivid Red $ "** error: " ++ s
+ error "Cannot continue!"
+
+colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO ()
+colorLine h intensity color msg = do
+ whenConsole h $
+ setSGR [SetColor Foreground intensity color]
putStr msg
- setSGR []
+ whenConsole h $
+ setSGR []
-- Note this comes after the color is reset, so that
-- the color set and reset happen in the same line.
putStrLn ""
hFlush stdout
-errorMessage :: String -> IO a
-errorMessage s = do
- liftIO $ colorLine Vivid Red $ "** error: " ++ s
- error "Cannot continue!"
-
-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
debug :: [String] -> IO ()
debug = debugM "propellor" . unwords