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.
This commit is contained in:
Joey Hess 2020-11-18 12:23:15 -04:00
parent aafae46bcb
commit 9af0000e0f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 52 additions and 12 deletions

View file

@ -6,7 +6,7 @@
- License: BSD-2-clause - License: BSD-2-clause
-} -}
{-# LANGUAGE CPP, Rank2Types #-} {-# LANGUAGE CPP, Rank2Types, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-tabs #-} {-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Process ( module Utility.Process (
@ -24,7 +24,7 @@ module Utility.Process (
withCreateProcess, withCreateProcess,
waitForProcess, waitForProcess,
cleanupProcess, cleanupProcess,
cancelOnExit, hGetLineUntilExitOrEOF,
startInteractiveProcess, startInteractiveProcess,
stdinHandle, stdinHandle,
stdoutHandle, stdoutHandle,
@ -250,40 +250,56 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
- buffered to the handle before exiting. - buffered to the handle before exiting.
-} -}
hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String) 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 where
reader = hGetLine isEOF h >>= \case reader = hIsEOF h >>= \case
True -> return Nothing True -> return Nothing
False -> Just <$> hGetLine h False -> Just <$> hGetLine h
waiter = do waiter = do
smalldelay smalldelay
print "hGetLineUntilExitOrEOF waitForProcess"
hFlush stdout
_ <- waitForProcess ph _ <- waitForProcess ph
waiter' print "hGetLineUntilExitOrEOF process done"
hFlush stdout
waitbufferempty
print "hGetLineUntilExitOrEOF buffer empty"
hFlush stdout
-- Reached the end of the processes output. -- Reached the end of the processes output.
hClose h hClose h
waiter' = isanythingbuffered >>= \case waitbufferempty = isanythingbuffered >>= \case
True -> do True -> do
print "something still buffered.."
-- Waiting for the reader to consume -- Waiting for the reader to consume
-- buffered output after the process has -- buffered output after the process has
-- exited. -- exited.
threadDelay 10000 -- 1/100th second threadDelay 10000 -- 1/100th second
waiter' waitbufferempty
False -> return () False -> return ()
isanythingbuffered = isanythingbuffered = do
print "hWaitForInput call start"
-- waitForInput is documented to throw an encoding -- waitForInput is documented to throw an encoding
-- error in some cases, if the Handle has buffered on it -- error in some cases, if the Handle has buffered on it
-- something that cannot be decoded. If it does, -- something that cannot be decoded. If it does,
-- that does imply there's still something buffered though. -- that does imply there's still something buffered though.
r <- hWaitForInput h 100
{-
catchNonAsync catchNonAsync
(const (return True))
-- waitForInput can throw an EOF error -- waitForInput can throw an EOF error
(catchIOErrorType EOF (catchIOErrorType EOF
(const (return False)) (const (print "EOF exception" >> return False))
(hWaitForInput h 0)) (hWaitForInput h 1))
(const (print "encoding exception" >> return True))
-}
print "hWaitForInput call done"
return r
-- A small delay avoids starting the work of waitForProcess -- A small delay avoids starting the work of waitForProcess
-- unncessarily in the common case where hGetLine gets a buffered -- unncessarily in the common case where hGetLine gets a buffered

5
bench Executable file
View file

@ -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"'

19
test.hs Normal file
View file

@ -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"