From ef7f2bb7fd6a79ee3e9d0abbaf6f002c146f3fbc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 29 Jul 2017 15:43:57 -0400 Subject: Added PROPELLOR_TRACE environment variable which can be set to 1 to make propellor output serialized Propellor.Message.Trace values, for consumption by another program. This commit was sponsored by Ewen McNeill. --- debian/changelog | 3 +++ src/Propellor/Message.hs | 31 ++++++++++++++++++++++++++++--- src/Propellor/Types/Result.hs | 3 +++ 3 files changed, 34 insertions(+), 3 deletions(-) diff --git a/debian/changelog b/debian/changelog index 99f12602..7645b371 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,8 @@ propellor (4.7.2) UNRELEASED; urgency=medium + * Added PROPELLOR_TRACE environment variable, which can be set to 1 to + make propellor output serialized Propellor.Message.Trace values, + for consumption by another program. * Rsync: Make rsync display its progress, in a minimal format to avoid scrolling each file down the screen. diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 7715088f..690056e4 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -5,6 +5,8 @@ -- the messages will be displayed sequentially. module Propellor.Message ( + Trace(..), + parseTrace, getMessageHandle, isConsole, forceConsole, @@ -21,6 +23,7 @@ module Propellor.Message ( import System.Console.ANSI import System.IO +import Control.Monad.IfElse import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -31,10 +34,25 @@ import Prelude import Propellor.Types import Propellor.Types.Exception import Utility.Monad +import Utility.Env import Utility.Exception +import Utility.PartialPrelude + +-- | Serializable tracing. Export `PROPELLOR_TRACE=1` in the environment to +-- make propellor emit these to stdout, in addition to its other output. +data Trace + = ActionStart (Maybe HostName) Desc + | ActionEnd Result + deriving (Read, Show) + +-- | Given a line read from propellor, if it's a serialized Trace, +-- parses it. +parseTrace :: String -> Maybe Trace +parseTrace = readish data MessageHandle = MessageHandle { isConsole :: Bool + , traceEnabled :: Bool } -- | A shared global variable for the MessageHandle. @@ -43,11 +61,16 @@ globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ newMVar =<< MessageHandle <$> catchDefaultIO False (hIsTerminalDevice stdout) + <*> ((== Just "1") <$> getEnv "PROPELLOR_TRACE") -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle +trace :: Trace -> IO () +trace t = whenM (traceEnabled <$> getMessageHandle) $ + putStrLn $ show t + -- | Force console output. This can be used when stdout is not directly -- connected to a console, but is eventually going to be displayed at a -- console. @@ -63,20 +86,22 @@ whenConsole s = ifM (isConsole <$> getMessageHandle) -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r +actionMessage :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing -- | Shows a message while performing an action on a specified host, -- with a colored status display. -actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' :: (MonadIO m, ActionResult r, ToResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do liftIO $ outputConcurrent =<< whenConsole (setTitleCode $ "propellor: " ++ desc) + liftIO $ trace $ ActionStart mhn desc r <- a + liftIO $ trace $ ActionEnd $ toResult r liftIO $ outputConcurrent . concat =<< sequence [ whenConsole $ diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs index e8510abf..5209094b 100644 --- a/src/Propellor/Types/Result.hs +++ b/src/Propellor/Types/Result.hs @@ -24,6 +24,9 @@ instance ToResult Bool where toResult False = FailedChange toResult True = MadeChange +instance ToResult Result where + toResult = id + -- | Results of actions, with color. class ActionResult a where getActionResult :: a -> (String, ColorIntensity, Color) -- cgit v1.2.3