make Propellor.Message use lock to handle concurrent threads outputting messages

Not yet handled: Output from concurrent programs.

4 files changed, 99 insertions, 52 deletions

diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index f0bcdac8..36a05b28 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -9,14 +9,12 @@ module Propellor.Engine (
 	fromHost,
 	fromHost',
 	onlyProcess,
-	processChainOutput,
 ) where
 
 import System.Exit
 import System.IO
 import Data.Monoid
 import Control.Applicative
-import System.Console.ANSI
 import "mtl" Control.Monad.RWS.Strict
 import System.PosixCompat
 import System.Posix.IO
@@ -29,8 +27,6 @@ import Propellor.Exception
 import Propellor.Info
 import Propellor.Property
 import Utility.Exception
-import Utility.PartialPrelude
-import Utility.Monad
 
 -- | Gets the Properties of a Host, and ensures them all,
 -- with nice display of what's being done.
@@ -38,9 +34,7 @@ mainProperties :: Host -> IO ()
 mainProperties host = do
 	ret <- runPropellor host $
 		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
-        whenConsole $
-		setTitle "propellor: done"
-	hFlush stdout
+	messagesDone
 	case ret of
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
@@ -98,28 +92,3 @@ onlyProcess lockfile a = bracket lock unlock (const a)
 		return l
 	unlock = closeFd
 	alreadyrunning = error "Propellor is already running on this host!"
-
--- | Reads and displays each line from the Handle, except for the last line
--- which is a Result.
-processChainOutput :: Handle -> IO Result
-processChainOutput h = go Nothing
-  where
-	go lastline = do
-		v <- catchMaybeIO (hGetLine h)
-		debug ["read from chained propellor: ", show v]
-		case v of
-			Nothing -> case lastline of
-				Nothing -> do
-					debug ["chained propellor output nothing; assuming it failed"]
-					return FailedChange
-				Just l -> case readish l of
-					Just r -> pure r
-					Nothing -> do
-						debug ["chained propellor output did not end with a Result; assuming it failed"]
-						putStrLn l
-						hFlush stdout
-						return FailedChange
-			Just s -> do
-				maybe noop (\l -> unless (null l) (putStrLn l)) lastline
-				hFlush stdout
-				go (Just s)
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 9c6cb57c..0961a356 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -1,6 +1,26 @@
 {-# LANGUAGE PackageImports #-}
 
-module Propellor.Message where
+-- | This module handles all display of output to the console when
+-- propellor is ensuring Properties.
+--
+-- When two threads both try to display a message concurrently, 
+-- the messages will be displayed sequentially.
+
+module Propellor.Message (
+	getMessageHandle,
+	isConsole,
+	forceConsole,
+	actionMessage,
+	actionMessageOn,
+	warningMessage,
+	infoMessage,
+	errorMessage,
+	debug,
+	checkDebugMode,
+	enableDebugMode,
+	processChainOutput,
+	messagesDone,
+) where
 
 import System.Console.ANSI
 import System.IO
@@ -16,6 +36,7 @@ import System.IO.Unsafe (unsafePerformIO)
 import Control.Concurrent
 
 import Propellor.Types
+import Utility.PartialPrelude
 import Utility.Monad
 import Utility.Env
 import Utility.Process
@@ -23,6 +44,7 @@ import Utility.Exception
 
 data MessageHandle = MessageHandle
 	{ isConsole :: Bool
+	, outputLock :: MVar ()
 	}
 
 -- | A shared global variable for the MessageHandle.
@@ -30,30 +52,44 @@ data MessageHandle = MessageHandle
 globalMessageHandle :: MVar MessageHandle
 globalMessageHandle = unsafePerformIO $ do
 	c <- hIsTerminalDevice stdout
-	newMVar $ MessageHandle c
+	o <- newMVar ()
+	newMVar $ MessageHandle c o
 
+-- | Gets the global MessageHandle.
 getMessageHandle :: IO MessageHandle
 getMessageHandle = readMVar globalMessageHandle
 
+-- | Takes a lock while performing an action. Any other threads
+-- that try to lockOutput at the same time will block.
+lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
+lockOutput a = do
+	lck <- liftIO $ outputLock <$> getMessageHandle
+	bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) a
+
+-- | 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.
 forceConsole :: IO ()
 forceConsole = modifyMVar_ globalMessageHandle $ \mh ->
 	pure (mh { isConsole = True })
 
+-- | Only performs the action when at the console, or when console
+-- output has been forced.
 whenConsole :: IO () -> IO ()
 whenConsole a = whenM (isConsole <$> getMessageHandle) a
 
 -- | Shows a message while performing an action, with a colored status
 -- display.
-actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
+actionMessage :: (MonadIO m, MonadMask m, ActionResult 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, ActionResult r) => HostName -> Desc -> m r -> m r
+actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r
 actionMessageOn = actionMessage' . Just
 
-actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
-actionMessage' mhn desc a = do
+actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
+actionMessage' mhn desc a = lockOutput $ do
 	liftIO $ whenConsole $ do
 		setTitle $ "propellor: " ++ desc
 		hFlush stdout
@@ -80,14 +116,18 @@ actionMessage' mhn desc a = do
 			setSGR []
 
 warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $
+warningMessage s = liftIO $ lockOutput $
 	colorLine Vivid Magenta $ "** warning: " ++ s
 
+infoMessage :: MonadIO m => [String] -> m ()
+infoMessage ls = liftIO $ lockOutput $
+	mapM_ putStrLn ls
+
 errorMessage :: MonadIO m => String -> m a
-errorMessage s = liftIO $ do
+errorMessage s = liftIO $ lockOutput $ do
 	colorLine Vivid Red $ "** error: " ++ s
 	error "Cannot continue!"
-
+ 
 colorLine :: ColorIntensity -> Color -> String -> IO ()
 colorLine intensity color msg = do
 	whenConsole $
@@ -120,3 +160,37 @@ enableDebugMode = do
 		<*> pure (simpleLogFormatter "[$time] $msg")
 	updateGlobalLogger rootLoggerName $ 
 		setLevel DEBUG .  setHandlers [f]
+
+-- | Reads and displays each line from the Handle, except for the last line
+-- which is a Result.
+processChainOutput :: Handle -> IO Result
+processChainOutput h = go Nothing
+  where
+	go lastline = do
+		v <- catchMaybeIO (hGetLine h)
+		debug ["read from chained propellor: ", show v]
+		case v of
+			Nothing -> case lastline of
+				Nothing -> do
+					debug ["chained propellor output nothing; assuming it failed"]
+					return FailedChange
+				Just l -> case readish l of
+					Just r -> pure r
+					Nothing -> do
+						debug ["chained propellor output did not end with a Result; assuming it failed"]
+						lockOutput $ do
+							putStrLn l
+							hFlush stdout
+						return FailedChange
+			Just s -> do
+				lockOutput $ do
+					maybe noop (\l -> unless (null l) (putStrLn l)) lastline
+					hFlush stdout
+				go (Just s)
+
+-- | Called when all messages about properties have been printed.
+messagesDone :: IO ()
+messagesDone = lockOutput $ do
+	whenConsole $
+		setTitle "propellor: done"
+	hFlush stdout
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index aac37d14..e59f42c3 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -106,9 +106,9 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 	missing = do
 		Context cname <- mkHostContext hc <$> asks hostName
 		warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")"
-		liftIO $ putStrLn $ "Fix this by running:"
-		liftIO $ showSet $
-			map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
+		infoMessage $ 
+			"Fix this by running:" :
+			showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist)
 		return FailedChange
 	addinfo p = infoProperty
 		(propertyDesc p)
@@ -121,11 +121,14 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 	fieldlist = map privDataField srclist
 	hc = asHostContext c
 
-showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO ()
-showSet l = forM_ l $ \(f, Context c, md) -> do
-	putStrLn $ "  propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"
-	maybe noop (\d -> putStrLn $ "    " ++ d) md
-	putStrLn ""
+showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> [String]
+showSet = concatMap go
+  where
+	go (f, Context c, md) = catMaybes
+		[ Just $ "  propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"
+		, maybe Nothing (\d -> Just $ "    " ++ d) md
+		, Just ""
+		]
 
 addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
 addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v))
@@ -207,7 +210,8 @@ listPrivDataFields hosts = do
 		showtable $ map mkrow missing
 
 		section "How to set missing data:"
-		showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
+		mapM_ putStrLn $ showSet $
+			map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
   where
 	header = ["Field", "Context", "Used by"]
 	mkrow k@(field, Context context) =
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index c57f5228..645a5dfd 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
--- | Note that this module does not yet arrange for any output multiplexing,
--- so the output of concurrent properties will be scrambled together.
+-- | Note that any output of commands run by
+-- concurrent properties will be scrambled together.
 
 module Propellor.Property.Concurrent (
 	concurrently,