summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog10
-rw-r--r--doc/news/version_4.6.0.mdwn8
-rw-r--r--doc/news/version_4.7.2.mdwn7
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Message.hs31
-rw-r--r--src/Propellor/Property/Rsync.hs2
-rw-r--r--src/Propellor/Types/Result.hs3
7 files changed, 50 insertions, 13 deletions
diff --git a/debian/changelog b/debian/changelog
index 3b02a00b..5c9cddd2 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,13 @@
+propellor (4.7.2) unstable; 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.
+
+ -- Joey Hess <id@joeyh.name> Sat, 29 Jul 2017 15:49:00 -0400
+
propellor (4.7.1) unstable; urgency=medium
* Added Mount.isMounted.
diff --git a/doc/news/version_4.6.0.mdwn b/doc/news/version_4.6.0.mdwn
deleted file mode 100644
index 673051ea..00000000
--- a/doc/news/version_4.6.0.mdwn
+++ /dev/null
@@ -1,8 +0,0 @@
-propellor 4.6.0 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Add Typeable instance to Bootstrapper, fixing build with old versions
- of ghc.
- * Network.static changed to take address and gateway parameters.
- If you used the old Network.static property, it has been renamed to
- Network.preserveStatic.
- (Minor API change)"""]] \ No newline at end of file
diff --git a/doc/news/version_4.7.2.mdwn b/doc/news/version_4.7.2.mdwn
new file mode 100644
index 00000000..a81220b7
--- /dev/null
+++ b/doc/news/version_4.7.2.mdwn
@@ -0,0 +1,7 @@
+propellor 4.7.2 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * 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."""]] \ No newline at end of file
diff --git a/propellor.cabal b/propellor.cabal
index b7668af5..0156734f 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 4.7.1
+Version: 4.7.2
Cabal-Version: >= 1.20
License: BSD2
Maintainer: Joey Hess <id@joeyh.name>
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/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index 5665ab91..c7ff3287 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -54,7 +54,7 @@ syncDirFiltered filters src dest = rsync $
, addTrailingPathSeparator dest
, "--delete"
, "--delete-excluded"
- , "--quiet"
+ , "--info=progress2"
] ++ map toRsync filters
rsync :: [String] -> Property (DebianLike + ArchLinux)
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)