summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2015-10-28 15:41:26 -0400
committerJoey Hess2015-10-28 15:41:26 -0400
commit644ce3f6e8876ee4bbecba6d1bf5b74a612d82e4 (patch)
treebe7bd385f6614446d24a6eebe9c5fec8c3222345 /src/Utility
parenta882ac7eefa405993ba903f19c51134341ba457c (diff)
work around waitForProcess race condition
https://github.com/haskell/process/issues/46
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/ConcurrentOutput.hs18
-rw-r--r--src/Utility/Process/Shim.hs10
2 files changed, 24 insertions, 4 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
diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs
index 202b7c32..08694d5d 100644
--- a/src/Utility/Process/Shim.hs
+++ b/src/Utility/Process/Shim.hs
@@ -1,8 +1,12 @@
-module Utility.Process.Shim (module X, createProcess) where
+module Utility.Process.Shim (module X, createProcess, waitForProcess) where
-import System.Process as X hiding (createProcess)
-import Utility.ConcurrentOutput (createProcessConcurrent)
+import System.Process as X hiding (createProcess, waitForProcess)
+import Utility.ConcurrentOutput (createProcessConcurrent, waitForProcessConcurrent)
import System.IO
+import System.Exit
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess = createProcessConcurrent
+
+waitForProcess :: ProcessHandle -> IO ExitCode
+waitForProcess = waitForProcessConcurrent