packages feed

process 1.4.3.0 → 1.5.0.0

raw patch · 9 files changed

+457/−90 lines, 9 filesdep ~Win32dep ~base

Dependency ranges changed: Win32, base

Files

System/Process.hs view
@@ -115,7 +115,8 @@                                 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 @@                             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@@ -178,7 +180,8 @@ @UseHandle@ constructor will be closed by calling this function. This is not always the desired behavior. In cases where you would like to leave the @Handle@ open after spawning the child process, please use 'createProcess_'-instead.+instead. All created @Handle@s are initially in text mode; if you need them+to be in binary mode then use 'hSetBinaryMode'.  -} createProcess@@ -593,8 +596,9 @@           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)@@ -604,7 +608,15 @@         when delegating_ctlc $           endDelegateControlC e         return e-+#if defined(WINDOWS)+    OpenExtHandle _ job iocp ->+        maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite+      where mkExitCode code | code == 0 = ExitSuccess+                            | otherwise = ExitFailure $ fromIntegral code+#else+    OpenExtHandle _ _job _iocp ->+        return $ ExitFailure (-1)+#endif  -- ---------------------------------------------------------------------------- -- getProcessExitCode@@ -623,22 +635,29 @@   (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   -- ----------------------------------------------------------------------------@@ -663,8 +682,13 @@ 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@@ -774,8 +798,7 @@  {- | Runs a command using the shell, and returns 'Handle's that may      be used to communicate with the process via its @stdin@, @stdout@,-     and @stderr@ respectively. The 'Handle's are initially in binary-     mode; if you need them to be in text mode then use 'hSetBinaryMode'.+     and @stderr@ respectively. -} runInteractiveCommand   :: String@@ -797,9 +820,6 @@  >   (inp,out,err,pid) <- runInteractiveProcess "..." >   forkIO (hPutStr inp str)--    The 'Handle's are initially in binary mode; if you need them to be-    in text mode then use 'hSetBinaryMode'. -} runInteractiveProcess   :: FilePath                   -- ^ Filename of the executable (see 'RawCommand' for details)
System/Process/Common.hs view
@@ -6,6 +6,7 @@     , StdStream (..)     , ProcessHandle(..)     , ProcessHandle__(..)+    , ProcRetHandles (..)     , withFilePathException     , PHANDLE     , modifyProcessHandle@@ -65,7 +66,7 @@ #endif  data CreateProcess = CreateProcess{-  cmdspec      :: CmdSpec,                 -- ^ Executable & arguments, or shell command.  Relative paths are resolved with respect to 'cwd' if given, and otherwise the current working directory.+  cmdspec      :: CmdSpec,                 -- ^ Executable & arguments, or shell command.  If 'cwd' is 'Nothing', relative paths are resolved with respect to the current working directory.  If 'cwd' is provided, it is implementation-dependent whether relative paths are resolved with respect to 'cwd' or the current working directory, so absolute paths should be used to ensure portability.   cwd          :: Maybe FilePath,          -- ^ Optional path to the working directory for the new process   env          :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)   std_in       :: StdStream,               -- ^ How to determine stdin@@ -94,13 +95,27 @@                                            --   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 @@      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 view
@@ -24,14 +24,19 @@     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 @@ #endif  -- ----------------------------------------------------------------------------- -- | This function is almost identical to -- 'System.Process.createProcess'. The only differences are: --@@ -66,6 +70,18 @@ -- * 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 @@   :: 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 = 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 view
@@ -100,7 +100,7 @@ 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 @@      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 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
System/Process/Windows.hsc view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE InterruptibleFFI #-} module System.Process.Windows     ( mkProcessHandle     , translateInternal@@ -12,12 +13,16 @@     , createPipeInternal     , createPipeInternalFd     , interruptProcessGroupOfInternal+    , terminateJob+    , waitForJobCompletion+    , timeout_Infinite     ) where  import System.Process.Common import Control.Concurrent import Control.Exception import Data.Bits+import Data.Maybe import Foreign.C import Foreign.Marshal import Foreign.Ptr@@ -42,14 +47,24 @@  #include <fcntl.h>     /* for _O_BINARY */ +##if defined(i386_HOST_ARCH)+## define WINDOWS_CCONV stdcall+##elif defined(x86_64_HOST_ARCH)+## define WINDOWS_CCONV ccall+##else+## error Unknown mingw32 arch+##endif+ throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE throwErrnoIfBadPHandle = throwErrnoIfNull  -- On Windows, we have to close this HANDLE when it is no longer required, -- hence we add a finalizer to it-mkProcessHandle :: PHANDLE -> IO ProcessHandle-mkProcessHandle h = do-   m <- newMVar (OpenHandle h)+mkProcessHandle :: PHANDLE -> PHANDLE -> PHANDLE -> IO ProcessHandle+mkProcessHandle h job io = do+   m <- if job == nullPtr && io == nullPtr+           then newMVar (OpenHandle h)+           else newMVar (OpenExtHandle h job io)    _ <- mkWeakMVar m (processHandleFinaliser m)    return (ProcessHandle m False) @@ -57,22 +72,17 @@ processHandleFinaliser m =    modifyMVar_ m $ \p_ -> do         case p_ of-          OpenHandle ph -> closePHANDLE ph+          OpenHandle ph           -> closePHANDLE ph+          OpenExtHandle ph job io -> closePHANDLE ph+                                  >> closePHANDLE job+                                  >> closePHANDLE io           _ -> return ()         return (error "closed process handle")  closePHANDLE :: PHANDLE -> IO () closePHANDLE ph = c_CloseHandle ph -foreign import-#if defined(i386_HOST_ARCH)-  stdcall-#elif defined(x86_64_HOST_ARCH)-  ccall-#else-#error "Unknown architecture"-#endif-  unsafe "CloseHandle"+foreign import WINDOWS_CCONV unsafe "CloseHandle"   c_CloseHandle         :: PHANDLE         -> IO ()@@ -80,26 +90,30 @@ createProcess_Internal   :: String                     -- ^ function name (for error messages)   -> CreateProcess-  -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+  -> IO ProcRetHandles  createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,-                                  cwd = mb_cwd,-                                  env = mb_env,-                                  std_in = mb_stdin,-                                  std_out = mb_stdout,-                                  std_err = mb_stderr,-                                  close_fds = mb_close_fds,-                                  create_group = mb_create_group,-                                  delegate_ctlc = _ignored,-                                  detach_console = mb_detach_console,-                                  create_new_console = mb_create_new_console,-                                  new_session = mb_new_session }+                                    cwd = mb_cwd,+                                    env = mb_env,+                                    std_in = mb_stdin,+                                    std_out = mb_stdout,+                                    std_err = mb_stderr,+                                    close_fds = mb_close_fds,+                                    create_group = mb_create_group,+                                    delegate_ctlc = _ignored,+                                    detach_console = mb_detach_console,+                                    create_new_console = mb_create_new_console,+                                    new_session = mb_new_session,+                                    use_process_jobs = use_job }  = do+  let lenPtr = sizeOf (undefined :: WordPtr)   (cmd, cmdline) <- commandToProcess cmdsp   withFilePathException cmd $-   alloca $ \ pfdStdInput  ->-   alloca $ \ pfdStdOutput ->-   alloca $ \ pfdStdError  ->+   alloca $ \ pfdStdInput           ->+   alloca $ \ pfdStdOutput          ->+   alloca $ \ pfdStdError           ->+   allocaBytes lenPtr $ \ hJob      ->+   allocaBytes lenPtr $ \ hIOcpPort ->    maybeWith withCEnvironment mb_env $ \pEnv ->    maybeWith withCWString mb_cwd $ \pWorkDir -> do    withCWString cmdline $ \pcmdline -> do@@ -128,13 +142,22 @@                                 .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)                                 .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)                                 .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))+                                use_job+                                hJob+                                hIOcpPort       hndStdInput  <- mbPipe mb_stdin  pfdStdInput  WriteMode      hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode      hndStdError  <- mbPipe mb_stderr pfdStdError  ReadMode -     ph <- mkProcessHandle proc_handle-     return (hndStdInput, hndStdOutput, hndStdError, ph)+     phJob  <- peek hJob+     phIOCP <- peek hIOcpPort+     ph     <- mkProcessHandle proc_handle phJob phIOCP+     return ProcRetHandles { hStdInput  = hndStdInput+                           , hStdOutput = hndStdOutput+                           , hStdError  = hndStdError+                           , procHandle = ph+                           }  {-# NOINLINE runInteractiveProcess_lock #-} runInteractiveProcess_lock :: MVar ()@@ -155,6 +178,68 @@  -- End no-op functions ++-- ----------------------------------------------------------------------------+-- Interface to C I/O CP bits++terminateJob :: ProcessHandle -> CUInt -> IO Bool+terminateJob jh ecode =+    withProcessHandle jh $ \p_ -> do+        case p_ of+            ClosedHandle        _ -> return False+            OpenHandle          _ -> return False+            OpenExtHandle _ job _ -> c_terminateJobObject job ecode++timeout_Infinite :: CUInt+timeout_Infinite = 0xFFFFFFFF++waitForJobCompletion :: PHANDLE+                     -> PHANDLE+                     -> CUInt+                     -> IO (Maybe CInt)+waitForJobCompletion job io timeout =+            alloca $ \p_exitCode -> do+              items <- newMVar $ []+              setter <- mkSetter (insertItem items)+              getter <- mkGetter (getItem items)+              ret <- c_waitForJobCompletion job io timeout p_exitCode setter getter+              if ret == 0+                 then Just <$> peek p_exitCode+                 else return Nothing++insertItem :: Eq k => MVar [(k, v)] -> k -> v -> IO ()+insertItem env_ k v = modifyMVar_ env_ (return . ((k, v):))++getItem :: Eq k => MVar [(k, v)] -> k -> IO v+getItem env_ k = withMVar env_ (\m -> return $ fromJust $ lookup k m)++-- ----------------------------------------------------------------------------+-- Interface to C bits++type SetterDef = CUInt -> Ptr () -> IO ()+type GetterDef = CUInt -> IO (Ptr ())++foreign import ccall "wrapper"+  mkSetter :: SetterDef -> IO (FunPtr SetterDef)+foreign import ccall "wrapper"+  mkGetter :: GetterDef -> IO (FunPtr GetterDef)++foreign import WINDOWS_CCONV unsafe "TerminateJobObject"+  c_terminateJobObject+        :: PHANDLE+        -> CUInt+        -> IO Bool++foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block+  c_waitForJobCompletion+        :: PHANDLE+        -> PHANDLE+        -> CUInt+        -> Ptr CInt+        -> FunPtr (SetterDef)+        -> FunPtr (GetterDef)+        -> IO CInt+ foreign import ccall unsafe "runInteractiveProcess"   c_runInteractiveProcess         :: CWString@@ -166,7 +251,10 @@         -> Ptr FD         -> Ptr FD         -> Ptr FD-        -> CInt                         -- flags+        -> CInt          -- flags+        -> Bool          -- useJobObject+        -> Ptr PHANDLE       -- Handle to Job+        -> Ptr PHANDLE       -- Handle to I/O Completion Port         -> IO PHANDLE  commandToProcess@@ -275,15 +363,18 @@     withProcessHandle ph $ \p_ -> do         case p_ of             ClosedHandle _ -> return ()-            OpenHandle h -> do+            _ -> do let h = case p_ of+                              OpenHandle x        -> x+                              OpenExtHandle x _ _ -> x+                              _                   -> error "interruptProcessGroupOfInternal" #if mingw32_HOST_OS-                pid <- getProcessId h-                generateConsoleCtrlEvent cTRL_BREAK_EVENT pid+                    pid <- getProcessId h+                    generateConsoleCtrlEvent cTRL_BREAK_EVENT pid -- We can't use an #elif here, because MIN_VERSION_unix isn't defined -- on Windows, so on Windows cpp fails: -- error: missing binary operator before token "(" #else-                pgid <- getProcessGroupIDOf h-                signalProcessGroup sigINT pgid+                    pgid <- getProcessGroupIDOf h+                    signalProcessGroup sigINT pgid #endif-                return ()+                    return ()
cbits/runProcess.c view
@@ -161,7 +161,7 @@         if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) {             setpgid(0, 0);         }-        +         if ( childGroup) {             if ( setgid( *childGroup) != 0) {                 // ERROR@@ -240,9 +240,9 @@             }             // XXX Not the pipe             for (i = 3; i < max_fd; i++) {-		if (i != forkCommunicationFds[1]) {-		    close(i);-		}+                if (i != forkCommunicationFds[1]) {+                    close(i);+                }             }         } @@ -341,16 +341,16 @@         waitpid(pid, NULL, 0);          if (fdStdIn == -1) {-            close(fdStdInput[0]);+            // Already closed fdStdInput[0] above             close(fdStdInput[1]);         }         if (fdStdOut == -1) {             close(fdStdOutput[0]);-            close(fdStdOutput[1]);+            // Already closed fdStdOutput[1] above         }         if (fdStdErr == -1) {             close(fdStdError[0]);-            close(fdStdError[1]);+            // Already closed fdStdError[1] above         }          pid = -1;@@ -510,12 +510,87 @@     return TRUE; } +static HANDLE+createJob ()+{+    HANDLE hJob = CreateJobObject (NULL, NULL);+    JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli;+    ZeroMemory(&jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION));+    // Configure all child processes associated with the job to terminate when the+    // Last process in the job terminates. This prevent half dead processes.+    jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE;++    if (SetInformationJobObject (hJob, JobObjectExtendedLimitInformation,+                                 &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)))+    {+        return hJob;+    }++    maperrno();+    return NULL;+}++static HANDLE+createCompletionPort (HANDLE hJob)+{+    HANDLE ioPort = CreateIoCompletionPort (INVALID_HANDLE_VALUE, NULL, 0, 1);+    if (!ioPort)+    {+        // Something failed. Error is in GetLastError, let caller handler it.+        return NULL;+    }++    JOBOBJECT_ASSOCIATE_COMPLETION_PORT Port;+    Port.CompletionKey = hJob;+    Port.CompletionPort = ioPort;+    if (!SetInformationJobObject(hJob,+        JobObjectAssociateCompletionPortInformation,+        &Port, sizeof(Port))) {+        // Something failed. Error is in GetLastError, let caller handler it.+        return NULL;+    }++    return ioPort;+}++/* Note [Windows exec interaction]++   The basic issue that process jobs tried to solve is this:++   Say you have two programs A and B. Now A calls B. There are two ways to do this.
+
+   1) You can use the normal CreateProcess API, which is what normal Windows code do.
+      Using this approach, the current waitForProcess works absolutely fine.
+   2) You can call the emulated POSIX function _exec, which of course is supposed to
+      allow the child process to replace the parent.
+
+    With approach 2) waitForProcess falls apart because the Win32's process model does
+    not allow this the same way as linux. _exec is emulated by first making a call to
+    CreateProcess to spawn B and then immediately exiting from A. So you have two
+    different processes.
+
+    waitForProcess is waiting on the termination of A. Because A is immediately killed,
+    waitForProcess will return even though B is still running. This is why for instance
+    the GHC testsuite on Windows had lots of file locked errors.
+
+    This approach creates a new Job and assigned A to the job, but also all future
+    processes spawned by A. This allows us to listen in on events, such as, when all
+    processes in the job are finished, but also allows us to propagate exit codes from
+    _exec calls.
+
+    The only reason we need this at all is because we don't interact with just actual+    native code on Windows, and instead have a lot of ported POSIX code.++    The Job handle is returned to the user because Jobs have additional benefits as well,+    such as allowing you to specify resource limits on the to be spawned process.+ */+ ProcHandle runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,                        wchar_t *environment,                        int fdStdIn, int fdStdOut, int fdStdErr,                        int *pfdStdInput, int *pfdStdOutput, int *pfdStdError,-                       int flags)+                       int flags, bool useJobObject, HANDLE *hJob, HANDLE *hIOcpPort) {     STARTUPINFO sInfo;     PROCESS_INFORMATION pInfo;@@ -534,6 +609,7 @@     ZeroMemory(&sInfo, sizeof(sInfo));     sInfo.cb = sizeof(sInfo);     sInfo.dwFlags = STARTF_USESTDHANDLES;+    ZeroMemory(&pInfo, sizeof(pInfo));      if (fdStdIn == -1) {         if (!mkAnonPipe(&hStdInputRead,  TRUE, &hStdInputWrite,  FALSE))@@ -624,10 +700,47 @@         dwFlags |= CREATE_NEW_CONSOLE;     } +    /* If we're going to use a job object, then we have to create+       the thread suspended.+       See Note [Windows exec interaction].  */+    if (useJobObject)+    {+        dwFlags |= CREATE_SUSPENDED;+        *hJob = createJob();+        if (!*hJob)+        {+            goto cleanup_err;+        }++        // Create the completion port and attach it to the job+        *hIOcpPort = createCompletionPort(*hJob);+        if (!*hIOcpPort)+        {+            goto cleanup_err;+        }+    } else {+        *hJob      = NULL;+        *hIOcpPort = NULL;+    }+     if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo))     {             goto cleanup_err;     }++    if (useJobObject && hJob && *hJob)+    {+        // Then associate the process and the job;+        if (!AssignProcessToJobObject (*hJob, pInfo.hProcess))+        {+            goto cleanup_err;+        }++        // And now that we've associated the new process with the job+        // we can actively resume it.+        ResumeThread (pInfo.hThread);+    }+     CloseHandle(pInfo.hThread);      // Close the ends of the pipes that were inherited by the@@ -650,6 +763,9 @@     if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite);     if (hStdErrorRead   != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead);     if (hStdErrorWrite  != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite);+    if (useJobObject && hJob      && *hJob     ) CloseHandle(*hJob);+    if (useJobObject && hIOcpPort && *hIOcpPort) CloseHandle(*hIOcpPort);+     maperrno();     return NULL; }@@ -657,7 +773,7 @@ int terminateProcess (ProcHandle handle) {-    if (!TerminateProcess((HANDLE) handle, 1)) {+    if (!TerminateProcess ((HANDLE) handle, 1)) {         maperrno();         return -1;     }@@ -665,6 +781,16 @@ }  int+terminateJob (ProcHandle handle)+{+    if (!TerminateJobObject ((HANDLE)handle, 1)) {+        maperrno();+        return -1;+    }+    return 0;+}++int getProcessExitCode (ProcHandle handle, int *pExitCode) {     *pExitCode = 0;@@ -700,6 +826,72 @@      maperrno();     return -1;+}+++int+waitForJobCompletion ( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode, setterDef set, getterDef get )+{+    DWORD CompletionCode;+    ULONG_PTR CompletionKey;+    LPOVERLAPPED Overlapped;+    *pExitCode = 0;++    // We have to loop here. It's a blocking call, but+    // we get notified on each completion event. So if it's+    // not one we care for we should just block again.+    // If all processes are finished before this call is made+    // then the initial call will return false.+    // List of events we can listen to:+    // https://msdn.microsoft.com/en-us/library/windows/desktop/ms684141(v=vs.85).aspx+    while (GetQueuedCompletionStatus (ioPort, &CompletionCode,+           &CompletionKey, &Overlapped, timeout)) {++        switch (CompletionCode)+        {+            case JOB_OBJECT_MSG_NEW_PROCESS:+            {+                // A new child process is born.+                // Retrieve and save the process handle from the process id.+                // We'll need it for later but we can't retrieve it after the+                // process has exited.+                DWORD pid    = (DWORD)(uintptr_t)Overlapped;+                HANDLE pHwnd = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, TRUE, pid);+                set(pid, pHwnd);+            }+            break;+            case JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS:+            case JOB_OBJECT_MSG_EXIT_PROCESS:+            {+                // A child process has just exited.+                // Read exit code, We assume the last process to exit+                // is the process whose exit code we're interested in.+                HANDLE pHwnd = get((DWORD)(uintptr_t)Overlapped);+                if (GetExitCodeProcess(pHwnd, (DWORD *)pExitCode) == 0)+                {+                    maperrno();+                    return 1;+                }+            }+            break;+            case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO:+                // All processes in the tree are done.+                return 0;+            default:+                break;+        }+    }++    // Check to see if a timeout has occurred or that the+    // all processes in the job were finished by the time we+    // got to the loop.+    if (Overlapped == NULL && (HANDLE)CompletionKey != hJob)+    {+        // Timeout occurred.+        return -1;+    }++    return 0; }  #endif /* Win32 */
changelog.md view
@@ -1,5 +1,13 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.5.0.0 *February 2017*++* Bug fix: Don't close already closed pipes+  [#81](https://github.com/haskell/process/pull/81)+* Relax version bounds of Win32 to allow 2.5.+* Add support for monitoring process tree for termination with the parameter `use_process_jobs`+  in `CreateProcess` on Windows. Also added a function `terminateJob` to kill entire process tree.+ ## 1.4.3.0 *December 2016*  * New exposed `withCreateProcess`
include/runProcess.h view
@@ -16,6 +16,7 @@ #define UNICODE #include <windows.h> #include <stdlib.h>+#include <stdbool.h> #endif  #include <unistd.h>@@ -53,14 +54,14 @@  #if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) -extern ProcHandle runInteractiveProcess( char *const args[], -                                         char *workingDirectory, -                                         char **environment, +extern ProcHandle runInteractiveProcess( char *const args[],+                                         char *workingDirectory,+                                         char **environment,                                          int fdStdIn,                                          int fdStdOut,                                          int fdStdErr,-                                         int *pfdStdInput, -                                         int *pfdStdOutput, +                                         int *pfdStdInput,+                                         int *pfdStdOutput,                                          int *pfdStdError,                                          gid_t *childGroup,                                          uid_t *childUser,@@ -79,7 +80,16 @@                                          int *pfdStdInput,                                          int *pfdStdOutput,                                          int *pfdStdError,-                                         int flags);+                                         int flags,+                                         bool useJobObject,+                                         HANDLE *hJob,+                                         HANDLE *hIOcpPort );++typedef void(*setterDef)(DWORD, HANDLE);+typedef HANDLE(*getterDef)(DWORD);++extern int terminateJob( ProcHandle handle );+extern int waitForJobCompletion( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode, setterDef set, getterDef get );  #endif
process.cabal view
@@ -1,5 +1,5 @@ name:          process-version:       1.4.3.0+version:       1.5.0.0 -- NOTE: Don't forget to update ./changelog.md license:       BSD3 license-file:  LICENSE@@ -50,7 +50,7 @@     other-modules: System.Process.Common     if os(windows)         other-modules: System.Process.Windows-        build-depends: Win32 >=2.2 && < 2.4+        build-depends: Win32 >=2.2 && < 2.6         extra-libraries: kernel32         cpp-options: -DWINDOWS     else