summaryrefslogtreecommitdiff
path: root/src/Utility/ConcurrentOutput.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Utility/ConcurrentOutput.hs')
-rw-r--r--src/Utility/ConcurrentOutput.hs18
1 files changed, 17 insertions, 1 deletions
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