From ff0927bde98e7b7fd4a7ef49b61b8770c6df294d Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 19 Nov 2020 16:21:17 -0400
Subject: [PATCH] converted reads from stderr to use hGetLineUntilExitOrEOF

These are all unlikely to suffer from the inherited stderr fd problem,
but who knows, it could happen.
---
 Annex/YoutubeDl.hs       | 11 +++++++----
 Git/Fsck.hs              | 14 +++++++++-----
 Utility/MagicWormhole.hs | 17 +++++++++++------
 3 files changed, 27 insertions(+), 15 deletions(-)

diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs
index 03e7562f58..f025adfa94 100644
--- a/Annex/YoutubeDl.hs
+++ b/Annex/YoutubeDl.hs
@@ -225,16 +225,19 @@ youtubeDlFileNameHtmlOnly' url uo
 		liftIO $ withCreateProcess p waitproc
 	
 	waitproc Nothing (Just o) (Just e) pid = do
-		output <- fmap fst $ 
-			hGetContentsStrict o
-				`concurrently`
-			hGetContentsStrict e
+		errt <- async $ discardstderr pid e
+		output <- hGetContentsStrict o
 		ok <- liftIO $ checkSuccessProcess pid
+		wait errt
 		return $ case (ok, lines output) of
 			(True, (f:_)) | not (null f) -> Right f
 			_ -> nomedia
 	waitproc _ _ _ _ = error "internal"
 
+	discardstderr pid e = hGetLineUntilExitOrEOF pid e >>= \case
+		Nothing -> return ()
+		Just _ -> discardstderr pid e
+
 	nomedia = Left "no media in url"
 
 youtubeDlOpts :: [CommandParam] -> Annex [CommandParam]
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 5206b35888..7440b92272 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -85,8 +85,8 @@ findBroken batchmode r = do
   where
 	go _ (Just outh) (Just errh) pid = do
 		(o1, o2) <- concurrently
-			(parseFsckOutput maxobjs r outh)
-			(parseFsckOutput maxobjs r errh)
+			(parseFsckOutput maxobjs r outh pid)
+			(parseFsckOutput maxobjs r errh pid)
 		fsckok <- checkSuccessProcess pid
 		case mappend o1 o2 of
 			FsckOutput badobjs truncated
@@ -121,9 +121,9 @@ knownMissing (FsckFoundMissing s _) = s
 findMissing :: [Sha] -> Repo -> IO MissingObjects
 findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
 
-parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput
-parseFsckOutput maxobjs r h = do
-	ls <- lines <$> hGetContents h
+parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput
+parseFsckOutput maxobjs r h pid = do
+	ls <- getlines []
 	if null ls
 		then return NoFsckOutput
 		else if all ("duplicateEntries" `isInfixOf`) ls
@@ -133,6 +133,10 @@ parseFsckOutput maxobjs r h = do
 				let !truncated = length shas > maxobjs
 				missingobjs <- findMissing (take maxobjs shas) r
 				return $ FsckOutput missingobjs truncated
+  where
+	getlines c = hGetLineUntilExitOrEOF pid h >>= \case
+		Nothing -> return (reverse c)
+		Just l -> getlines (l:c)
 
 isMissing :: Sha -> Repo -> IO Bool
 isMissing s r = either (const True) (const False) <$> tryIO dump
diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs
index 4e7b49c7cc..b76bb3a568 100644
--- a/Utility/MagicWormhole.hs
+++ b/Utility/MagicWormhole.hs
@@ -113,23 +113,28 @@ sendFile f (CodeObserver observer) ps = do
 	-- Work around stupid stdout buffering behavior of python.
 	-- See https://github.com/warner/magic-wormhole/issues/108
 	environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment
-	runWormHoleProcess p { env = Just environ} $ \_hin hout herr -> do
-		(inout, inerr) <- findcode hout `concurrently` findcode herr
+	runWormHoleProcess p { env = Just environ} $ \_hin hout herr ph -> do
+ 		(inout, inerr) <- concurrently
+			(findcode ph hout)
+			(findcode ph herr)
 		return (inout || inerr)
   where
 	p = wormHoleProcess (Param "send" : ps ++ [File f])
-	findcode h = findcode' =<< words <$> hGetContents h
+	findcode ph h = findcode' =<< getwords ph h []
 	findcode' [] = return False
 	findcode' (w:ws) = case mkCode w of
 		Just code -> do
 			_ <- tryPutMVar observer code
 			return True
 		Nothing -> findcode' ws
+	getwords ph h c = hGetLineUntilExitOrEOF ph h >>= \case
+		Nothing -> return $ concatMap words $ reverse c
+		Just l -> getwords ph h (l:c)
 
 -- | Receives a file. Once the receive is under way, the Code will be
 -- read from the CodeProducer, and fed to wormhole on stdin.
 receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool
-receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr -> do
+receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr _ph -> do
 	Code c <- readMVar producer
 	hPutStrLn hin c
 	hFlush hin
@@ -145,7 +150,7 @@ receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _he
 wormHoleProcess :: WormHoleParams -> CreateProcess
 wormHoleProcess = proc "wormhole" . toCommand
 
-runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> IO Bool) ->  IO Bool
+runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> ProcessHandle -> IO Bool) ->  IO Bool
 runWormHoleProcess p consumer =
 	withCreateProcess p' go `catchNonAsync` const (return False)
   where
@@ -155,7 +160,7 @@ runWormHoleProcess p consumer =
 		, std_err = CreatePipe
 		}
 	go (Just hin) (Just hout) (Just herr) pid =
-		consumer hin hout herr <&&> waitbool pid
+		consumer hin hout herr pid <&&> waitbool pid
 	go _ _ _ _ = error "internal"
 	waitbool pid = do
 		r <- waitForProcess pid