packages feed

process 1.5.0.0 → 1.6.0.0

raw patch · 7 files changed

+66/−15 lines, 7 files

Files

System/Process.hs view
@@ -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
System/Process/Common.hs view
@@ -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
System/Process/Posix.hs view
@@ -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 ()
System/Process/Windows.hsc view
@@ -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 =
changelog.md view
@@ -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
process.cabal view
@@ -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"
test/main.hs view
@@ -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"