diff --git a/System/Process.hsc b/System/Process.hsc --- a/System/Process.hsc +++ b/System/Process.hsc @@ -236,7 +236,8 @@ cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () -cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, + ph@(ProcessHandle _ delegating_ctlc)) = do terminateProcess ph -- Note, it's important that other threads that might be reading/writing -- these handles also get killed off, since otherwise they might be holding @@ -248,9 +249,16 @@ -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee -- that it stops. If it doesn't stop, we don't want to hang, so we wait -- asynchronously using forkIO. - _ <- forkIO (waitForProcess ph >> return ()) - return () + -- However we want to end the Ctl-C handling synchronously, so we'll do + -- that synchronously, and set delegating_ctlc as False for the + -- waitForProcess (which would otherwise end the Ctl-C delegation itself). + when delegating_ctlc + stopDelegateControlC + _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) + return () + where + resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False -- ---------------------------------------------------------------------------- -- spawnProcess/spawnCommand @@ -372,17 +380,18 @@ -- | @readProcess@ forks an external process, reads its standard output -- strictly, blocking until the process terminates, and returns the output --- string. +-- string. The external process inherits the standard error. -- -- If an asynchronous exception is thrown to the thread executing --- @readProcess@. The forked process will be terminated and @readProcess@ will +-- @readProcess@, the forked process will be terminated and @readProcess@ will -- wait (block) until the process has been terminated. -- -- Output is returned strictly, so this is not suitable for -- interactive applications. -- -- This function throws an 'IOError' if the process 'ExitCode' is --- anything other than 'ExitSuccess'. +-- anything other than 'ExitSuccess'. If instead you want to get the +-- 'ExitCode' then use 'readProcessWithExitCode'. -- -- Users of this function should compile with @-threaded@ if they -- want other Haskell threads to keep running while waiting on @@ -435,26 +444,17 @@ ExitSuccess -> return output ExitFailure r -> processFailedException "readProcess" cmd args r -{- | -@readProcessWithExitCode@ creates an external process, reads its -standard output and standard error strictly, waits until the process -terminates, and then returns the 'ExitCode' of the process, -the standard output, and the standard error. - -If an asynchronous exception is thrown to the thread executing -@readProcessWithExitCode@. The forked process will be terminated and -@readProcessWithExitCode@ will wait (block) until the process has been -terminated. - -'readProcess' and 'readProcessWithExitCode' are fairly simple wrappers -around 'createProcess'. Constructing variants of these functions is -quite easy: follow the link to the source code to see how -'readProcess' is implemented. - -On Unix systems, see 'waitForProcess' for the meaning of exit codes -when the process died as the result of a signal. --} - +-- | @readProcessWithExitCode@ is like @readProcess@ but with two differences: +-- +-- * it returns the 'ExitCode' of the process, and does not throw any +-- exception if the code is not 'ExitSuccess'. +-- +-- * it reads and returns the output from process' standard error handle, +-- rather than the process inheriting the standard error handle. +-- +-- On Unix systems, see 'waitForProcess' for the meaning of exit codes +-- when the process died as the result of a signal. +-- readProcessWithExitCode :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) -> [String] -- ^ any arguments diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -33,6 +33,7 @@ #endif startDelegateControlC, endDelegateControlC, + stopDelegateControlC, #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) pPrPr_disableITimers, c_execvpe, ignoreSignal, defaultSignal, @@ -293,6 +294,8 @@ when (proc_handle == -1) $ do cFailedDoing <- peek pFailedDoing failedDoing <- peekCString cFailedDoing + when mb_delegate_ctlc + stopDelegateControlC throwErrno (fun ++ ": " ++ failedDoing) hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode @@ -332,7 +335,6 @@ modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do case delegating of Nothing -> do --- print ("startDelegateControlC", "Nothing") -- We're going to ignore ^C in the parent while there are any -- processes using ^C delegation. -- @@ -344,29 +346,30 @@ return (Just (1, old_int, old_quit)) Just (count, old_int, old_quit) -> do --- print ("startDelegateControlC", count) -- If we're already doing it, just increment the count let !count' = count + 1 return (Just (count', old_int, old_quit)) -endDelegateControlC :: ExitCode -> IO () -endDelegateControlC exitCode = do +stopDelegateControlC :: IO () +stopDelegateControlC = modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do case delegating of Just (1, old_int, old_quit) -> do --- print ("endDelegateControlC", exitCode, 1 :: Int) -- Last process, so restore the old signal handlers _ <- installHandler sigINT old_int Nothing _ <- installHandler sigQUIT old_quit Nothing return Nothing Just (count, old_int, old_quit) -> do --- print ("endDelegateControlC", exitCode, count) -- Not the last, just decrement the count let !count' = count - 1 return (Just (count', old_int, old_quit)) Nothing -> return Nothing -- should be impossible + +endDelegateControlC :: ExitCode -> IO () +endDelegateControlC exitCode = do + stopDelegateControlC -- And if the process did die due to SIGINT or SIGQUIT then -- we throw our equivalent exception here (synchronously). diff --git a/cbits/runProcess.c b/cbits/runProcess.c --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -288,6 +288,11 @@ // get the errno of whatever else went wrong instead. errno = err; } + + // We forked the child, but the child had a problem and stopped so it's + // our responsibility to reap here as nobody else can. + waitpid(pid, NULL, 0); + pid = -1; } else if (r != 0) { diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,14 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.2.2.0 *Jan 2015* + + * Fix delegated CTRL-C handling in `createProcess` in case of failed + process creation. See [issue #15](https://github.com/haskell/process/issues/15) + for more details. + + * `waitpid` on child PID after pre-exec failure in child to prevent zombies. + See also [issue #14](https://github.com/haskell/process/issues/14). + ## 1.2.1.0 *Dec 2014* * Add support for `base-4.8.0.0` diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.2.1.0 +version: 1.2.2.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE