diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -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) diff --git a/System/Process/Common.hs b/System/Process/Common.hs --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -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 diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -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 diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -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 diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc --- 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 @@ , 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 /* 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 () diff --git a/cbits/runProcess.c b/cbits/runProcess.c --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -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 */ diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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` diff --git a/include/runProcess.h b/include/runProcess.h --- a/include/runProcess.h +++ b/include/runProcess.h @@ -16,6 +16,7 @@ #define UNICODE #include #include +#include #endif #include @@ -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 diff --git a/process.cabal b/process.cabal --- 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 @@ -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