From 644ce3f6e8876ee4bbecba6d1bf5b74a612d82e4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 15:41:26 -0400 Subject: work around waitForProcess race condition https://github.com/haskell/process/issues/46 --- src/Utility/ConcurrentOutput.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'src/Utility/ConcurrentOutput.hs') diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 3c072cf4..0f1cf9d3 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -6,6 +6,7 @@ module Utility.ConcurrentOutput ( withConcurrentOutput, outputConcurrent, createProcessConcurrent, + waitForProcessConcurrent, ) where import System.IO @@ -23,6 +24,7 @@ import Data.List import Data.Monoid import qualified Data.ByteString as B import qualified System.Process as P +import System.Exit import Utility.Monad import Utility.Exception @@ -85,7 +87,7 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do - void $ P.waitForProcess h + void $ waitForProcessConcurrent h havelock else do withLock (`putTMVar` orig) @@ -206,6 +208,20 @@ createProcessConcurrent p (from, to) <- createPipe (,) <$> fdToHandle to <*> fdToHandle from +-- | This must be used to wait for processes started with +-- `createProcessConcurrent`. +-- +-- This is necessary because `System.Process.waitForProcess` has a +-- race condition when two threads check the same process. If the race +-- is triggered, one thread will successfully wait, but the other +-- throws a DoesNotExist exception. +waitForProcessConcurrent :: P.ProcessHandle -> IO ExitCode +waitForProcessConcurrent h = do + v <- tryWhenExists (P.waitForProcess h) + case v of + Just r -> return r + Nothing -> maybe (waitForProcessConcurrent h) return =<< P.getProcessExitCode h + willOutput :: P.StdStream -> Bool willOutput P.Inherit = True willOutput _ = False -- cgit v1.2.3