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] 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"
-- 
2.30.2