Skip to content

Commit

Permalink
Fix race condition
Browse files Browse the repository at this point in the history
  • Loading branch information
fredefox committed Dec 3, 2021
1 parent 1b28ab3 commit c903da5
Showing 1 changed file with 11 additions and 9 deletions.
20 changes: 11 additions & 9 deletions cabal-testsuite/src/Test/Cabal/Run.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,19 +55,13 @@ run _verbosity mb_cwd env_overrides path0 args input = do
(readstdout, writestdout) <- Compat.createPipe
(readstderr, writestderr) <- Compat.createPipe
(readall, writeall) <- Compat.createPipe
traverse_ (`hSetBuffering` LineBuffering) [ readstdout, writestdout, readstderr, writestderr, readall, writeall ]
traverse_ (`hSetBuffering` LineBuffering) [ stdout, readstdout, writestdout, readstderr, writestderr, readall, writeall ]
let mkDrain h = do
r <- hGetContents h
length r `seq` hClose h
r <- hGetContents' h
hPutStr writeall r
return r
let mkDrain' h = do
r <- hGetContents h
length r `seq` hClose h
return r
withAsync (mkDrain readstdout) $ \syncstdout -> do
withAsync (mkDrain readstderr) $ \syncstderr -> do
withAsync (mkDrain' readall) $ \syncall -> do

let prc = (proc path args)
{ cwd = mb_cwd
Expand All @@ -90,7 +84,8 @@ run _verbosity mb_cwd env_overrides path0 args input = do
rStdout <- wait syncstdout
rStderr <- wait syncstderr
hClose writeall
rAll <- wait syncall

rAll <- hGetContents' readall

return Result {
resultExitCode = exitcode,
Expand All @@ -99,3 +94,10 @@ run _verbosity mb_cwd env_overrides path0 args input = do
resultStdout = rStdout,
resultStderr = rStderr
}

-- `hGetContents'` is in since base-4.15.0.0 -- which we don't have.
hGetContents' :: Handle -> IO String
hGetContents' h = do
v <- hGetContents h
length v `seq` hClose h
pure v

0 comments on commit c903da5

Please sign in to comment.