From aafae46bcbb2a9533364b65be5fc05b379898aa1 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 17 Nov 2020 17:31:08 -0400
Subject: [PATCH 1/9] WIP

for https://git-annex.branchable.com/bugs/Buggy_external_special_remote_stalls_after_7245a9e/
---
 Annex/ExternalAddonProcess.hs |  2 +-
 Messages/Progress.hs          |  4 +--
 Utility/Metered.hs            | 60 +++++++++++++++--------------------
 Utility/Process.hs            | 60 +++++++++++++++++++++++++++++++++++
 4 files changed, 88 insertions(+), 38 deletions(-)

diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs
index 8a6c6c32fd..40908ccab0 100644
--- a/Annex/ExternalAddonProcess.hs
+++ b/Annex/ExternalAddonProcess.hs
@@ -53,7 +53,7 @@ startExternalAddonProcess basecmd pid = do
 			Left _ -> runerr cmdpath
 	
 	started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do
-		stderrelay <- async $ errrelayer herr
+		stderrelay <- async $ errrelayer ph herr
 		let shutdown forcestop = do
 			-- Close the process's stdin, to let it know there
 			-- are no more requests, so it will exit.
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index f0d4455228..a8588614c2 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -140,11 +140,11 @@ mkOutputHandlerQuiet = OutputHandler
 	<$> pure True
 	<*> mkStderrEmitter
 
-mkStderrRelayer :: Annex (Handle -> IO ())
+mkStderrRelayer :: Annex (ProcessHandle -> Handle -> IO ())
 mkStderrRelayer = do
 	quiet <- commandProgressDisabled
 	emitter <- mkStderrEmitter
-	return $ \h -> avoidProgress quiet h emitter
+	return $ \ph h -> avoidProgress quiet ph h emitter
 
 {- Generates an IO action that can be used to emit stderr.
  -
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index 8bdedf2b59..d39e39bfaf 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -49,7 +49,6 @@ import Common
 import Utility.Percentage
 import Utility.DataUnits
 import Utility.HumanTime
-import Utility.ThreadScheduler
 import Utility.SimpleProtocol as Proto
 
 import qualified Data.ByteString.Lazy as L
@@ -266,7 +265,7 @@ commandMeterExitCode progressparser oh meter meterupdate cmd params =
 commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode)
 commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = 
 	outputFilter cmd params mkprocess Nothing
-		(feedprogress mmeter zeroBytesProcessed [])
+		(const $ feedprogress mmeter zeroBytesProcessed [])
 		handlestderr
   where
 	feedprogress sendtotalsize prev buf h = do
@@ -291,9 +290,12 @@ commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess
 							meterupdate bytes
 						feedprogress sendtotalsize' bytes buf' h
 
-	handlestderr h = unlessM (hIsEOF h) $ do
-		stderrHandler oh =<< hGetLine h
-		handlestderr h
+	handlestderr ph h = unlessM (hIsEOF h) $ do
+		cancelOnExit ph (hGetLine h) >>= \case
+			Just l -> do
+				stderrHandler oh l
+				handlestderr ph h
+			Nothing -> return ()
 
 {- Runs a command, that may display one or more progress meters on
  - either stdout or stderr, and prevents the meters from being displayed.
@@ -306,8 +308,8 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing
 demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
 demeterCommandEnv oh cmd params environ = do
 	ret <- outputFilter cmd params id environ
-		(\outh -> avoidProgress True outh stdouthandler)
-		(\errh -> avoidProgress True errh $ stderrHandler oh)
+		(\ph outh -> avoidProgress True ph outh stdouthandler)
+		(\ph errh -> avoidProgress True ph errh $ stderrHandler oh)
 	return $ case ret of
 		Just ExitSuccess -> True
 		_ -> False
@@ -320,44 +322,32 @@ demeterCommandEnv oh cmd params environ = do
  - filter out lines that contain \r (typically used to reset to the
  - beginning of the line when updating a progress display).
  -}
-avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO ()
-avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do
-	s <- hGetLine h
-	unless (doavoid && '\r' `elem` s) $
-		emitter s
-	avoidProgress doavoid h emitter
+avoidProgress :: Bool -> ProcessHandle -> Handle -> (String -> IO ()) -> IO ()
+avoidProgress doavoid ph h emitter = unlessM (hIsEOF h) $
+	cancelOnExit ph (hGetLine h) >>= \case
+		Just s -> do
+			unless (doavoid && '\r' `elem` s) $
+				emitter s
+			avoidProgress doavoid ph h emitter
+		Nothing -> return ()
 
 outputFilter
 	:: FilePath
 	-> [CommandParam]
 	-> (CreateProcess -> CreateProcess)
 	-> Maybe [(String, String)]
-	-> (Handle -> IO ())
-	-> (Handle -> IO ())
+	-> (ProcessHandle -> Handle -> IO ())
+	-> (ProcessHandle -> Handle -> IO ())
 	-> IO (Maybe ExitCode)
 outputFilter cmd params mkprocess environ outfilter errfilter = 
 	catchMaybeIO $ withCreateProcess p go
   where
-	go _ (Just outh) (Just errh) pid = do
-		outt <- async $ tryIO (outfilter outh) >> hClose outh
-		errt <- async $ tryIO (errfilter errh) >> hClose errh
-		ret <- waitForProcess pid
-
-		-- Normally, now that the process has exited, the threads
-		-- will finish processing its output and terminate.
-		-- But, just in case the process did something evil like
-		-- forking to the background while inheriting stderr,
-		-- it's possible that the threads will not finish, which
-		-- would result in a deadlock. So, wait a few seconds
-		-- maximum for them to finish and then cancel them.
-		-- (One program that has behaved this way in the past is
-		-- openssh.)
-		void $ tryNonAsync $ race_
-			(wait outt >> wait errt)
-			(threadDelaySeconds (Seconds 2))
-		cancel outt
-		cancel errt
-
+	go _ (Just outh) (Just errh) ph = do
+		outt <- async $ tryIO (outfilter ph outh) >> hClose outh
+		errt <- async $ tryIO (errfilter ph errh) >> hClose errh
+		ret <- waitForProcess ph
+		wait outt
+		wait errt
 		return ret
 	go _ _ _ _ = error "internal"
 	
diff --git a/Utility/Process.hs b/Utility/Process.hs
index f535d6b2fb..319bc54523 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -24,6 +24,7 @@ module Utility.Process (
 	withCreateProcess,
 	waitForProcess,
 	cleanupProcess,
+	cancelOnExit,
 	startInteractiveProcess,
 	stdinHandle,
 	stdoutHandle,
@@ -42,8 +43,10 @@ import System.Exit
 import System.IO
 import System.Log.Logger
 import Control.Monad.IO.Class
+import Control.Concurrent
 import Control.Concurrent.Async
 import qualified Data.ByteString as S
+import GHC.IO.Handle (hWaitForInput)
 
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
 	deriving (Eq)
@@ -229,3 +232,60 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
 	maybe (return ()) hClose mb_stderr
 	void $ waitForProcess pid
 #endif
+
+{- | Like hGetLine, reads a line from the Handle. If the Handle is already
+ - closed, returns Nothing. If the process exits without writing a line,
+ - also returns Nothing.
+ -
+ - This is useful to protect against situations where the process might
+ - have transferred the handle being read to another process, and so
+ - the handle could remain open after the process has exited. That is a rare
+ - situation, but can happen. Consider a the process that started up a
+ - daemon, and the daemon inherited stderr from it, rather than the more
+ - usual behavior of closing the file descriptor. Reading from stderr
+ - would block past the exit of the process.
+ -
+ - In that situation, this will detect when the process has exited,
+ - and avoid blocking forever. But will still return anything the process
+ - buffered to the handle before exiting.
+ -}
+hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
+hGetLineUntilExitOrEOF ph h = either Just id <$> (reader `race` waiter)
+  where
+	reader = hGetLine isEOF h >>= \case
+		True -> return Nothing
+		False -> Just <$> hGetLine h
+
+	waiter = do
+		smalldelay
+		_ <- waitForProcess ph
+		waiter'
+		-- Reached the end of the processes output.
+		hClose h
+
+	waiter' = isanythingbuffered >>= \case
+		True -> do
+			-- Waiting for the reader to consume
+			-- buffered output after the process has
+			-- exited.
+			threadDelay 10000 -- 1/100th second
+			waiter'
+		False ->  return ()
+
+	isanythingbuffered = 
+		-- waitForInput is documented to throw an encoding
+		-- error in some cases, if the Handle has buffered on it
+		-- something that cannot be decoded. If it does,
+		-- that does imply there's still something buffered though.
+		catchNonAsync
+			(const (return True))
+			-- waitForInput can throw an EOF error
+			(catchIOErrorType EOF
+				(const (return False))
+				(hWaitForInput h 0))
+
+
+	-- A small delay avoids starting the work of waitForProcess
+	-- unncessarily in the common case where hGetLine gets a buffered
+	-- line immediately.
+	smalldelay = threadDelay 10000 -- 1/100th second

From 9af0000e0ff28c8eaae0ee1ce6838063d0a5ebef Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 12:23:15 -0400
Subject: [PATCH 2/9] bench test for hGetLineUntilExitOrEOF

This seems to show that hWaitForInput does not seem to behave as
documented. It does not time out, so blocks forever in this situation.
This is with a 0 timeout and with larger timeouts. Unsure why, it looked
like it should work.
---
 Utility/Process.hs | 40 ++++++++++++++++++++++++++++------------
 bench              |  5 +++++
 test.hs            | 19 +++++++++++++++++++
 3 files changed, 52 insertions(+), 12 deletions(-)
 create mode 100755 bench
 create mode 100644 test.hs

diff --git a/Utility/Process.hs b/Utility/Process.hs
index 319bc54523..b862307811 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -6,7 +6,7 @@
  - License: BSD-2-clause
  -}
 
-{-# LANGUAGE CPP, Rank2Types #-}
+{-# LANGUAGE CPP, Rank2Types, LambdaCase #-}
 {-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Process (
@@ -24,7 +24,7 @@ module Utility.Process (
 	withCreateProcess,
 	waitForProcess,
 	cleanupProcess,
-	cancelOnExit,
+	hGetLineUntilExitOrEOF,
 	startInteractiveProcess,
 	stdinHandle,
 	stdoutHandle,
@@ -250,40 +250,56 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
  - buffered to the handle before exiting.
  -}
 hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
-hGetLineUntilExitOrEOF ph h = either Just id <$> (reader `race` waiter)
+hGetLineUntilExitOrEOF ph h = do
+	w <- async waiter
+	r <- reader
+	cancel w
+	return r
   where
-	reader = hGetLine isEOF h >>= \case
+	reader = hIsEOF h >>= \case
 		True -> return Nothing
 		False -> Just <$> hGetLine h
 
 	waiter = do
 		smalldelay
+		print "hGetLineUntilExitOrEOF waitForProcess"
+		hFlush stdout
 		_ <- waitForProcess ph
-		waiter'
+		print "hGetLineUntilExitOrEOF process done"
+		hFlush stdout
+		waitbufferempty
+		print "hGetLineUntilExitOrEOF buffer empty"
+		hFlush stdout
 		-- Reached the end of the processes output.
 		hClose h
 
-	waiter' = isanythingbuffered >>= \case
+	waitbufferempty = isanythingbuffered >>= \case
 		True -> do
+			print "something still buffered.."
 			-- Waiting for the reader to consume
 			-- buffered output after the process has
 			-- exited.
 			threadDelay 10000 -- 1/100th second
-			waiter'
+			waitbufferempty
 		False ->  return ()
 
-	isanythingbuffered = 
+	isanythingbuffered = do
+		print "hWaitForInput call start"
 		-- waitForInput is documented to throw an encoding
 		-- error in some cases, if the Handle has buffered on it
 		-- something that cannot be decoded. If it does,
 		-- that does imply there's still something buffered though.
+		r <- hWaitForInput h 100
+		{-
 		catchNonAsync
-			(const (return True))
 			-- waitForInput can throw an EOF error
 			(catchIOErrorType EOF
-				(const (return False))
-				(hWaitForInput h 0))
-
+				(const (print "EOF exception" >> return False))
+				(hWaitForInput h 1))
+			(const (print "encoding exception" >> return True))
+		-}
+		print "hWaitForInput call done"
+		return r
 
 	-- A small delay avoids starting the work of waitForProcess
 	-- unncessarily in the common case where hGetLine gets a buffered
diff --git a/bench b/bench
new file mode 100755
index 0000000000..52e2d78116
--- /dev/null
+++ b/bench
@@ -0,0 +1,5 @@
+#!/bin/sh
+ssh -fN -o ControlMaster=auto -o ControlPersist=15m -o ControlPath=./socket localhost
+echo foo >&2
+sleep 2
+perl -e 'print STDERR "blah\n" for 1..100; print STDERR "final\n"'
diff --git a/test.hs b/test.hs
new file mode 100644
index 0000000000..188f92a333
--- /dev/null
+++ b/test.hs
@@ -0,0 +1,19 @@
+import Utility.Process
+import Data.Maybe
+import System.IO
+import Control.Concurrent.Async
+
+main = do
+	(Nothing, Nothing, Just h, p) <- createProcess $ (proc "./bench" [])
+		{ std_err = CreatePipe }
+	t <- async $ go h p
+	exitcode <- waitForProcess p
+	print ("process exited", exitcode)
+	wait t
+  where
+	go h p = do
+		l <- hGetLineUntilExitOrEOF p h
+		print ("got line", l)
+		if isJust l
+			then go h p
+			else print "at EOF"

From 787b39c7c14d1e8edb69040e88ee4c80e1b5d491 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 14:21:47 -0400
Subject: [PATCH 3/9] working hGetLineUntilExitOrEOF

The problem with the old version seemed to be that hWaitForInput blocks
rather than timing out when being run concurrently with hGetLine on the
same handle.

This passes the bench test, and also works when run concurrently on
different handles.
---
 Utility/Process.hs | 99 +++++++++++++++++++++++-----------------------
 1 file changed, 49 insertions(+), 50 deletions(-)

diff --git a/Utility/Process.hs b/Utility/Process.hs
index b862307811..a7e1b12f7c 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -250,58 +250,57 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
  - buffered to the handle before exiting.
  -}
 hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
-hGetLineUntilExitOrEOF ph h = do
-	w <- async waiter
-	r <- reader
-	cancel w
-	return r
+hGetLineUntilExitOrEOF ph h = go []
   where
-	reader = hIsEOF h >>= \case
-		True -> return Nothing
-		False -> Just <$> hGetLine h
+	go buf = do
+		ready <- waitforinputorerror smalldelay
+		if ready
+			then getloop buf go
+			else getProcessExitCode ph >>= \case
+				-- Process still running, wait longer.
+				Nothing -> go buf
+				-- Process is done. It's possible
+				-- that it output something and exited
+				-- since the prior hWaitForInput,
+				-- so check one more time for any buffered
+				-- output.
+				Just _ -> finalcheck buf
 
-	waiter = do
-		smalldelay
-		print "hGetLineUntilExitOrEOF waitForProcess"
-		hFlush stdout
-		_ <- waitForProcess ph
-		print "hGetLineUntilExitOrEOF process done"
-		hFlush stdout
-		waitbufferempty
-		print "hGetLineUntilExitOrEOF buffer empty"
-		hFlush stdout
-		-- Reached the end of the processes output.
-		hClose h
+	finalcheck buf = do
+		ready <- hWaitForInput h 0
+		if ready
+			then getloop buf finalcheck
+			-- No remaining buffered input, though the handle
+			-- may not be EOF if something else is keeping it
+			-- open. Treated the same as EOF.
+			else eofwithnolineend buf
 
-	waitbufferempty = isanythingbuffered >>= \case
-		True -> do
-			print "something still buffered.."
-			-- Waiting for the reader to consume
-			-- buffered output after the process has
-			-- exited.
-			threadDelay 10000 -- 1/100th second
-			waitbufferempty
-		False ->  return ()
+	-- On exception, proceed as if there was input;
+	-- EOF and any encoding issues are dealt with
+	-- when reading from the handle.
+	waitforinputorerror t = hWaitForInput h t
+		`catchNonAsync` const (pure True)
 
-	isanythingbuffered = do
-		print "hWaitForInput call start"
-		-- waitForInput is documented to throw an encoding
-		-- error in some cases, if the Handle has buffered on it
-		-- something that cannot be decoded. If it does,
-		-- that does imply there's still something buffered though.
-		r <- hWaitForInput h 100
-		{-
-		catchNonAsync
-			-- waitForInput can throw an EOF error
-			(catchIOErrorType EOF
-				(const (print "EOF exception" >> return False))
-				(hWaitForInput h 1))
-			(const (print "encoding exception" >> return True))
-		-}
-		print "hWaitForInput call done"
-		return r
+	getchar = catchIOErrorType EOF 
+		(const (pure Nothing)) 
+		(Just <$> hGetChar h)
 
-	-- A small delay avoids starting the work of waitForProcess
-	-- unncessarily in the common case where hGetLine gets a buffered
-	-- line immediately.
-	smalldelay = threadDelay 10000 -- 1/100th second
+	getloop buf cont =
+		getchar >>= \case
+			Just c
+				| c == '\n' -> return (Just (reverse buf))
+				| otherwise -> cont (c:buf)
+			Nothing -> eofwithnolineend buf
+
+	eofwithnolineend buf = return $
+		if null buf 
+			then Nothing -- no line read
+			else Just (reverse buf)
+
+	-- Tenth of a second delay. If the process exits with the FD being
+	-- held open, will wait up to twice this long before returning.
+	-- This delay could be made smaller. However, that is an unusual
+	-- case, and making it too small would cause lots of wakeups while
+	-- waiting for output. Bearing in mind that this could be run on
+	-- many processes at the same time.
+	smalldelay = 100 -- milliseconds

From b483be854817a379043d2926afd89faa7af0d8ef Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 14:48:50 -0400
Subject: [PATCH 4/9] newline mode (mis)handling for windows

Unfortunately, there is no hGetNewLineMode. This seems like an oversight
that should be fixed in ghc, but for now, I paper over it with a windows
hack.
---
 Utility/Process.hs | 16 +++++++++++++---
 bench              |  3 ---
 test.hs            | 14 +++++++++-----
 3 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/Utility/Process.hs b/Utility/Process.hs
index a7e1b12f7c..7552264710 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -43,10 +43,8 @@ import System.Exit
 import System.IO
 import System.Log.Logger
 import Control.Monad.IO.Class
-import Control.Concurrent
 import Control.Concurrent.Async
 import qualified Data.ByteString as S
-import GHC.IO.Handle (hWaitForInput)
 
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
 	deriving (Eq)
@@ -248,6 +246,11 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
  - In that situation, this will detect when the process has exited,
  - and avoid blocking forever. But will still return anything the process
  - buffered to the handle before exiting.
+ -
+ - Note on newline mode: This ignores whatever newline mode is configured
+ - for the handle, because there is no way to query that. On Windows,
+ - it will remove any \r coming before the \n. On other platforms,
+ - it does not treat \r specially.
  -}
 hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
 hGetLineUntilExitOrEOF ph h = go []
@@ -288,10 +291,17 @@ hGetLineUntilExitOrEOF ph h = go []
 	getloop buf cont =
 		getchar >>= \case
 			Just c
-				| c == '\n' -> return (Just (reverse buf))
+				| c == '\n' -> return (Just (gotline buf))
 				| otherwise -> cont (c:buf)
 			Nothing -> eofwithnolineend buf
 
+#ifndef mingw32_HOST_OS
+	gotline buf = reverse buf
+#else
+	gotline ('\r':buf) = reverse buf
+	gotline buf = reverse buf
+#endif
+
 	eofwithnolineend buf = return $
 		if null buf 
 			then Nothing -- no line read
diff --git a/bench b/bench
index 52e2d78116..98f1e9eda5 100755
--- a/bench
+++ b/bench
@@ -1,5 +1,2 @@
 #!/bin/sh
-ssh -fN -o ControlMaster=auto -o ControlPersist=15m -o ControlPath=./socket localhost
-echo foo >&2
-sleep 2
 perl -e 'print STDERR "blah\n" for 1..100; print STDERR "final\n"'
diff --git a/test.hs b/test.hs
index 188f92a333..9bda99a1c7 100644
--- a/test.hs
+++ b/test.hs
@@ -6,14 +6,18 @@ import Control.Concurrent.Async
 main = do
 	(Nothing, Nothing, Just h, p) <- createProcess $ (proc "./bench" [])
 		{ std_err = CreatePipe }
+	hSetNewlineMode h universalNewlineMode
 	t <- async $ go h p
 	exitcode <- waitForProcess p
 	print ("process exited", exitcode)
 	wait t
   where
 	go h p = do
-		l <- hGetLineUntilExitOrEOF p h
-		print ("got line", l)
-		if isJust l
-			then go h p
-			else print "at EOF"
+		eof <- hIsEOF h
+		if eof
+			then return ()
+			else do
+				l <- hGetLineUntilExitOrEOF p h
+				print ("got line", l)
+				go h p
+

From 7ec22489da3be66182f89feb08867d8665ef909f Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 14:25:19 -0400
Subject: [PATCH 5/9] remove bench test

---
 bench   |  2 --
 test.hs | 23 -----------------------
 2 files changed, 25 deletions(-)
 delete mode 100755 bench
 delete mode 100644 test.hs

diff --git a/bench b/bench
deleted file mode 100755
index 98f1e9eda5..0000000000
--- a/bench
+++ /dev/null
@@ -1,2 +0,0 @@
-#!/bin/sh
-perl -e 'print STDERR "blah\n" for 1..100; print STDERR "final\n"'
diff --git a/test.hs b/test.hs
deleted file mode 100644
index 9bda99a1c7..0000000000
--- a/test.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-import Utility.Process
-import Data.Maybe
-import System.IO
-import Control.Concurrent.Async
-
-main = do
-	(Nothing, Nothing, Just h, p) <- createProcess $ (proc "./bench" [])
-		{ std_err = CreatePipe }
-	hSetNewlineMode h universalNewlineMode
-	t <- async $ go h p
-	exitcode <- waitForProcess p
-	print ("process exited", exitcode)
-	wait t
-  where
-	go h p = do
-		eof <- hIsEOF h
-		if eof
-			then return ()
-			else do
-				l <- hGetLineUntilExitOrEOF p h
-				print ("got line", l)
-				go h p
-

From e6d741af79b04f9c2c09f73eb28d91f924c6d291 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 14:54:02 -0400
Subject: [PATCH 6/9] finish conversion to hGetLineUntilExitOrEOF

started in aafae46bcbb2a9533364b65be5fc05b379898aa1
---
 Utility/Metered.hs | 24 +++++++++++-------------
 Utility/Process.hs |  6 +++---
 2 files changed, 14 insertions(+), 16 deletions(-)

diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index d39e39bfaf..888e7e1416 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -290,12 +290,11 @@ commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess
 							meterupdate bytes
 						feedprogress sendtotalsize' bytes buf' h
 
-	handlestderr ph h = unlessM (hIsEOF h) $ do
-		cancelOnExit ph (hGetLine h) >>= \case
-			Just l -> do
-				stderrHandler oh l
-				handlestderr ph h
-			Nothing -> return ()
+	handlestderr ph h = hGetLineUntilExitOrEOF ph h >>= \case
+		Just l -> do
+			stderrHandler oh l
+			handlestderr ph h
+		Nothing -> return ()
 
 {- Runs a command, that may display one or more progress meters on
  - either stdout or stderr, and prevents the meters from being displayed.
@@ -323,13 +322,12 @@ demeterCommandEnv oh cmd params environ = do
  - beginning of the line when updating a progress display).
  -}
 avoidProgress :: Bool -> ProcessHandle -> Handle -> (String -> IO ()) -> IO ()
-avoidProgress doavoid ph h emitter = unlessM (hIsEOF h) $
-	cancelOnExit ph (hGetLine h) >>= \case
-		Just s -> do
-			unless (doavoid && '\r' `elem` s) $
-				emitter s
-			avoidProgress doavoid ph h emitter
-		Nothing -> return ()
+avoidProgress doavoid ph h emitter = hGetLineUntilExitOrEOF ph h >>= \case
+	Just s -> do
+		unless (doavoid && '\r' `elem` s) $
+			emitter s
+		avoidProgress doavoid ph h emitter
+	Nothing -> return ()
 
 outputFilter
 	:: FilePath
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 7552264710..1348e9ee92 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -231,9 +231,9 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
 	void $ waitForProcess pid
 #endif
 
-{- | Like hGetLine, reads a line from the Handle. If the Handle is already
- - closed, returns Nothing. If the process exits without writing a line,
- - also returns Nothing.
+{- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of
+ - file is reached, or if the process has exited and there is nothing more
+ - buffered to read from the handle.
  -
  - This is useful to protect against situations where the process might
  - have transferred the handle being read to another process, and so

From b021e2322fff44c96ce2e9cccf39454dfade1399 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 15:03:30 -0400
Subject: [PATCH 7/9] avoid crash on EOF at end

---
 Utility/Process.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Utility/Process.hs b/Utility/Process.hs
index 1348e9ee92..958d239069 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -270,7 +270,7 @@ hGetLineUntilExitOrEOF ph h = go []
 				Just _ -> finalcheck buf
 
 	finalcheck buf = do
-		ready <- hWaitForInput h 0
+		ready <- waitforinputorerror 0
 		if ready
 			then getloop buf finalcheck
 			-- No remaining buffered input, though the handle

From 682829c200edf79b7762f87eff56845ff4ad2444 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 15:10:35 -0400
Subject: [PATCH 8/9] avoid throwing exception when the handle is closed

The handle could get closed eg, by cleanupProcess being called,
which forces the process to exit and closes all its handles.

At this point, the test case in https://git-annex.branchable.com/bugs/Buggy_external_special_remote_stalls_after_7245a9e/
is fixed.
---
 Utility/Process.hs | 15 ++++++++++-----
 1 file changed, 10 insertions(+), 5 deletions(-)

diff --git a/Utility/Process.hs b/Utility/Process.hs
index 958d239069..94321b2dfc 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -232,8 +232,8 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
 #endif
 
 {- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of
- - file is reached, or if the process has exited and there is nothing more
- - buffered to read from the handle.
+ - file is reached, or the handle is closed, or if the process has exited
+ - and there is nothing more buffered to read from the handle.
  -
  - This is useful to protect against situations where the process might
  - have transferred the handle being read to another process, and so
@@ -284,9 +284,14 @@ hGetLineUntilExitOrEOF ph h = go []
 	waitforinputorerror t = hWaitForInput h t
 		`catchNonAsync` const (pure True)
 
-	getchar = catchIOErrorType EOF 
-		(const (pure Nothing)) 
-		(Just <$> hGetChar h)
+	getchar = 
+		catcherr EOF $
+			-- If the handle is closed, reading from it is
+			-- an IllegalOperation.
+			catcherr IllegalOperation $
+				Just <$> hGetChar h
+	  where
+		catcherr t = catchIOErrorType t (const (pure Nothing))
 
 	getloop buf cont =
 		getchar >>= \case

From 043eee0cb5f9f9fb2e0b4546912296f7cda4da98 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 18 Nov 2020 15:16:49 -0400
Subject: [PATCH 9/9] update

---
 CHANGELOG                                     |  3 +++
 ..._746ffcf575f91bc3d156b279bcdf8ae2._comment | 20 +++++++++++++++++++
 2 files changed, 23 insertions(+)
 create mode 100644 doc/bugs/Buggy_external_special_remote_stalls_after_7245a9e/comment_4_746ffcf575f91bc3d156b279bcdf8ae2._comment

diff --git a/CHANGELOG b/CHANGELOG
index edef6eb3d7..fe32908de6 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -9,6 +9,9 @@ git-annex (8.20201117) UNRELEASED; urgency=medium
     and for easier scripting.
   * init: When writing hook scripts, set all execute bits, not only
     the user execute bit.
+  * Fix hang when an external special remote program exited but
+    the stderr pipe to it was left open, due to a daemon having inherited
+    the file descriptor.
 
  -- Joey Hess <id@joeyh.name>  Mon, 16 Nov 2020 09:38:32 -0400
 
diff --git a/doc/bugs/Buggy_external_special_remote_stalls_after_7245a9e/comment_4_746ffcf575f91bc3d156b279bcdf8ae2._comment b/doc/bugs/Buggy_external_special_remote_stalls_after_7245a9e/comment_4_746ffcf575f91bc3d156b279bcdf8ae2._comment
new file mode 100644
index 0000000000..f4fc122825
--- /dev/null
+++ b/doc/bugs/Buggy_external_special_remote_stalls_after_7245a9e/comment_4_746ffcf575f91bc3d156b279bcdf8ae2._comment
@@ -0,0 +1,20 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2020-11-18T17:23:21Z"
+ content="""
+Seems the problem with hWaitForInput happens when running it concurrently
+with hGetLine on the same handle. When I run it sequentially, it does seem
+to work. Ok.. I was able to implement hGetLineUntilExitOrEOF that seems to
+work.
+
+I've converted it to use that, and the test case for this bug is fixed.
+Also, the sleep based workaround
+in [[!commit aa492bc65904a19f22ffdfc20d7a5e7052e2f54d]] is removed,
+and it uses hGetLineUntilExitOrEOF instead.
+
+However, I still want to do the audit of other things that pipe stderr.
+Some of them don't do line based input, so will need a different function
+than hGetLineUntilExitOrEOF. Leaving this bug open until that audit is
+done.
+"""]]