diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,15 @@ +concurrent-output (1.10.0) unstable; urgency=medium + + * Simplified by removing workaround for waitForProcess race + condition (https://github.com/haskell/process/issues/46). + * Depends on process-1.6.0.0 which fixed that race. + * ConcurrentProcessHandle is now a type alias for ProcessHandle, + and waitForProcessConcurrent simply calls waitForProcess. + These are now only provided to avoid breaking backwards + compatability. + + -- Joey Hess Fri, 19 May 2017 11:54:49 -0400 + concurrent-output (1.9.2) unstable; urgency=medium * Allow process-1.6.0.0. diff --git a/System/Console/Concurrent.hs b/System/Console/Concurrent.hs --- a/System/Console/Concurrent.hs +++ b/System/Console/Concurrent.hs @@ -20,12 +20,12 @@ Outputable(..), outputConcurrent, errorConcurrent, - ConcurrentProcessHandle, createProcessConcurrent, - waitForProcessConcurrent, createProcessForeground, flushConcurrentOutput, lockOutput, + ConcurrentProcessHandle, + waitForProcessConcurrent, -- * Low level access to the output buffer OutputBuffer, StdHandle(..), diff --git a/System/Console/Concurrent/Internal.hs b/System/Console/Concurrent/Internal.hs --- a/System/Console/Concurrent/Internal.hs +++ b/System/Console/Concurrent/Internal.hs @@ -40,8 +40,6 @@ , outputBuffer :: TMVar OutputBuffer , errorBuffer :: TMVar OutputBuffer , outputThreads :: TMVar Integer - , processWaiters :: TMVar [Async ()] - , waitForProcessLock :: TMVar () } data Lock = Locked @@ -54,8 +52,6 @@ <*> newTMVarIO (OutputBuffer []) <*> newTMVarIO (OutputBuffer []) <*> newTMVarIO 0 - <*> newTMVarIO [] - <*> newEmptyTMVarIO -- | Holds a lock while performing an action. This allows the action to -- perform its own output to the console, without using functions from this @@ -186,69 +182,13 @@ h = toHandle stdh bv = bufferFor stdh -newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle - -toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) -toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h) +-- | This alias is provided to avoid breaking backwards compatibility. +type ConcurrentProcessHandle = P.ProcessHandle --- | Use this to wait for processes started with --- `createProcessConcurrent` and `createProcessForeground`, and get their --- exit status. --- --- Note that such processes are actually automatically waited for --- internally, so not calling this explicitly will not result --- in zombie processes. This behavior differs from `P.waitForProcess` +-- | Same as `P.waitForProcess`; provided to avoid breaking backwards +-- compatibility. waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode -waitForProcessConcurrent (ConcurrentProcessHandle h) = - bracket lock unlock checkexit - where - lck = waitForProcessLock globalOutputHandle - lock = atomically $ tryPutTMVar lck () - unlock True = atomically $ takeTMVar lck - unlock False = return () - checkexit locked = maybe (waitsome locked) return - =<< P.getProcessExitCode h - waitsome True = do - let v = processWaiters globalOutputHandle - l <- atomically $ readTMVar v - if null l - -- Avoid waitAny [] which blocks forever - then P.waitForProcess h - else do - -- Wait for any of the running - -- processes to exit. It may or may not - -- be the one corresponding to the - -- ProcessHandle. If it is, - -- getProcessExitCode will succeed. - void $ tryIO $ waitAny l - checkexit True - waitsome False = do - -- Another thread took the lck first. Wait for that thread to - -- wait for one of the running processes to exit. - atomically $ do - putTMVar lck () - takeTMVar lck - checkexit False - --- Registers an action that waits for a process to exit, --- adding it to the processWaiters list, and removing it once the action --- completes. -asyncProcessWaiter :: IO () -> IO () -asyncProcessWaiter waitaction = do - regdone <- newEmptyTMVarIO - waiter <- async $ do - self <- atomically (takeTMVar regdone) - waitaction `finally` unregister self - register waiter regdone - where - v = processWaiters globalOutputHandle - register waiter regdone = atomically $ do - l <- takeTMVar v - putTMVar v (waiter:l) - putTMVar regdone waiter - unregister waiter = atomically $ do - l <- takeTMVar v - putTMVar v (filter (/= waiter) l) +waitForProcessConcurrent = P.waitForProcess -- | Wrapper around `System.Process.createProcess` that prevents -- multiple processes that are running concurrently from writing @@ -266,7 +206,11 @@ -- the process is instead run with its stdout and stderr -- redirected to a buffer. The buffered output will be displayed as soon -- as the output lock becomes free. -createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +-- +-- Note that the the process is waited for by a background thread, +-- so unlike createProcess, neglecting to call waitForProcess will not +-- result in zombie processess. +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p | willOutput (P.std_out p) || willOutput (P.std_err p) = ifM tryTakeOutputLock @@ -275,31 +219,34 @@ ) | otherwise = do r@(_, _, _, h) <- P.createProcess p - asyncProcessWaiter $ - void $ tryIO $ P.waitForProcess h - return (toConcurrentProcessHandle r) + _ <- async $ void $ tryIO $ P.waitForProcess h + return r -- | Wrapper around `System.Process.createProcess` that makes sure a process -- is run in the foreground, with direct access to stdout and stderr. -- Useful when eg, running an interactive process. -createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +-- +-- Note that the the process is waited for by a background thread, +-- so unlike createProcess, neglecting to call waitForProcess will not +-- result in zombie processess. +createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessForeground p = do takeOutputLock fgProcess p -fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock registerOutputThread -- Wait for the process to exit and drop the lock. - asyncProcessWaiter $ do + _ <- async $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock - return (toConcurrentProcessHandle r) + return r -bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) bgProcess p = do let p' = p { P.std_out = rediroutput (P.std_out p) @@ -314,11 +261,13 @@ , mungeret (P.std_err p) stderr_h , h ) - asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h + -- Wait for the process for symmetry with fgProcess, + -- which does the same. + _ <- async $ void $ tryIO $ P.waitForProcess h outbuf <- setupOutputBuffer StdOut stdout_h errbuf <- setupOutputBuffer StdErr stderr_h void $ async $ bufferWriter [outbuf, errbuf] - return (toConcurrentProcessHandle r) + return r where rediroutput ss | willOutput ss = P.CreatePipe diff --git a/System/Process/Concurrent.hs b/System/Process/Concurrent.hs --- a/System/Process/Concurrent.hs +++ b/System/Process/Concurrent.hs @@ -9,26 +9,14 @@ module System.Process.Concurrent where import System.Console.Concurrent -import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import System.Process hiding (createProcess, waitForProcess) import System.IO import System.Exit -- | Calls `createProcessConcurrent` --- --- You should use the waitForProcess in this module on the resulting --- ProcessHandle. Using System.Process.waitForProcess instead can have --- mildly unexpected results. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess p = do - (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p - return (i, o, e, h) +createProcess = createProcessConcurrent -- | Calls `waitForProcessConcurrent` --- --- You should only use this on a ProcessHandle obtained by calling --- createProcess from this module. Using this with a ProcessHandle --- obtained from System.Process.createProcess etc will have extremely --- unexpected results; it can wait a very long time before returning. waitForProcess :: ProcessHandle -> IO ExitCode -waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle +waitForProcess = waitForProcessConcurrent diff --git a/concurrent-output.cabal b/concurrent-output.cabal --- a/concurrent-output.cabal +++ b/concurrent-output.cabal @@ -1,5 +1,5 @@ Name: concurrent-output -Version: 1.9.2 +Version: 1.10.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess @@ -34,7 +34,7 @@ , text (>= 0.11.0 && < 1.3.0) , async (>= 2.0 && < 2.2) , stm (>= 2.0 && < 2.5) - , process (>= 1.1.0 && < 1.7.0) + , process (>= 1.6.0 && < 1.7.0) , directory (>= 1.2.0 && < 1.4.0) , transformers (>= 0.3.0 && < 0.6.0) , exceptions (>= 0.6.0 && < 0.9.0)