summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2017-05-19 15:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-05-19 15:55:00 (GMT)
commitbcd56dbbf7c201df3d58b86b26790fa6befa1055 (patch)
tree8ddfcaf50095be798eb1a10c932c4d19df05a6dd
parent1278c3c0e0c823582779dc5d07979ed71c40882d (diff)
version 1.10.0HEAD1.10.0master
-rw-r--r--CHANGELOG12
-rw-r--r--System/Console/Concurrent.hs4
-rw-r--r--System/Console/Concurrent/Internal.hs101
-rw-r--r--System/Process/Concurrent.hs16
-rw-r--r--concurrent-output.cabal4
5 files changed, 43 insertions, 94 deletions
diff --git a/CHANGELOG b/CHANGELOG
index cc11517..0e31b4e 100644
--- 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 <id@joeyh.name> 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
index d8cea13..57b03b8 100644
--- a/System/Console/Concurrent.hs
+++ b/System/Console/Concurrent.hs
@@ -20,12 +20,12 @@ module System.Console.Concurrent (
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
index a19b358..e1c40f5 100644
--- a/System/Console/Concurrent/Internal.hs
+++ b/System/Console/Concurrent/Internal.hs
@@ -40,8 +40,6 @@ data OutputHandle = OutputHandle
, outputBuffer :: TMVar OutputBuffer
, errorBuffer :: TMVar OutputBuffer
, outputThreads :: TMVar Integer
- , processWaiters :: TMVar [Async ()]
- , waitForProcessLock :: TMVar ()
}
data Lock = Locked
@@ -54,8 +52,6 @@ globalOutputHandle = unsafePerformIO $ OutputHandle
<*> 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 @@ outputConcurrent' stdh v = bracket setup cleanup go
h = toHandle stdh
bv = bufferFor stdh
-newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle
+-- | This alias is provided to avoid breaking backwards compatibility.
+type 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)
-
--- | 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 @@ asyncProcessWaiter waitaction = do
-- 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 @@ createProcessConcurrent p
)
| 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 @@ bgProcess p = do
, 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
index 0e00e4f..346ce2e 100644
--- 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
index c6ba3ff..1dbe486 100644
--- 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 <id@joeyh.name>
@@ -34,7 +34,7 @@ Library
, 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)