From 3fb6d99e0bd94711880881b1d95bb15f5a4eb532 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 1 Feb 2020 00:30:54 -0500 Subject: [PATCH 1/7] windows: Don't swallow failures from WaitForSingleObject --- cbits/runProcess.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 494de7fb..7d76b27a 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -957,7 +957,7 @@ waitForJobCompletion ( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode return -1; } - return 0; + return 2; } #endif /* Win32 */ From d6ff89288db6ac8eec5ff62043a0e3ab1c616988 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 1 Feb 2020 00:31:35 -0500 Subject: [PATCH 2/7] Add documentation for fields of ProcessHandle__ --- System/Process/Common.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 3da4ad9c..dfdaf8f0 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -186,8 +186,15 @@ data StdStream completion. This requires two handles. A process job handle and a events handle to monitor. -} -data ProcessHandle__ = OpenHandle PHANDLE - | OpenExtHandle PHANDLE PHANDLE PHANDLE +data ProcessHandle__ = OpenHandle { phdlProcessHandle :: PHANDLE } + | OpenExtHandle { phdlProcessHandle :: PHANDLE + -- ^ the process + , phdlJobHandle :: PHANDLE + -- ^ the job containing the process and + -- its subprocesses + , phdlIocpHandle :: PHANDLE + -- ^ the job's IO Completion Port + } | ClosedHandle ExitCode data ProcessHandle = ProcessHandle { phandle :: !(MVar ProcessHandle__) From 8895de09530e90a34519feef8f6e88d4f68faefe Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 1 Feb 2020 00:33:01 -0500 Subject: [PATCH 3/7] Check exit code of processes using jobs in two stages Previously we would rely on the exit This fixes a few nasty bugs: * System.Process.waitForProcess failed to keep the ProcessHandle's MVar alive, potentially resulting in the finalizer being run while waitForJobCompletion is executing. This would cause the process handles to be closed, resulting in waitForJobCompletion to fail. * waitForProcess failed to explicitly close the job, process, and IOCP handles. * waitForProcess failed to stop delegation of Ctrl-C in processes using jobs. --- System/Process.hs | 60 ++++++++++++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 21 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 33784e06..89e91b21 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -642,28 +642,35 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do case p_ of ClosedHandle e -> return e OpenHandle h -> do - e <- alloca $ \pret -> do - -- don't hold the MVar while we call c_waitForProcess... - throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret) - modifyProcessHandle ph $ \p_' -> - case p_' of - ClosedHandle e -> return (p_', e) - OpenExtHandle{} -> return (p_', ExitFailure (-1)) - OpenHandle ph' -> do - closePHANDLE ph' - code <- peek pret - let e = if (code == 0) - then ExitSuccess - else (ExitFailure (fromIntegral code)) - return (ClosedHandle e, e) - when delegating_ctlc $ - endDelegateControlC e - return e + -- don't hold the MVar while we call c_waitForProcess... + e <- waitForProcess' h + e' <- modifyProcessHandle ph $ \p_' -> + case p_' of + ClosedHandle e' -> return (p_', e') + OpenExtHandle{} -> fail "waitForProcess(OpenExtHandle): this cannot happen" + OpenHandle ph' -> do + closePHANDLE ph' + when delegating_ctlc $ + endDelegateControlC e + return (ClosedHandle e, 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 + OpenExtHandle h job iocp -> do + -- First wait for completion of the job... + code <- waitForJobCompletion job iocp timeout_Infinite + let e = maybe (ExitFailure (-1)) mkExitCode code + e' <- modifyProcessHandle ph $ \p_' -> + case p_' of + ClosedHandle e' -> return (p_', e') + OpenHandle{} -> fail "waitForProcess(OpenHandle): this cannot happen" + OpenExtHandle ph' job' iocp' -> do + closePHANDLE ph' + closePHANDLE job' + closePHANDLE iocp' + when delegating_ctlc $ + endDelegateControlC e + return (ClosedHandle e, e) + return e #else OpenExtHandle _ _job _iocp -> return $ ExitFailure (-1) @@ -676,6 +683,17 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do -- https://github.com/haskell/process/pull/58 for further discussion lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m + waitForProcess' :: PHANDLE -> IO ExitCode + waitForProcess' h = alloca $ \pret -> do + throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret) + mkExitCode <$> peek pret + + mkExitCode :: CInt -> ExitCode + mkExitCode code + | code == 0 = ExitSuccess + | otherwise = ExitFailure (fromIntegral code) + + -- ---------------------------------------------------------------------------- -- getProcessExitCode From 3138b775e80b058c987c91029424d0a64d2f181d Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Mon, 3 Feb 2020 16:51:34 -0500 Subject: [PATCH 4/7] Refactor waiting on job objects Previously in order to wait on a job object we would create an IO Completion Port, configure the job object to emit notifications to it with SetInformationJobObject, and wait for JOB_OBJECT_MSG_EXIT_PROCESS notifications until all processes have died. This followed one piece of guidance from Microsoft [1] but according to Microsoft's own documentation, this cannot work reliably as delivery of job notifications is not guaranteed [2]. I have seen cases where the processes hang waiting on job objects so I can only guess that message loss is indeed possible. Instead we now take a simpler approach: look at the processes in the job, if there are none then we are done. If there are still processes, choose one and wait for it to finish. Iterate until the job is empty. Credit for this approach goes to Davean Scies. [1] https://devblogs.microsoft.com/oldnewthing/20130405-00/?p=4743 [2] https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-jobobject_associate_completion_port --- System/Process.hs | 15 ++-- System/Process/Common.hs | 2 - System/Process/Windows.hsc | 70 +++++-------------- cbits/runProcess.c | 139 +++++++++++-------------------------- include/runProcess.h | 5 +- 5 files changed, 66 insertions(+), 165 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 89e91b21..3e54f456 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -655,24 +655,23 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do return (ClosedHandle e, e) return e' #if defined(WINDOWS) - OpenExtHandle h job iocp -> do + OpenExtHandle h job -> do -- First wait for completion of the job... - code <- waitForJobCompletion job iocp timeout_Infinite - let e = maybe (ExitFailure (-1)) mkExitCode code + waitForJobCompletion job + e <- waitForProcess' h e' <- modifyProcessHandle ph $ \p_' -> case p_' of ClosedHandle e' -> return (p_', e') OpenHandle{} -> fail "waitForProcess(OpenHandle): this cannot happen" - OpenExtHandle ph' job' iocp' -> do + OpenExtHandle ph' job' -> do closePHANDLE ph' closePHANDLE job' - closePHANDLE iocp' when delegating_ctlc $ endDelegateControlC e return (ClosedHandle e, e) - return e + return e' #else - OpenExtHandle _ _job _iocp -> + OpenExtHandle _ _job -> return $ ExitFailure (-1) #endif where @@ -733,7 +732,7 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do where getHandle :: ProcessHandle__ -> Maybe PHANDLE getHandle (OpenHandle h) = Just h getHandle (ClosedHandle _) = Nothing - getHandle (OpenExtHandle h _ _) = Just h + getHandle (OpenExtHandle h _) = Just h -- If somebody is currently holding the waitpid lock, we don't want to -- accidentally remove the pid from the process table. diff --git a/System/Process/Common.hs b/System/Process/Common.hs index dfdaf8f0..805f684b 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -192,8 +192,6 @@ data ProcessHandle__ = OpenHandle { phdlProcessHandle :: PHANDLE } , phdlJobHandle :: PHANDLE -- ^ the job containing the process and -- its subprocesses - , phdlIocpHandle :: PHANDLE - -- ^ the job's IO Completion Port } | ClosedHandle ExitCode data ProcessHandle diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index 23498f5f..16080e4c 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -22,7 +22,6 @@ 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 @@ -60,11 +59,11 @@ 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 -> PHANDLE -> PHANDLE -> IO ProcessHandle -mkProcessHandle h job io = do - m <- if job == nullPtr && io == nullPtr +mkProcessHandle :: PHANDLE -> PHANDLE -> IO ProcessHandle +mkProcessHandle h job = do + m <- if job == nullPtr then newMVar (OpenHandle h) - else newMVar (OpenExtHandle h job io) + else newMVar (OpenExtHandle h job) _ <- mkWeakMVar m (processHandleFinaliser m) l <- newMVar () return (ProcessHandle m False l) @@ -74,9 +73,8 @@ processHandleFinaliser m = modifyMVar_ m $ \p_ -> do case p_ of OpenHandle ph -> closePHANDLE ph - OpenExtHandle ph job io -> closePHANDLE ph + OpenExtHandle ph job -> closePHANDLE ph >> closePHANDLE job - >> closePHANDLE io _ -> return () return (error "closed process handle") @@ -114,7 +112,6 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp, 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 @@ -145,15 +142,13 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp, .|.(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 phJob <- peek hJob - phIOCP <- peek hIOcpPort - ph <- mkProcessHandle proc_handle phJob phIOCP + ph <- mkProcessHandle proc_handle phJob return ProcRetHandles { hStdInput = hndStdInput , hStdOutput = hndStdOutput , hStdError = hndStdError @@ -187,44 +182,21 @@ 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 + 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 :: 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) +waitForJobCompletion :: PHANDLE -- ^ job handle + -> IO () +waitForJobCompletion job = + throwErrnoIf_ not "waitForJobCompletion" $ c_waitForJobCompletion job -- ---------------------------------------------------------------------------- -- 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 @@ -234,12 +206,7 @@ foreign import WINDOWS_CCONV unsafe "TerminateJobObject" foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block c_waitForJobCompletion :: PHANDLE - -> PHANDLE - -> CUInt - -> Ptr CInt - -> FunPtr (SetterDef) - -> FunPtr (GetterDef) - -> IO CInt + -> IO Bool foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess @@ -255,7 +222,6 @@ foreign import ccall unsafe "runInteractiveProcess" -> CInt -- flags -> Bool -- useJobObject -> Ptr PHANDLE -- Handle to Job - -> Ptr PHANDLE -- Handle to I/O Completion Port -> IO PHANDLE commandToProcess @@ -338,7 +304,7 @@ createPipeInternal = do (do readh <- fdToHandle readfd writeh <- fdToHandle writefd return (readh, writeh)) `onException` (close' readfd >> close' writefd) - + createPipeInternalFd :: IO (FD, FD) createPipeInternalFd = do allocaArray 2 $ \ pfds -> do @@ -365,9 +331,9 @@ interruptProcessGroupOfInternal ph = do case p_ of ClosedHandle _ -> return () _ -> do let h = case p_ of - OpenHandle x -> x - OpenExtHandle x _ _ -> x - _ -> error "interruptProcessGroupOfInternal" + OpenHandle x -> x + OpenExtHandle x _ -> x + _ -> error "interruptProcessGroupOfInternal" #if mingw32_HOST_OS pid <- getProcessId h generateConsoleCtrlEvent cTRL_BREAK_EVENT pid diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 7d76b27a..98e653ee 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -569,29 +569,6 @@ createJob () 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: @@ -629,7 +606,7 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, wchar_t *environment, int fdStdIn, int fdStdOut, int fdStdErr, int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int flags, bool useJobObject, HANDLE *hJob, HANDLE *hIOcpPort) + int flags, bool useJobObject, HANDLE *hJob) { STARTUPINFO sInfo; PROCESS_INFORMATION pInfo; @@ -750,16 +727,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, { 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)) @@ -803,7 +772,6 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, 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; @@ -886,78 +854,49 @@ waitForProcess (ProcHandle handle, int *pret) return -1; } - +// Returns true on success. int -waitForJobCompletion ( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode, setterDef set, getterDef get ) +waitForJobCompletion ( HANDLE hJob ) { - 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)) { - - // If event wasn't meant of us, keep listening. - if ((HANDLE)CompletionKey != hJob) - continue; - - 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; - } - - // Check to see if the child has actually exited. - if (*(DWORD *)pExitCode == STILL_ACTIVE) - waitForProcess ((ProcHandle)pHwnd, pExitCode); - } - break; - case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO: - // All processes in the tree are done. - return 0; - default: - break; + JOBOBJECT_BASIC_PROCESS_ID_LIST pid_list; + pid_list.NumberOfAssignedProcesses = 1; + + while (true) { + // Find a process in the job... + bool success = QueryInformationJobObject( + hJob, + JobObjectBasicProcessIdList, + &pid_list, + sizeof(JOBOBJECT_BASIC_PROCESS_ID_LIST), + NULL); + + if (pid_list.NumberOfProcessIdsInList == 0) { + // We're done + return true; + } + + HANDLE pHwnd = OpenProcess(SYNCHRONIZE, TRUE, pid_list.ProcessIdList[0]); + if (pHwnd == NULL) { + switch (GetLastError()) { + case ERROR_INVALID_PARAMETER: + // Presumably the process terminated; try again. + continue; + default: + maperrno(); + return false; } - } + } - // 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; - } + // Wait for it to finish... + if (WaitForSingleObject(pHwnd, INFINITE) != WAIT_OBJECT_0) { + maperrno(); + CloseHandle(pHwnd); + return false; + } - return 2; + // The process signalled, loop again to try the next process. + CloseHandle(pHwnd); + } } #endif /* Win32 */ diff --git a/include/runProcess.h b/include/runProcess.h index dff39051..c88187ed 100644 --- a/include/runProcess.h +++ b/include/runProcess.h @@ -86,14 +86,13 @@ extern ProcHandle runInteractiveProcess( wchar_t *cmd, int *pfdStdError, int flags, bool useJobObject, - HANDLE *hJob, - HANDLE *hIOcpPort ); + HANDLE *hJob ); 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 ); +extern int waitForJobCompletion( HANDLE hJob ); #endif From 3f70d019dbb20aab9e016ab961d255f681e7f14e Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Mon, 3 Feb 2020 17:43:17 -0500 Subject: [PATCH 5/7] Document intricacies of exec on Windows --- System/Process.hs | 30 +++++++++++++++++++++++++++++- System/Process/Common.hs | 2 +- 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 3e54f456..690be37d 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -54,12 +54,14 @@ module System.Process ( -- $ctlc-handling -- * Process completion + -- ** Notes about @exec@ on Windows + -- $exec-on-windows waitForProcess, getProcessExitCode, terminateProcess, interruptProcessGroupOf, - -- Interprocess communication + -- * Interprocess communication createPipe, createPipeFd, @@ -394,6 +396,32 @@ processFailedException fun cmd args exit_code = -- For even more detail on this topic, see -- . +-- $exec-on-windows +-- +-- Note that processes which use the POSIX @exec@ system call (e.g. @gcc@) +-- require special care on Windows. Specifically, the @msvcrt@ C runtime used +-- frequently on Windows emulates @exec@ in a non-POSIX compliant manner, where +-- the caller will be terminated (with exit code 0) and execution will continue +-- in a new process. As a result, on Windows it will appear as though a child +-- process which has called @exec@ has terminated despite the fact that the +-- process would still be running on a POSIX-compliant platform. +-- +-- Since many programs do use @exec@, the @process@ library exposes the +-- 'use_process_jobs' flag to make it possible to reliably detect when such a +-- process completes. When this flag is set a 'ProcessHandle' will not be +-- deemed to be \"finished\" until all processes spawned by it have +-- terminated (except those spawned by the child with the +-- @CREATE_BREAKAWAY_FROM_JOB@ @CreateProcess@ flag). +-- +-- Note, however, that, because of platform limitations, the exit code returned +-- by @waitForProcess@ and @getProcessExitCode@ cannot not be relied upon when +-- the child uses @exec@, even when 'use_process_jobs' is used. Specifically, +-- these functions will return the exit code of the *original child* (which +-- always exits with code 0, since it called @exec@), not the exit code of the +-- process which carried on with execution after @exec@. This is different from +-- the behavior prescribed by POSIX but is the best approximation that can be +-- realised under the restrictions of the Windows process model. + -- ----------------------------------------------------------------------------- -- | @readProcess@ forks an external process, reads its standard output diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 805f684b..917c40f8 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -103,7 +103,7 @@ data CreateProcess = CreateProcess{ -- -- @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. + -- to finish before unblocking. On POSIX systems this flag is ignored. See $exec-on-windows for details. -- -- Default: @False@ -- From 5c3afc9c6e60160f2d654a0b1fa6eb5e49eb40fb Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 4 Feb 2020 18:41:50 -0500 Subject: [PATCH 6/7] Grow process list on ERROR_MORE_DATA --- cbits/runProcess.c | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 98e653ee..3098bca2 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -858,30 +858,48 @@ waitForProcess (ProcHandle handle, int *pret) int waitForJobCompletion ( HANDLE hJob ) { - JOBOBJECT_BASIC_PROCESS_ID_LIST pid_list; - pid_list.NumberOfAssignedProcesses = 1; + int process_count = 16; + JOBOBJECT_BASIC_PROCESS_ID_LIST *pid_list = NULL; while (true) { + if (pid_list == NULL) { + pid_list = malloc(sizeof(JOBOBJECT_BASIC_PROCESS_ID_LIST) + sizeof(ULONG_PTR) * process_count); + pid_list->NumberOfAssignedProcesses = process_count; + } + // Find a process in the job... bool success = QueryInformationJobObject( hJob, JobObjectBasicProcessIdList, - &pid_list, + pid_list, sizeof(JOBOBJECT_BASIC_PROCESS_ID_LIST), NULL); - if (pid_list.NumberOfProcessIdsInList == 0) { + if (!success && GetLastError() == ERROR_MORE_DATA) { + process_count *= 2; + free(pid_list); + pid_list = NULL; + continue; + } else if (!success) { + free(pid_list); + maperrno(); + return false; + } + if (pid_list->NumberOfProcessIdsInList == 0) { // We're done + free(pid_list); return true; } - HANDLE pHwnd = OpenProcess(SYNCHRONIZE, TRUE, pid_list.ProcessIdList[0]); + HANDLE pHwnd = OpenProcess(SYNCHRONIZE, TRUE, pid_list->ProcessIdList[0]); if (pHwnd == NULL) { switch (GetLastError()) { case ERROR_INVALID_PARAMETER: + case ERROR_INVALID_HANDLE: // Presumably the process terminated; try again. continue; default: + free(pid_list); maperrno(); return false; } @@ -889,6 +907,7 @@ waitForJobCompletion ( HANDLE hJob ) // Wait for it to finish... if (WaitForSingleObject(pHwnd, INFINITE) != WAIT_OBJECT_0) { + free(pid_list); maperrno(); CloseHandle(pHwnd); return false; From fcdb254e6ba8d0d280da28dd42ffbd1fa0c90a53 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 5 Feb 2020 16:25:53 -0500 Subject: [PATCH 7/7] Add changelog entry for recent process jobs changes --- changelog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/changelog.md b/changelog.md index 2b8db76e..47ba53ee 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,10 @@ ## Unreleased changes +* Fix several bugs on Windows where use of process jobs would result + in the process being prematurely terminated. See + [#168](https://github.com/haskell/process/168). + ## 1.6.7.0 *November 2019* * Fix a race condition on Windows that happens when you use process jobs and one of