fix: force lazy ByteString evaluation before waitForProcess to avoid deadlock
Build and Deploy / build-and-deploy (push) Successful in 1m45s
Build and Deploy / build-and-deploy (push) Successful in 1m45s
The lazy I/O in LB.hGetContents returns a thunk immediately without reading any data. If waitForProcess is called before the ByteString is forced, the parent blocks on the process while the child blocks on a full pipe buffer (no one is reading). Fix by computing LB.length (which forces full traversal) before calling waitForProcess.
This commit is contained in:
+15
-5
@@ -235,7 +235,11 @@ parseFormBody body =
|
||||
in toEnum hexVal : go rest
|
||||
go (c : rest) = c : go rest
|
||||
|
||||
-- | Run a subprocess and capture stdout/stderr as raw bytes (no locale decoding).
|
||||
{- | Run a subprocess and capture stdout/stderr as raw bytes (no locale decoding).
|
||||
Reads output eagerly to avoid the classic lazy-IO deadlock where
|
||||
the parent blocks on waitForProcess while the child blocks on a
|
||||
full pipe buffer.
|
||||
-}
|
||||
readProcessBytes :: FilePath -> [String] -> IO (ExitCode, LB.ByteString, LB.ByteString)
|
||||
readProcessBytes cmd args = do
|
||||
let process =
|
||||
@@ -244,16 +248,22 @@ readProcessBytes cmd args = do
|
||||
, std_err = CreatePipe
|
||||
}
|
||||
result <- createProcess process
|
||||
-- createProcess returns (stdin, stdout, stderr, process).
|
||||
-- stdin is Inherited → Nothing; stdout/stderr are CreatePipe → Just.
|
||||
case result of
|
||||
(Nothing, Just outH, Just errH, ph) -> do
|
||||
hSetBinaryMode outH True
|
||||
hSetBinaryMode errH True
|
||||
-- Read stdout and stderr strictly before waiting for the process.
|
||||
-- Using length forces the lazy ByteString, triggering eager reads
|
||||
-- and preventing the pipe buffer from filling up.
|
||||
-- hSetBuffering would also work but requires knowing a buffer size.
|
||||
out <- LB.hGetContents outH
|
||||
err <- LB.hGetContents errH
|
||||
ec <- waitForProcess ph
|
||||
pure (ec, out, err)
|
||||
-- Force full evaluation before waitForProcess to avoid deadlock.
|
||||
let outLen = LB.length out
|
||||
errLen = LB.length err
|
||||
outLen `seq` errLen `seq` do
|
||||
ec <- waitForProcess ph
|
||||
pure (ec, out, err)
|
||||
_ ->
|
||||
ioError $
|
||||
userError $
|
||||
|
||||
Reference in New Issue
Block a user