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.

diff --git a/Utility/Process.hs b/Utility/Process.hs
index 319bc545235bb60d6d1891b82465f4ac89e67af8..b8623078114379bbb41d36dbf1454983088723e6 100644 (file)
--- 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 (executable)
index 0000000..52e2d78
--- /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 (file)
index 0000000..188f92a
--- /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"