[commit: packages/process] master: Fix waitpid race by adding a lock (d837c95)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/process

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d837c95d378c16e74d2dcbb09a75ca907eb018d1/process

>---------------------------------------------------------------

commit d837c95d378c16e74d2dcbb09a75ca907eb018d1
Author: Charles Cooper <cooper.charles.m at gmail.com>
Date:   Fri Feb 3 10:41:05 2017 -0500

    Fix waitpid race by adding a lock


>---------------------------------------------------------------

d837c95d378c16e74d2dcbb09a75ca907eb018d1
 System/Process.hs        | 12 +++++-------
 System/Process/Common.hs | 10 +++++++---
 System/Process/Posix.hs  |  3 ++-
 3 files changed, 14 insertions(+), 11 deletions(-)

diff --git a/System/Process.hs b/System/Process.hs
index 81a5788..b78b831 100644
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -237,7 +237,7 @@ withCreateProcess_ fun c action =
 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 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr,
     _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ())
     return ()
   where
-    resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False
+    resetCtlcDelegation (ProcessHandle m _ l) = ProcessHandle m False l
 
 -- ----------------------------------------------------------------------------
 -- spawnProcess/spawnCommand
@@ -584,14 +584,11 @@ detail.
 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
           throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
           modifyProcessHandle ph $ \p_' ->
@@ -616,6 +613,7 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do
 #else
         return $ ExitFailure (-1)
 #endif
+  where lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m
 
 -- ----------------------------------------------------------------------------
 -- getProcessExitCode
@@ -630,7 +628,7 @@ when the process died as the result of a signal.
 -}
 
 getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
-getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do
+getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = do
   (m_e, was_open) <- modifyProcessHandle ph $ \p_ ->
     case p_ of
       ClosedHandle e -> return (p_, (Just e, False))
diff --git a/System/Process/Common.hs b/System/Process/Common.hs
index 3c8d370..dd09c0e 100644
--- a/System/Process/Common.hs
+++ b/System/Process/Common.hs
@@ -177,7 +177,11 @@ data StdStream
 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 @@ modifyProcessHandle
         :: 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
index cd8573f..129072f 100644
--- a/System/Process/Posix.hs
+++ b/System/Process/Posix.hs
@@ -48,7 +48,8 @@ import System.Process.Common
 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 ()