diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -77,7 +77,7 @@ import Control.Concurrent import Control.DeepSeq (rnf) -import Control.Exception (SomeException, mask, try, throwIO) +import Control.Exception (SomeException, mask, bracket, try, throwIO) import qualified Control.Exception as C import Control.Monad import Data.Maybe @@ -237,7 +237,7 @@ cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () cleanupProcess (mb_stdin, mb_stdout, mb_stderr, - ph@(ProcessHandle _ delegating_ctlc)) = do + ph@(ProcessHandle _ delegating_ctlc _)) = do terminateProcess ph -- Note, it's important that other threads that might be reading/writing -- these handles also get killed off, since otherwise they might be holding @@ -258,7 +258,7 @@ _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) return () where - resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False + resetCtlcDelegation (ProcessHandle m _ l) = ProcessHandle m False l -- ---------------------------------------------------------------------------- -- spawnProcess/spawnCommand @@ -584,15 +584,13 @@ waitForProcess :: ProcessHandle -> IO ExitCode -waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do +waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_) case p_ of ClosedHandle e -> return e OpenHandle h -> do - -- don't hold the MVar while we call c_waitForProcess... - -- (XXX but there's a small race window here during which another - -- thread could close the handle or call waitForProcess) e <- alloca $ \pret -> do + -- don't hold the MVar while we call c_waitForProcess... throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) modifyProcessHandle ph $ \p_' -> case p_' of @@ -617,6 +615,13 @@ OpenExtHandle _ _job _iocp -> return $ ExitFailure (-1) #endif + where + -- If more than one thread calls `waitpid` at a time, `waitpid` will + -- return the exit code to one of them and (-1) to the rest of them, + -- causing an exception to be thrown. + -- Cf. https://github.com/haskell/process/issues/46, and + -- https://github.com/haskell/process/pull/58 for further discussion + lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m -- ---------------------------------------------------------------------------- -- getProcessExitCode @@ -631,7 +636,7 @@ -} getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) -getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do +getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do (m_e, was_open) <- modifyProcessHandle ph $ \p_ -> case p_ of ClosedHandle e -> return (p_, (Just e, False)) @@ -659,6 +664,23 @@ getHandle (ClosedHandle _) = Nothing getHandle (OpenExtHandle h _ _) = Just h + -- If somebody is currently holding the waitpid lock, we don't want to + -- accidentally remove the pid from the process table. + -- Try acquiring the waitpid lock. If it is held, we are done + -- since that means the process is still running and we can return + -- `Nothing`. If it is not held, acquire it so we can run the + -- (non-blocking) call to `waitpid` without worrying about any + -- other threads calling it at the same time. + tryLockWaitpid :: IO (Maybe ExitCode) -> IO (Maybe ExitCode) + tryLockWaitpid action = bracket acquire release between + where + acquire = tryTakeMVar (waitpidLock ph) + release m = case m of + Nothing -> return () + Just () -> putMVar (waitpidLock ph) () + between m = case m of + Nothing -> return Nothing + Just () -> action -- ---------------------------------------------------------------------------- -- terminateProcess diff --git a/System/Process/Common.hs b/System/Process/Common.hs --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -177,7 +177,11 @@ data ProcessHandle__ = OpenHandle PHANDLE | OpenExtHandle PHANDLE PHANDLE PHANDLE | ClosedHandle ExitCode -data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool +data ProcessHandle + = ProcessHandle { phandle :: !(MVar ProcessHandle__) + , mb_delegate_ctlc :: !Bool + , waitpidLock :: !(MVar ()) + } withFilePathException :: FilePath -> IO a -> IO a withFilePathException fpath act = handle mapEx act @@ -188,13 +192,13 @@ :: ProcessHandle -> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a -modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io +modifyProcessHandle (ProcessHandle m _ _) io = modifyMVar m io withProcessHandle :: ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a -withProcessHandle (ProcessHandle m _) io = withMVar m io +withProcessHandle (ProcessHandle m _ _) io = withMVar m io fd_stdin, fd_stdout, fd_stderr :: FD fd_stdin = 0 diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -48,7 +48,8 @@ mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle mkProcessHandle p mb_delegate_ctlc = do m <- newMVar (OpenHandle p) - return (ProcessHandle m mb_delegate_ctlc) + l <- newMVar () + return (ProcessHandle m mb_delegate_ctlc l) closePHANDLE :: PHANDLE -> IO () closePHANDLE _ = return () diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -66,7 +66,8 @@ then newMVar (OpenHandle h) else newMVar (OpenExtHandle h job io) _ <- mkWeakMVar m (processHandleFinaliser m) - return (ProcessHandle m False) + l <- newMVar () + return (ProcessHandle m False l) processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m = diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.0.0 *February 2017* + +* Fix: waitForProcess race condition + [#46](https://github.com/haskell/process/issues/46) + [#58](https://github.com/haskell/process/pull/58) + ## 1.5.0.0 *February 2017* * Bug fix: Don't close already closed pipes diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.5.0.0 +version: 1.6.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -82,3 +82,5 @@ , bytestring , directory , process + ghc-options: -threaded + -with-rtsopts "-N" diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,10 +1,12 @@ import Control.Exception -import Control.Monad (unless) +import Control.Monad (unless, void) import System.Exit import System.IO.Error import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Process +import Control.Concurrent import Data.List (isInfixOf) +import Data.Maybe (isNothing) import System.IO (hClose, openBinaryTempFile) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -65,6 +67,19 @@ $ error $ "Unexpected exit code " ++ show ec unless (bs == res') $ error $ "Unexpected result: " ++ show res' + + do -- multithreaded waitForProcess + (_, _, _, p) <- createProcess (proc "sleep" ["0.1"]) + me1 <- newEmptyMVar + _ <- forkIO . void $ waitForProcess p >>= putMVar me1 + -- check for race / deadlock between waitForProcess and getProcessExitCode + e3 <- getProcessExitCode p + e2 <- waitForProcess p + e1 <- readMVar me1 + unless (isNothing e3) + $ error $ "unexpected exit " ++ show e3 + unless (e1 == ExitSuccess && e2 == ExitSuccess) + $ error "sleep exited with non-zero exit code!" putStrLn "Tests passed successfully"