process 1.6.7.0 → 1.6.8.0
raw patch · 7 files changed
+160/−181 lines, 7 files
Files
- System/Process.hs +71/−26
- System/Process/Common.hs +8/−3
- System/Process/Windows.hsc +18/−52
- cbits/runProcess.c +54/−96
- changelog.md +6/−0
- include/runProcess.h +2/−3
- process.cabal +1/−1
System/Process.hs view
@@ -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 -- <http://www.cons.org/cracauer/sigint.html "Proper handling of SIGINT/SIGQUIT">. +-- $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.
System/Process/Common.hs view
@@ -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__)
System/Process/Windows.hsc view
@@ -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
cbits/runProcess.c view
@@ -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 */
changelog.md view
@@ -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
include/runProcess.h view
@@ -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
process.cabal view
@@ -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