From 21a74a3ffea3d48195d76486a56031b317fa23fa Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 11:44:05 -0400
Subject: propellor spin

---
 src/Propellor/Spin.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

(limited to 'src/Propellor/Spin.hs')

diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 0c457705..36859fb7 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -206,7 +206,10 @@ updateServer target relay hst connect haveprecompiled getprivdata =
 				sendRepoUrl toh
 				loop
 			(Just NeedPrivData) -> do
-				sendPrivData hn toh =<< getprivdata
+				print "START GET PRIVDATA"
+				pd <- getprivdata
+				print "GOT PRIVDATA"
+				sendPrivData hn toh pd
 				loop
 			(Just NeedGitClone) -> do
 				hClose toh
-- 
cgit v1.3-2-g0d8e


From 92cc0610586f0875286a945ea21477f0fc852f08 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 11:46:03 -0400
Subject: propellor spin

---
 src/Propellor/Spin.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'src/Propellor/Spin.hs')

diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 36859fb7..49d80460 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -15,6 +15,7 @@ import System.Posix.Directory
 import Control.Concurrent.Async
 import qualified Data.ByteString as B
 import qualified Data.Set as S
+import qualified Data.Map as M
 import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)
 
 import Propellor.Base
@@ -208,7 +209,7 @@ updateServer target relay hst connect haveprecompiled getprivdata =
 			(Just NeedPrivData) -> do
 				print "START GET PRIVDATA"
 				pd <- getprivdata
-				print "GOT PRIVDATA"
+				print ("GOT PRIVDATA", M.size pd)
 				sendPrivData hn toh pd
 				loop
 			(Just NeedGitClone) -> do
-- 
cgit v1.3-2-g0d8e


From 1f0e7001aafb91e7ed168505db1aa62a8b070234 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 11:47:39 -0400
Subject: propellor spin

---
 src/Propellor/Spin.hs | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'src/Propellor/Spin.hs')

diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 49d80460..ef3dc2d1 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -208,8 +208,10 @@ updateServer target relay hst connect haveprecompiled getprivdata =
 				loop
 			(Just NeedPrivData) -> do
 				print "START GET PRIVDATA"
+				hFlush stdout
 				pd <- getprivdata
 				print ("GOT PRIVDATA", M.size pd)
+				hFlush stdout
 				sendPrivData hn toh pd
 				loop
 			(Just NeedGitClone) -> do
-- 
cgit v1.3-2-g0d8e


From f935d1d667f78ba7d34e853346ab0a99b2c4ec14 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 11:49:12 -0400
Subject: remove debug

Found problem.. actionMessage is blocking.
---
 src/Propellor/Spin.hs | 8 +-------
 1 file changed, 1 insertion(+), 7 deletions(-)

(limited to 'src/Propellor/Spin.hs')

diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index ef3dc2d1..8a40fc87 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -15,7 +15,6 @@ import System.Posix.Directory
 import Control.Concurrent.Async
 import qualified Data.ByteString as B
 import qualified Data.Set as S
-import qualified Data.Map as M
 import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)
 
 import Propellor.Base
@@ -207,12 +206,7 @@ updateServer target relay hst connect haveprecompiled getprivdata =
 				sendRepoUrl toh
 				loop
 			(Just NeedPrivData) -> do
-				print "START GET PRIVDATA"
-				hFlush stdout
-				pd <- getprivdata
-				print ("GOT PRIVDATA", M.size pd)
-				hFlush stdout
-				sendPrivData hn toh pd
+				sendPrivData hn toh pd =<< getprivdata
 				loop
 			(Just NeedGitClone) -> do
 				hClose toh
-- 
cgit v1.3-2-g0d8e


From 7a83dab6e977f61b3348aaa9f70bd2a288b4b631 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 12:19:49 -0400
Subject: use outputConcurrent interface

This interface will fix the current deadlock when a process is running
and the thread that ran it wants to output to the console.

The locking and buffering is not implemented yet.
---
 src/Propellor/Message.hs        | 91 +++++++++++++++++++----------------------
 src/Propellor/Spin.hs           |  2 +-
 src/Utility/ConcurrentOutput.hs | 21 ++++++++--
 3 files changed, 61 insertions(+), 53 deletions(-)

(limited to 'src/Propellor/Spin.hs')

diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 3b06770c..6d541b9a 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -20,10 +20,8 @@ module Propellor.Message (
 
 import System.Console.ANSI
 import System.IO
-import Control.Monad
 import Control.Monad.IO.Class (liftIO, MonadIO)
 import Control.Applicative
-import Control.Monad.IfElse
 import System.IO.Unsafe (unsafePerformIO)
 import Control.Concurrent
 
@@ -55,10 +53,11 @@ 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
+whenConsole :: String -> IO String
+whenConsole s = ifM (isConsole <$> getMessageHandle)
+	( pure s
+	, pure ""
+	)
 
 -- | Shows a message while performing an action, with a colored status
 -- display.
@@ -72,55 +71,54 @@ actionMessageOn = actionMessage' . Just
 
 actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
 actionMessage' mhn desc a = do
-	liftIO $ whenConsole $ lockOutput $ do
-		setTitle $ "propellor: " ++ desc
-		hFlush stdout
+	liftIO $ outputConcurrent
+		=<< whenConsole (setTitleCode $ "propellor: " ++ desc)
 
 	r <- a
 
-	liftIO $ lockOutput $ do
-		whenConsole $
-			setTitle "propellor: running"
-		showhn mhn
-		putStr $ desc ++ " ... "
-		let (msg, intensity, color) = getActionResult r
-		colorLine intensity color msg
-		hFlush stdout
+	liftIO $ outputConcurrent . concat =<< sequence
+		[ whenConsole $
+			setTitleCode "propellor: running"
+		, showhn mhn
+		, pure $ desc ++ " ... "
+		, let (msg, intensity, color) = getActionResult r
+		  in colorLine intensity color msg
+		]
 
 	return r
   where
-	showhn Nothing = return ()
-	showhn (Just hn) = do
-		whenConsole $
-			setSGR [SetColor Foreground Dull Cyan]
-		putStr (hn ++ " ")
-		whenConsole $
-			setSGR []
+	showhn Nothing = return ""
+	showhn (Just hn) = concat <$> sequence
+		[ whenConsole $
+			setSGRCode [SetColor Foreground Dull Cyan]
+		, pure (hn ++ " ")
+		, whenConsole $
+			setSGRCode []
+		]
 
 warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ lockOutput $
-	colorLine Vivid Magenta $ "** warning: " ++ s
+warningMessage s = liftIO $
+	outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
 
 infoMessage :: MonadIO m => [String] -> m ()
-infoMessage ls = liftIO $ lockOutput $
-	mapM_ putStrLn ls
+infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
 
 errorMessage :: MonadIO m => String -> m a
-errorMessage s = liftIO $ lockOutput $ do
-	colorLine Vivid Red $ "** error: " ++ s
+errorMessage s = liftIO $ do
+	outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
 	error "Cannot continue!"
  
-colorLine :: ColorIntensity -> Color -> String -> IO ()
-colorLine intensity color msg = do
-	whenConsole $
-		setSGR [SetColor Foreground intensity color]
-	putStr msg
-	whenConsole $
-		setSGR []
+colorLine :: ColorIntensity -> Color -> String -> IO String
+colorLine intensity color msg = concat <$> sequence
+	[ whenConsole $
+		setSGRCode [SetColor Foreground intensity color]
+	, pure msg
+	, whenConsole $
+		setSGRCode []
 	-- Note this comes after the color is reset, so that
 	-- the color set and reset happen in the same line.
-	putStrLn ""
-	hFlush stdout
+	, pure "\n"
+	]
 
 -- | Reads and displays each line from the Handle, except for the last line
 -- which is a Result.
@@ -136,19 +134,14 @@ processChainOutput h = go Nothing
 				Just l -> case readish l of
 					Just r -> pure r
 					Nothing -> do
-						lockOutput $ do
-							putStrLn l
-							hFlush stdout
+						outputConcurrent l
 						return FailedChange
 			Just s -> do
-				lockOutput $ do
-					maybe noop (\l -> unless (null l) (putStrLn l)) lastline
-					hFlush stdout
+				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 = lockOutput $ do
-	whenConsole $
-		setTitle "propellor: done"
-	hFlush stdout
+messagesDone = outputConcurrent
+	=<< whenConsole (setTitleCode "propellor: done")
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 8a40fc87..0c457705 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -206,7 +206,7 @@ updateServer target relay hst connect haveprecompiled getprivdata =
 				sendRepoUrl toh
 				loop
 			(Just NeedPrivData) -> do
-				sendPrivData hn toh pd =<< getprivdata
+				sendPrivData hn toh =<< getprivdata
 				loop
 			(Just NeedGitClone) -> do
 				hClose toh
diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs
index 8a4bdcf2..0e9a59de 100644
--- a/src/Utility/ConcurrentOutput.hs
+++ b/src/Utility/ConcurrentOutput.hs
@@ -1,7 +1,7 @@
 -- | Concurrent output handling.
 
 module Utility.ConcurrentOutput (
-	lockOutput,
+	outputConcurrent,
 	createProcessConcurrent,
 ) where
 
@@ -113,6 +113,20 @@ updateOutputLocker l = do
 	putMVar lcker l
 	modifyMVar_ lcker (const $ return l)
 
+-- | Displays a string to stdout, and flush output so it's displayed.
+--
+-- Uses locking to ensure that the whole string is output atomically
+-- even when other threads are concurrently generating output.
+--
+-- When something else is writing to the console at the same time, this does
+-- not block. It buffers the string, so it will be displayed once the other
+-- writer is done.
+outputConcurrent :: String -> IO ()
+outputConcurrent s = do
+	putStr s
+	hFlush stdout
+	-- TODO
+
 -- | Wrapper around `System.Process.createProcess` that prevents 
 -- multiple processes that are running concurrently from writing
 -- to stdout/stderr at the same time.
@@ -124,8 +138,9 @@ updateOutputLocker l = do
 -- A process is allowed to write to stdout and stderr in the usual
 -- way, assuming it can successfully take the output lock.
 --
--- When the output lock is held (by another process or other caller of
--- `lockOutput`), the process is instead run with its stdout and stderr
+-- When the output lock is held (by another concurrent process,
+-- or because `outputConcurrent` is being called at the same time),
+-- the process is instead run with its stdout and stderr
 -- redirected to a buffer. The buffered output will be displayed as soon
 -- as the output lock becomes free.
 createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) 
-- 
cgit v1.3-2-g0d8e


From dba2e73aa7daede014969d6c4c159e86871d6b01 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 20:20:53 -0400
Subject: propellor spin

---
 src/Propellor/Spin.hs | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'src/Propellor/Spin.hs')

diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 0c457705..478d1517 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -29,6 +29,7 @@ import Propellor.Types.Info
 import qualified Propellor.Shim as Shim
 import Utility.FileMode
 import Utility.SafeCommand
+import Utility.ConcurrentOutput
 
 commitSpin :: IO ()
 commitSpin = do
@@ -63,6 +64,7 @@ spin' mprivdata relay target hst = do
 		getprivdata
 
 	-- And now we can run it.
+	flushConcurrentOutput
 	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
 		error "remote propellor failed"
   where
-- 
cgit v1.3-2-g0d8e