diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -54,12 +54,14 @@ -- $ctlc-handling -- * Process completion + -- ** Notes about @exec@ on Windows + -- $exec-on-windows waitForProcess, getProcessExitCode, terminateProcess, interruptProcessGroupOf, - -- Interprocess communication + -- * Interprocess communication createPipe, createPipeFd, @@ -188,7 +190,7 @@ To also set the directory in which to run @ls@: > (_, Just hout, _, _) <- -> createProcess (proc "ls" []){ cwd = Just "\home\bob", +> createProcess (proc "ls" []){ cwd = Just "/home/bob", > std_out = CreatePipe } Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the @@ -394,6 +396,32 @@ -- 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 @@ -436,7 +464,7 @@ -- | @readCreateProcess@ works exactly like 'readProcess' except that it -- lets you pass 'CreateProcess' giving better flexibility. -- --- > > readCreateProcess (shell "pwd" { cwd = "/etc/" }) "" +-- > > readCreateProcess ((shell "pwd") { cwd = Just "/etc/" }) "" -- > "/etc\n" -- -- Note that @Handle@s provided for @std_in@ or @std_out@ via the CreateProcess @@ -642,30 +670,36 @@ 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 -> do + -- First wait for completion of the job... + 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' -> do + closePHANDLE ph' + closePHANDLE job' + when delegating_ctlc $ + endDelegateControlC e + return (ClosedHandle e, e) + return e' #else - OpenExtHandle _ _job _iocp -> + OpenExtHandle _ _job -> return $ ExitFailure (-1) #endif where @@ -676,6 +710,17 @@ -- 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 @@ -715,7 +760,7 @@ 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 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -103,7 +103,7 @@ -- -- @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@ -- @@ -186,8 +186,13 @@ 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 + } | ClosedHandle ExitCode data ProcessHandle = ProcessHandle { phandle :: !(MVar ProcessHandle__) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -22,7 +22,6 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ .|.(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 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 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 @@ -> CInt -- flags -> Bool -- useJobObject -> Ptr PHANDLE -- Handle to Job - -> Ptr PHANDLE -- Handle to I/O Completion Port -> IO PHANDLE commandToProcess @@ -338,7 +304,7 @@ (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 @@ 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 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -569,29 +569,6 @@ 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 @@ 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 @@ { 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 @@ 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,68 @@ 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; + int process_count = 16; + JOBOBJECT_BASIC_PROCESS_ID_LIST *pid_list = NULL; - // 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)) { + 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; + } - // If event wasn't meant of us, keep listening. - if ((HANDLE)CompletionKey != hJob) - continue; + // Find a process in the job... + bool success = QueryInformationJobObject( + hJob, + JobObjectBasicProcessIdList, + pid_list, + sizeof(JOBOBJECT_BASIC_PROCESS_ID_LIST), + NULL); - 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; - } + 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; + } - // 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; + 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; } - } + } - // 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) { + free(pid_list); + maperrno(); + CloseHandle(pHwnd); + return false; + } - return 0; + // The process signalled, loop again to try the next process. + CloseHandle(pHwnd); + } } #endif /* Win32 */ diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.8.0 *February 2020* + +* 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 diff --git a/include/runProcess.h b/include/runProcess.h --- a/include/runProcess.h +++ b/include/runProcess.h @@ -86,14 +86,13 @@ 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 diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.6.7.0 +version: 1.6.8.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE