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.

2 files changed, 31 insertions, 3 deletions

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)