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