Add new API that can correctly wait for termination of processes forked with exec on Windows.

System/Process.hs

@@ -115,7 +115,8 @@ proc cmd args = CreateProcess { cmdspec = RawCommand cmd args,
                                 create_new_console = False,
                                 new_session = False,
                                 child_group = Nothing,
-                                child_user = Nothing }
+                                child_user = Nothing,
+                                use_process_jobs = False }
 
 -- | Construct a 'CreateProcess' record for passing to 'createProcess',
 -- representing a command to be passed to the shell.
@@ -133,7 +134,8 @@ shell str = CreateProcess { cmdspec = ShellCommand str,
                             create_new_console = False,
                             new_session = False,
                             child_group = Nothing,
-                            child_user = Nothing }
+                            child_user = Nothing,
+                            use_process_jobs = False }
 
 {- |
 This is the most general way to spawn an external process.  The
@@ -594,8 +596,9 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do
           throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
           modifyProcessHandle ph $ \p_' ->
             case p_' of
-              ClosedHandle e -> return (p_',e)
-              OpenHandle ph' -> do
+              ClosedHandle e  -> return (p_', e)
+              OpenExtHandle{} -> return (p_', ExitFailure (-1))
+              OpenHandle ph'  -> do
                 closePHANDLE ph'
                 code <- peek pret
                 let e = if (code == 0)
@@ -605,7 +608,14 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do
         when delegating_ctlc $
           endDelegateControlC e
         return e
-
+    OpenExtHandle _ job iocp ->
+#if defined(WINDOWS)
+        maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite
+      where mkExitCode code | code == 0 = ExitSuccess
+                            | otherwise = ExitFailure $ fromIntegral code
+#else
+        return $ ExitFailure (-1)
+#endif
 
 -- ----------------------------------------------------------------------------
 -- getProcessExitCode
@@ -624,22 +634,29 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do
   (m_e, was_open) <- modifyProcessHandle ph $ \p_ ->
     case p_ of
       ClosedHandle e -> return (p_, (Just e, False))
-      OpenHandle h ->
+      open -> do
         alloca $ \pExitCode -> do
-            res <- throwErrnoIfMinus1Retry "getProcessExitCode" $
-                        c_getProcessExitCode h pExitCode
-            code <- peek pExitCode
-            if res == 0
-              then return (p_, (Nothing, False))
-              else do
-                   closePHANDLE h
-                   let e  | code == 0 = ExitSuccess
-                          | otherwise = ExitFailure (fromIntegral code)
-                   return (ClosedHandle e, (Just e, True))
+          case getHandle open of
+            Nothing -> return (p_, (Nothing, False))
+            Just h  -> do
+                res <- throwErrnoIfMinus1Retry "getProcessExitCode" $
+                                        c_getProcessExitCode h pExitCode
+                code <- peek pExitCode
+                if res == 0
+                   then return (p_, (Nothing, False))
+                   else do
+                        closePHANDLE h
+                        let e  | code == 0 = ExitSuccess
+                               | otherwise = ExitFailure (fromIntegral code)
+                        return (ClosedHandle e, (Just e, True))
   case m_e of
     Just e | was_open && delegating_ctlc -> endDelegateControlC e
     _                                    -> return ()
   return m_e
+    where getHandle :: ProcessHandle__ -> Maybe PHANDLE
+          getHandle (OpenHandle        h) = Just h
+          getHandle (ClosedHandle      _) = Nothing
+          getHandle (OpenExtHandle h _ _) = Just h
 
 
 -- ----------------------------------------------------------------------------
@@ -664,8 +681,13 @@ terminateProcess :: ProcessHandle -> IO ()
 terminateProcess ph = do
   withProcessHandle ph $ \p_ ->
     case p_ of
-      ClosedHandle _ -> return ()
-      OpenHandle h -> do
+      ClosedHandle  _ -> return ()
+#if defined(WINDOWS)
+      OpenExtHandle{} -> terminateJob ph 1 >> return ()
+#else
+      OpenExtHandle{} -> error "terminateProcess with OpenExtHandle should not happen on POSIX."
+#endif
+      OpenHandle    h -> do
         throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h
         return ()
         -- does not close the handle, we might want to try terminating it

System/Process/Common.hs

@@ -6,6 +6,7 @@ module System.Process.Common
     , StdStream (..)
     , ProcessHandle(..)
     , ProcessHandle__(..)
+    , ProcRetHandles (..)
     , withFilePathException
     , PHANDLE
     , modifyProcessHandle
@@ -94,13 +95,27 @@ data CreateProcess = CreateProcess{
                                            --   Default: @Nothing@
                                            --
                                            --   @since 1.4.0.0
-  child_user :: Maybe UserID               -- ^ Use posix setuid to set child process's user id; does nothing on other platforms.
+  child_user :: Maybe UserID,              -- ^ Use posix setuid to set child process's user id; does nothing on other platforms.
                                            --
                                            --   Default: @Nothing@
                                            --
                                            --   @since 1.4.0.0
+  use_process_jobs :: Bool                 -- ^ On Windows systems this flag indicates that we should wait for the entire process tree
+                                           --   to finish before unblocking. On POSIX systems this flag is ignored.
+                                           --
+                                           --   Default: @False@
+                                           --
+                                           --   @since 1.5.0.0
  } deriving (Show, Eq)
 
+-- | contains the handles returned by a call to createProcess_Internal
+data ProcRetHandles
+  = ProcRetHandles { hStdInput      :: Maybe Handle
+                   , hStdOutput     :: Maybe Handle
+                   , hStdError      :: Maybe Handle
+                   , procHandle     :: ProcessHandle
+                   }
+
 data CmdSpec
   = ShellCommand String
       -- ^ A command line to execute using the shell
@@ -154,8 +169,14 @@ data StdStream
      None of the process-creation functions in this library wait for
      termination: they all return a 'ProcessHandle' which may be used
      to wait for the process later.
+
+     On Windows a second wait method can be used to block for event
+     completion. This requires two handles. A process job handle and
+     a events handle to monitor.
 -}
-data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode
+data ProcessHandle__ = OpenHandle PHANDLE
+                     | OpenExtHandle PHANDLE PHANDLE PHANDLE
+                     | ClosedHandle ExitCode
 data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool
 
 withFilePathException :: FilePath -> IO a -> IO a

System/Process/Internals.hs

@@ -24,14 +24,19 @@ module System.Process.Internals (
     PHANDLE, closePHANDLE, mkProcessHandle,
     modifyProcessHandle, withProcessHandle,
     CreateProcess(..),
-    CmdSpec(..), StdStream(..),
+    CmdSpec(..), StdStream(..), ProcRetHandles (..),
     createProcess_,
     runGenProcess_, --deprecated
     fdToHandle,
     startDelegateControlC,
     endDelegateControlC,
     stopDelegateControlC,
-#ifndef WINDOWS
+    unwrapHandles,
+#ifdef WINDOWS
+    terminateJob,
+    waitForJobCompletion,
+    timeout_Infinite,
+#else
     pPrPr_disableITimers, c_execvpe,
     ignoreSignal, defaultSignal,
 #endif
@@ -57,7 +62,6 @@ import System.Process.Posix
 #endif
 
 -- ----------------------------------------------------------------------------
-
 -- | This function is almost identical to
 -- 'System.Process.createProcess'. The only differences are:
 --
@@ -66,6 +70,18 @@ import System.Process.Posix
 -- * This function takes an extra @String@ argument to be used in creating
 --   error messages.
 --
+-- * 'use_process_jobs' can be set in CreateProcess since 1.5.0.0 in order to create
+--   an I/O completion port to monitor a process tree's progress on Windows.
+--
+-- The function also returns two new handles:
+--   * an I/O Completion Port handle on which events
+--     will be signaled.
+--   * a Job handle which can be used to kill all running
+--     processes.
+--
+--  On POSIX platforms these two new handles will always be Nothing
+--
+--
 -- This function has been available from the "System.Process.Internals" module
 -- for some time, and is part of the "System.Process" module since version
 -- 1.2.1.0.
@@ -75,7 +91,7 @@ createProcess_
   :: String                     -- ^ function name (for error messages)
   -> CreateProcess
   -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess_ = createProcess_Internal
+createProcess_ msg proc_ = unwrapHandles `fmap` createProcess_Internal msg proc_
 {-# INLINE createProcess_ #-}
 
 -- ------------------------------------------------------------------------
@@ -137,6 +153,10 @@ translate :: String -> String
 translate = translateInternal
 {-# INLINE translate #-}
 
+-- ---------------------------------------------------------------------------
+-- unwrapHandles
+unwrapHandles :: ProcRetHandles -> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+unwrapHandles r = (hStdInput r, hStdOutput r, hStdError r, procHandle r)
 
 -- ----------------------------------------------------------------------------
 -- Deprecated / compat

System/Process/Posix.hs

@@ -100,7 +100,7 @@ withCEnvironment envir act =
 createProcess_Internal
     :: String
     -> CreateProcess
-    -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+    -> IO ProcRetHandles
 createProcess_Internal fun
                    CreateProcess{ cmdspec = cmdsp,
                                   cwd = mb_cwd,
@@ -166,7 +166,11 @@ createProcess_Internal fun
      hndStdError  <- mbPipe mb_stderr pfdStdError  ReadMode
 
      ph <- mkProcessHandle proc_handle mb_delegate_ctlc
-     return (hndStdInput, hndStdOutput, hndStdError, ph)
+     return ProcRetHandles { hStdInput    = hndStdInput
+                           , hStdOutput   = hndStdOutput
+                           , hStdError    = hndStdError
+                           , procHandle   = ph
+                           }
 
 {-# NOINLINE runInteractiveProcess_lock #-}
 runInteractiveProcess_lock :: MVar ()
@@ -291,7 +295,8 @@ interruptProcessGroupOfInternal
 interruptProcessGroupOfInternal ph = do
     withProcessHandle ph $ \p_ -> do
         case p_ of
-            ClosedHandle _ -> return ()
-            OpenHandle h -> do
+            OpenExtHandle{} -> return ()
+            ClosedHandle  _ -> return ()
+            OpenHandle    h -> do
                 pgid <- getProcessGroupIDOf h
                 signalProcessGroup sigINT pgid