summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2017-07-29 15:43:57 -0400
committerJoey Hess2017-07-29 15:43:57 -0400
commitef7f2bb7fd6a79ee3e9d0abbaf6f002c146f3fbc (patch)
tree8f3c9310e2a7d6af206704b77b0e4c40cec31d6e
parent0946286c8afa9ed140b5636f87fdf5d9530fb954 (diff)
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.
-rw-r--r--debian/changelog3
-rw-r--r--src/Propellor/Message.hs31
-rw-r--r--src/Propellor/Types/Result.hs3
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)