avoid buffering container chain output

When provisioning a container, output was buffered until the whole process
was done; now output will be displayed immediately.

I know this didn't used to be a problem. I belive it was introduced by
accident when propellor started using concurrent-output. I know I've seen
it for a while and never was bothered enough to get to the bottom of it;
apparently "a while" was longer than I thought.

Also refactored code to do with chain provisioning to all be in
Propellor.Engine and avoided some duplication.

This commit was sponsored by Anthony DeRobertis on Patreon.

4 files changed, 67 insertions, 40 deletions

diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 08f535e0..f54da929 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -8,6 +8,8 @@ module Propellor.Engine (
 	fromHost,
 	fromHost',
 	onlyProcess,
+	chainPropellor,
+	runChainPropellor,
 ) where
 
 import System.Exit
@@ -17,7 +19,9 @@ import "mtl" Control.Monad.RWS.Strict
 import System.PosixCompat
 import System.Posix.IO
 import System.FilePath
+import System.Console.Concurrent
 import Control.Applicative
+import Control.Concurrent.Async
 import Prelude
 
 import Propellor.Types
@@ -28,6 +32,8 @@ import Propellor.Exception
 import Propellor.Info
 import Utility.Exception
 import Utility.Directory
+import Utility.Process
+import Utility.PartialPrelude
 
 -- | Gets the Properties of a Host, and ensures them all,
 -- with nice display of what's being done.
@@ -96,3 +102,53 @@ onlyProcess lockfile a = bracket lock unlock (const a)
 		return l
 	unlock = closeFd
 	alreadyrunning = error "Propellor is already running on this host!"
+
+-- | Chains to a propellor sub-Process, forwarding its output on to the
+-- display, except for the last line which is a Result.
+chainPropellor :: CreateProcess -> IO Result
+chainPropellor p = 
+	-- We want to use outputConcurrent to display output
+	-- as it's received. If only stdout were captured,
+	-- concurrent-output would buffer all outputConcurrent.
+	-- Also capturing stderr avoids that problem.
+	withOEHandles createProcessSuccess p $ \(outh, errh) -> do
+		(r, ()) <- processChainOutput outh
+			`concurrently` forwardChainError errh
+		return r
+
+-- | 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)
+		case v of
+			Nothing -> case lastline of
+				Nothing -> do
+					return FailedChange
+				Just l -> case readish l of
+					Just r -> pure r
+					Nothing -> do
+						outputConcurrent (l ++ "\n")
+						return FailedChange
+			Just s -> do
+				outputConcurrent $
+					maybe "" (\l -> if null l then "" else l ++ "\n") lastline
+				go (Just s)
+
+forwardChainError :: Handle -> IO ()
+forwardChainError h = do
+	v <- catchMaybeIO (hGetLine h)
+	case v of
+		Nothing -> return ()
+		Just s -> do
+			errorConcurrent (s ++ "\n")
+			forwardChainError h
+
+-- | Used by propellor sub-Processes that are run by chainPropellor.
+runChainPropellor :: Host -> Propellor Result -> IO ()
+runChainPropellor h a = do
+	r <- runPropellor h a
+	flushConcurrentOutput
+	putStrLn $ "\n" ++ show r
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index c56f0c5a..7715088f 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -14,7 +14,6 @@ module Propellor.Message (
 	infoMessage,
 	errorMessage,
 	stopPropellorMessage,
-	processChainOutput,
 	messagesDone,
 	createProcessConcurrent,
 	withConcurrentOutput,
@@ -31,7 +30,6 @@ import Prelude
 
 import Propellor.Types
 import Propellor.Types.Exception
-import Utility.PartialPrelude
 import Utility.Monad
 import Utility.Exception
 
@@ -142,27 +140,6 @@ colorLine intensity color msg = concat <$> sequence
 	, pure "\n"
 	]
 
--- | 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)
-		case v of
-			Nothing -> case lastline of
-				Nothing -> do
-					return FailedChange
-				Just l -> case readish l of
-					Just r -> pure r
-					Nothing -> do
-						outputConcurrent (l ++ "\n")
-						return FailedChange
-			Just s -> do
-				outputConcurrent $
-					maybe "" (\l -> if null l then "" else l ++ "\n") lastline
-				go (Just s)
-
 -- | Called when all messages about properties have been printed.
 messagesDone :: IO ()
 messagesDone = outputConcurrent
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ad2ae705..65749e34 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -37,7 +37,6 @@ import Utility.Split
 
 import qualified Data.Map as M
 import System.Posix.Directory
-import System.Console.Concurrent
 
 -- | Specification of a chroot. Normally you'll use `debootstrapped` or
 -- `bootstrapped` to construct a Chroot value.
@@ -201,9 +200,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
 			, "--continue"
 			, show cmd
 			]
-		let p' = p { env = Just pe }
-		r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
-			processChainOutput
+		r <- liftIO $ chainPropellor (p { env = Just pe })
 		liftIO cleanup
 		return r
 
@@ -223,13 +220,12 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 	go h = do
 		changeWorkingDirectory localdir
 		when onconsole forceConsole
-		onlyProcess (provisioningLock loc) $ do
-			r <- runPropellor (setInChroot h) $ ensureChildProperties $
-				if systemdonly
-					then [toChildProperty Systemd.installed]
-					else hostProperties h
-			flushConcurrentOutput
-			putStrLn $ "\n" ++ show r
+		onlyProcess (provisioningLock loc) $
+			runChainPropellor (setInChroot h) $
+				ensureChildProperties $
+					if systemdonly
+						then [toChildProperty Systemd.installed]
+						else hostProperties h
 chain _ _ = errorMessage "bad chain command"
 
 inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index d53bab71..66418253 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -576,8 +576,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d
 	let p = inContainerProcess cid
 		(if isConsole msgh then ["-it"] else [])
 		(shim : params)
-	r <- withHandle StdoutHandle createProcessSuccess p $
-		processChainOutput
+	r <- chainPropellor p
 	when (r /= FailedChange) $
 		setProvisionedFlag cid
 	return r
@@ -596,10 +595,9 @@ chain hostlist hn s = case toContainerId s of
   where
 	go cid h = do
 		changeWorkingDirectory localdir
-		onlyProcess (provisioningLock cid) $ do
-			r <- runPropellor h $ ensureChildProperties $ hostProperties h
-			flushConcurrentOutput
-			putStrLn $ "\n" ++ show r
+		onlyProcess (provisioningLock cid) $
+			runChainPropellor h $ 
+				ensureChildProperties $ hostProperties h
 
 stopContainer :: ContainerId -> IO Bool
 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]