From d6700721c079888e95b5936b1c810744a3c60d3d Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 15 Mar 2018 15:34:25 -0400
Subject: [PATCH] simplify with async

This is much clearer to follow.

I've tested this, and it still has the problem described in
doc/bugs/occasional_hang_with_p2pstdio.mdwn

Which I think indicates that problem is not with my code, but something
else. ghc runtime? Something crazy ssh does in this situation? Unsure..
---
 Utility/Process/Transcript.hs | 28 ++++++++--------------------
 1 file changed, 8 insertions(+), 20 deletions(-)

diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs
index 5379ea8bb2..88a0a77638 100644
--- a/Utility/Process/Transcript.hs
+++ b/Utility/Process/Transcript.hs
@@ -11,11 +11,11 @@
 module Utility.Process.Transcript where
 
 import Utility.Process
+import Utility.Misc
 
 import System.IO
 import System.Exit
-import Control.Concurrent
-import qualified Control.Exception as E
+import Control.Concurrent.Async
 import Control.Monad
 #ifndef mingw32_HOST_OS
 import qualified System.Posix.IO
@@ -51,9 +51,9 @@ processTranscript'' cp input = do
 		}
 	hClose writeh
 
-	get <- mkreader readh
+	get <- asyncreader readh
 	writeinput input p
-	transcript <- get
+	transcript <- wait get
 #else
 {- This implementation for Windows puts stderr after stdout. -}
 	p@(_, _, _, pid) <- createProcess $ cp
@@ -62,27 +62,15 @@ processTranscript'' cp input = do
 		, std_err = CreatePipe
 		}
 
-	getout <- mkreader (stdoutHandle p)
-	geterr <- mkreader (stderrHandle p)
+	getout <- asyncreader (stdoutHandle p)
+	geterr <- asyncreader (stderrHandle p)
 	writeinput input p
-	transcript <- (++) <$> getout <*> geterr
+	transcript <- (++) <$> wait getout <*> wait geterr
 #endif
 	code <- waitForProcess pid
 	return (transcript, code)
   where
-	mkreader h = do
-		-- Start consuming the output immediately, because the
-		-- process may block on reading input until some
-		-- of its output is consumed.
-		s <- hGetContents h
-		v <- newEmptyMVar
-		void $ forkIO $ do
-			-- Wait for output to be fully consumed.
-			void $ E.evaluate (length s)
-			putMVar v ()
-		return $ do
-			takeMVar v
-			return s
+	asyncreader = async . hGetContentsStrict
 
 	writeinput (Just s) p = do
 		let inh = stdinHandle p