diff --git a/System/Process.hs b/System/Process.hs index 0fc34454..81a5788c 100644 --- a/System/Process.hs +++ b/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 diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 4b18eb82..b2caae66 100644 --- a/System/Process/Common.hs +++ b/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 diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index af420093..036e1c07 100644 --- a/System/Process/Internals.hs +++ b/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 diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs index d11e793c..cd8573f4 100644 --- a/System/Process/Posix.hs +++ b/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 diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index c2582fed..ff8d3a79 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE InterruptibleFFI #-} module System.Process.Windows ( mkProcessHandle , translateInternal @@ -12,12 +13,16 @@ module System.Process.Windows , 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 @@ import System.Win32.Process (getProcessId) #include /* 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 :: MVar ProcessHandle__ -> IO () 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 @@ foreign import 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 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp, .|.(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 @@ stopDelegateControlC = return () -- 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 @@ foreign import ccall unsafe "runInteractiveProcess" -> 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 @@ interruptProcessGroupOfInternal ph = do 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 () diff --git a/cbits/runProcess.c b/cbits/runProcess.c index d6eae4a1..ae184c82 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -510,12 +510,87 @@ mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, 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 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, 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 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, 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 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, 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,17 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, int terminateProcess (ProcHandle handle) { - if (!TerminateProcess((HANDLE) handle, 1)) { + if (!TerminateProcess ((HANDLE) handle, 1)) { + maperrno(); + return -1; + } + return 0; +} + +int +terminateJob (ProcHandle handle) +{ + if (!TerminateJobObject ((HANDLE)handle, 1)) { maperrno(); return -1; } @@ -702,4 +828,70 @@ waitForProcess (ProcHandle handle, int *pret) 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 */ diff --git a/changelog.md b/changelog.md index 73c1814d..bee88743 100644 --- a/changelog.md +++ b/changelog.md @@ -5,6 +5,8 @@ * 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* diff --git a/include/runProcess.h b/include/runProcess.h index d35e3e4f..38073894 100644 --- a/include/runProcess.h +++ b/include/runProcess.h @@ -16,6 +16,7 @@ #define UNICODE #include #include +#include #endif #include @@ -53,14 +54,14 @@ typedef PHANDLE ProcHandle; #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 @@ extern ProcHandle runInteractiveProcess( wchar_t *cmd, 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 diff --git a/process.cabal b/process.cabal index 6734c253..0ef5b914 100644 --- a/process.cabal +++ b/process.cabal @@ -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 diff --git a/tests/T9775/Makefile b/tests/T9775/Makefile new file mode 100644 index 00000000..f5a54bcc --- /dev/null +++ b/tests/T9775/Makefile @@ -0,0 +1,13 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T9775 +T9775: + '$(TEST_CC)' ok.c -o ok.exe + '$(TEST_CC)' main.c -o main.exe + diff --git a/tests/T9775/T9775_fail.hs b/tests/T9775/T9775_fail.hs new file mode 100644 index 00000000..b2cc020d --- /dev/null +++ b/tests/T9775/T9775_fail.hs @@ -0,0 +1,7 @@ +module Main where + +import System.Process + +main + = do (_,_,_,p) <- createProcess (proc "main" []) + waitForProcess p >>= print diff --git a/tests/T9775/T9775_fail.stdout b/tests/T9775/T9775_fail.stdout new file mode 100644 index 00000000..7374c53f --- /dev/null +++ b/tests/T9775/T9775_fail.stdout @@ -0,0 +1,2 @@ +ExitSuccess +bye bye diff --git a/tests/T9775/T9775_good.hs b/tests/T9775/T9775_good.hs new file mode 100644 index 00000000..a66c3165 --- /dev/null +++ b/tests/T9775/T9775_good.hs @@ -0,0 +1,7 @@ +module Main where + +import System.Process + +main + = do (_,_,_,p) <- createProcess ((proc "main" []){ use_process_jobs = True }) + waitForProcess p >>= print diff --git a/tests/T9775/T9775_good.stdout b/tests/T9775/T9775_good.stdout new file mode 100644 index 00000000..e08b3555 --- /dev/null +++ b/tests/T9775/T9775_good.stdout @@ -0,0 +1,2 @@ +bye bye +ExitFailure 120 diff --git a/tests/T9775/all.T b/tests/T9775/all.T new file mode 100644 index 00000000..55e77508 --- /dev/null +++ b/tests/T9775/all.T @@ -0,0 +1,14 @@ + +test('T9775_fail', + [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), + extra_files(['ok.c', 'main.c']), + unless(opsys('mingw32'),skip), + pre_cmd('$MAKE -s --no-print-directory T9775')], + compile_and_run, ['']) + +test('T9775_good', + [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), + unless(opsys('mingw32'),skip), + extra_files(['ok.c', 'main.c']), + pre_cmd('$MAKE -s --no-print-directory T9775')], + compile_and_run, ['']) diff --git a/tests/T9775/main.c b/tests/T9775/main.c new file mode 100644 index 00000000..2c891b1a --- /dev/null +++ b/tests/T9775/main.c @@ -0,0 +1,6 @@ +#include + +int main(int argc, char *argv[]) { + char * args[2] = { "ok", NULL }; + execv("./ok", args); +} diff --git a/tests/T9775/ok.c b/tests/T9775/ok.c new file mode 100644 index 00000000..50191dc0 --- /dev/null +++ b/tests/T9775/ok.c @@ -0,0 +1,8 @@ +#include +#include + +int main() { + Sleep(2000); + printf("bye bye\n"); + return 120; +}