-- cgit v1.3-2-g0d8e -- cgit v1.3-2-g0d8e From 24b25e64259e5370326a88fc23bf4ee27c2c44fd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 15:08:38 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 3c072cf4..be5fb8d3 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -85,7 +85,11 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do + hPutStrLn stderr "WAIT PROCESS" + hFlush stderr void $ P.waitForProcess h + hPutStrLn stderr "WAIT PROCESS done" + hFlush stderr havelock else do withLock (`putTMVar` orig) -- cgit v1.3-2-g0d8e From 8719ec68887f7e0d56f7c0cd94ac5a4e0efef293 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 15:12:23 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index be5fb8d3..5584d7a9 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -87,7 +87,9 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar then do hPutStrLn stderr "WAIT PROCESS" hFlush stderr - void $ P.waitForProcess h + (void $ P.waitForProcess h) + `catchIO` + (\e -> hPutStrLn stderr (show ("WAIT PROCESS failed", e))) hPutStrLn stderr "WAIT PROCESS done" hFlush stderr havelock -- cgit v1.3-2-g0d8e From 76a84010180d17d99982880c6b1e7ae4bed82a76 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 15:15:36 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 5584d7a9..3ced5083 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -85,13 +85,7 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do - hPutStrLn stderr "WAIT PROCESS" - hFlush stderr - (void $ P.waitForProcess h) - `catchIO` - (\e -> hPutStrLn stderr (show ("WAIT PROCESS failed", e))) - hPutStrLn stderr "WAIT PROCESS done" - hFlush stderr + void $ tryIO $ P.waitForProcess h havelock else do withLock (`putTMVar` orig) -- cgit v1.3-2-g0d8e From 46e113e200af741695417ce38ae8cb6fd670a486 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 15:16:44 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 3ced5083..3c072cf4 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -85,7 +85,7 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do - void $ tryIO $ P.waitForProcess h + void $ P.waitForProcess h havelock else do withLock (`putTMVar` orig) -- cgit v1.3-2-g0d8e From 3ba41b1d37a82effa2fc5b5a3f5b8d8da470c6bc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 15:34:43 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 18 +++++++++++++++++- src/Utility/Process/Shim.hs | 10 +++++++--- 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 -- cgit v1.3-2-g0d8e -- cgit v1.3-2-g0d8e