Commit a0467f3e authored by Duncan Coutts's avatar Duncan Coutts Committed by Herbert Valerio Riedel
Browse files

Implement delegated control-C handling on Unix (#2301)

This is a generalisation of the SIGINT-ignoring that system and
rawSystem do, to allow it to be used via the general createProcess.

For the gory details of SIGINT handling, see
http://www.cons.org/cracauer/sigint.html



We implement the 'WCE' method described there.

That important feature was only available to system and rawSystem
(mirroring the C system() behaviour). These functions are very limited
and indeed deprecated, so we need this feature in general. In particular
projects like Cabal are suffering because they cannot do this properly
(or need horrible workarounds copy and pasting much of System.Process
and using System.Process.Internals).

The feature is available now via a new delegate_ctlc flag in the
CreateProcess options record. The use of signal handlers is still a
little hairy, but probably better than before (for situations where
there were multiple concurrent calls to system/rawSystem).

One thing to note is that waitForProcess and getProcessExitCode can now
throw the UserInterrupt exception.

This is all documented in the haddock docs (both a short description and
also the excruciating details).
Authored-by: Duncan Coutts's avatarDuncan Coutts <duncan@well-typed.com>
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parent 3ebbe13a
......@@ -56,6 +56,9 @@ module System.Process (
rawSystem,
showCommandForUser,
-- ** Control-C handling on Unix
-- $ctlc-handling
#ifndef __HUGS__
-- * Process completion
waitForProcess,
......@@ -113,7 +116,7 @@ runCommand
-> IO ProcessHandle
runCommand string = do
(_,_,_,ph) <- runGenProcess_ "runCommand" (shell string) Nothing Nothing
(_,_,_,ph) <- runGenProcess_ "runCommand" (shell string)
return ph
-- ----------------------------------------------------------------------------
......@@ -148,7 +151,6 @@ runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do
std_in = mbToStd mb_stdin,
std_out = mbToStd mb_stdout,
std_err = mbToStd mb_stderr }
Nothing Nothing
maybeClose mb_stdin
maybeClose mb_stdout
maybeClose mb_stderr
......@@ -193,7 +195,8 @@ proc cmd args = CreateProcess { cmdspec = RawCommand cmd args,
std_out = Inherit,
std_err = Inherit,
close_fds = False,
create_group = False}
create_group = False,
delegate_ctlc = False}
-- | Construct a 'CreateProcess' record for passing to 'createProcess',
-- representing a command to be passed to the shell.
......@@ -205,7 +208,8 @@ shell str = CreateProcess { cmdspec = ShellCommand str,
std_out = Inherit,
std_err = Inherit,
close_fds = False,
create_group = False}
create_group = False,
delegate_ctlc = False}
{- |
This is the most general way to spawn an external process. The
......@@ -251,7 +255,7 @@ createProcess
:: CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess cp = do
r <- runGenProcess_ "createProcess" cp Nothing Nothing
r <- runGenProcess_ "createProcess" cp
maybeCloseStd (std_in cp)
maybeCloseStd (std_out cp)
maybeCloseStd (std_err cp)
......@@ -262,6 +266,50 @@ createProcess cp = do
| hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl
maybeCloseStd _ = return ()
-- $ctlc-handling
--
-- When running an interactive console process (such as a shell, console-based
-- text editor or ghci), we typically want that process to be allowed to handle
-- Ctl-C keyboard interrupts how it sees fit. For example, while most programs
-- simply quit on a Ctl-C, some handle it specially. To allow this to happen,
-- use the @'delegate_ctlc' = True@ option in the 'CreateProcess' options.
--
-- The gory details:
--
-- By default Ctl-C will generate a @SIGINT@ signal, causing a 'UserInterrupt'
-- exception to be sent to the main Haskell thread of your program, which if
-- not specially handled will terminate the program. Normally, this is exactly
-- what is wanted: an orderly shutdown of the program in response to Ctl-C.
--
-- Of course when running another interactive program in the console then we
-- want to let that program handle Ctl-C. Under Unix however, Ctl-C sends
-- @SIGINT@ to every process using the console. The standard solution is that
-- while running an interactive program, ignore @SIGINT@ in the parent, and let
-- it be handled in the child process. If that process then terminates due to
-- the @SIGINT@ signal, then at that point treat it as if we had recieved the
-- @SIGINT@ ourselves and begin an orderly shutdown.
--
-- This behaviour is implemented by 'createProcess' (and
-- 'waitForProcess' \/ 'getProcessExitCode') when the @'delegate_ctlc' = True@
-- option is set. In particular, the @SIGINT@ signal will be ignored until
-- 'waitForProcess' returns (or 'getProcessExitCode' returns a non-Nothing
-- result), so it becomes especially important to use 'waitForProcess' for every
-- processes created.
--
-- In addition, in 'delegate_ctlc' mode, 'waitForProcess' and
-- 'getProcessExitCode' will throw a 'UserInterrupt' exception if the process
-- terminated with @ExitFailure (-SIGINT)@. Typically you will not want to
-- catch this exception, but let it propagate, giving a normal orderly shutdown.
-- One detail to be aware of is that the 'UserInterrupt' exception is thrown
-- /synchronously/ in the thread that calls 'waitForProcess', whereas normally
-- @SIGINT@ causes the exception to be thrown /asynchronously/ to the main
-- thread.
--
-- For even more detail on this topic, see
-- <http://www.cons.org/cracauer/sigint.html>.
-- ----------------------------------------------------------------------------
-- runInteractiveCommand
......@@ -312,7 +360,6 @@ runInteractiveProcess1 fun cmd = do
cmd{ std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe }
Nothing Nothing
return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)
-- ----------------------------------------------------------------------------
......@@ -335,7 +382,7 @@ detail.
waitForProcess
:: ProcessHandle
-> IO ExitCode
waitForProcess ph = do
waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do
p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_)
case p_ of
ClosedHandle e -> return e
......@@ -343,7 +390,7 @@ waitForProcess ph = do
-- don't hold the MVar while we call c_waitForProcess...
-- (XXX but there's a small race window here during which another
-- thread could close the handle or call waitForProcess)
alloca $ \pret -> do
e <- alloca $ \pret -> do
throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
modifyProcessHandle ph $ \p_' ->
case p_' of
......@@ -355,6 +402,9 @@ waitForProcess ph = do
then ExitSuccess
else (ExitFailure (fromIntegral code))
return (ClosedHandle e, e)
when delegating_ctlc $
endDelegateControlC e
return e
-- -----------------------------------------------------------------------------
--
......@@ -531,31 +581,9 @@ when the process died as the result of a signal.
#ifdef __GLASGOW_HASKELL__
system :: String -> IO ExitCode
system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
system str = syncProcess "system" (shell str)
syncProcess :: String -> CreateProcess -> IO ExitCode
#if mingw32_HOST_OS
syncProcess _fun c = do
(_,_,_,p) <- createProcess c
system str = do
(_,_,_,p) <- runGenProcess_ "system" (shell str) { delegate_ctlc = True }
waitForProcess p
#else
syncProcess fun c = do
-- The POSIX version of system needs to do some manipulation of signal
-- handlers. Since we're going to be synchronously waiting for the child,
-- we want to ignore ^C in the parent, but handle it the default way
-- in the child (using SIG_DFL isn't really correct, it should be the
-- original signal handler, but the GHC RTS will have already set up
-- its own handler and we don't want to use that).
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
(_,_,_,p) <- runGenProcess_ fun c
(Just defaultSignal) (Just defaultSignal)
r <- waitForProcess p
_ <- installHandler sigINT old_int Nothing
_ <- installHandler sigQUIT old_quit Nothing
return r
#endif /* mingw32_HOST_OS */
#endif /* __GLASGOW_HASKELL__ */
{-|
......@@ -568,7 +596,9 @@ The return codes and possible failures are the same as for 'system'.
-}
rawSystem :: String -> [String] -> IO ExitCode
#ifdef __GLASGOW_HASKELL__
rawSystem cmd args = syncProcess "rawSystem" (proc cmd args)
rawSystem cmd args = do
(_,_,_,p) <- runGenProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True }
waitForProcess p
#elif !mingw32_HOST_OS
-- crude fallback implementation: could do much better than this under Unix
rawSystem cmd args = system (showCommandForUser cmd args)
......@@ -657,22 +687,26 @@ when the process died as the result of a signal.
-}
getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ph = do
modifyProcessHandle ph $ \p_ ->
getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do
(m_e, was_open) <- modifyProcessHandle ph $ \p_ ->
case p_ of
ClosedHandle e -> return (p_, Just e)
ClosedHandle e -> return (p_, (Just e, False))
OpenHandle h ->
alloca $ \pExitCode -> do
res <- throwErrnoIfMinus1Retry "getProcessExitCode" $
c_getProcessExitCode h pExitCode
code <- peek pExitCode
if res == 0
then return (p_, Nothing)
then return (p_, (Nothing, False))
else do
closePHANDLE h
let e | code == 0 = ExitSuccess
| otherwise = ExitFailure (fromIntegral code)
return (ClosedHandle e, Just e)
return (ClosedHandle e, (Just e, True))
case m_e of
Just e | was_open && delegating_ctlc -> endDelegateControlC e
_ -> return ()
return m_e
-- ----------------------------------------------------------------------------
-- Interface to C bits
......
{-# LANGUAGE CPP, ForeignFunctionInterface, RecordWildCards #-}
{-# LANGUAGE CPP, ForeignFunctionInterface, RecordWildCards, BangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE InterruptibleFFI #-}
#endif
-----------------------------------------------------------------------------
......@@ -27,6 +28,8 @@ module System.Process.Internals (
CmdSpec(..), StdStream(..),
runGenProcess_,
#endif
startDelegateControlC,
endDelegateControlC,
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
pPrPr_disableITimers, c_execvpe,
ignoreSignal, defaultSignal,
......@@ -61,12 +64,14 @@ import qualified GHC.IO.FD as FD
import GHC.IO.Device
import GHC.IO.Handle.FD
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import GHC.IO.Handle.Types hiding (ClosedHandle)
import System.IO.Error
import Data.Typeable
#if defined(mingw32_HOST_OS)
import GHC.IO.IOMode
import System.Win32.DebugApi (PHANDLE)
#else
import System.Posix.Signals as Sig
#endif
#endif
......@@ -100,28 +105,28 @@ import System.FilePath
to wait for the process later.
-}
data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode
newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__)
data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool
modifyProcessHandle
:: ProcessHandle
-> (ProcessHandle__ -> IO (ProcessHandle__, a))
-> IO a
modifyProcessHandle (ProcessHandle m) io = modifyMVar m io
modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io
withProcessHandle
:: ProcessHandle
-> (ProcessHandle__ -> IO a)
-> IO a
withProcessHandle (ProcessHandle m) io = withMVar m io
withProcessHandle (ProcessHandle m _) io = withMVar m io
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
type PHANDLE = CPid
mkProcessHandle :: PHANDLE -> IO ProcessHandle
mkProcessHandle p = do
mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle
mkProcessHandle p mb_delegate_ctlc = do
m <- newMVar (OpenHandle p)
return (ProcessHandle m)
return (ProcessHandle m mb_delegate_ctlc)
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE _ = return ()
......@@ -137,7 +142,7 @@ mkProcessHandle :: PHANDLE -> IO ProcessHandle
mkProcessHandle h = do
m <- newMVar (OpenHandle h)
_ <- mkWeakMVar m (processHandleFinaliser m)
return (ProcessHandle m)
return (ProcessHandle m False)
processHandleFinaliser :: MVar ProcessHandle__ -> IO ()
processHandleFinaliser m =
......@@ -166,7 +171,10 @@ data CreateProcess = CreateProcess{
std_out :: StdStream, -- ^ How to determine stdout
std_err :: StdStream, -- ^ How to determine stderr
close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit)
create_group :: Bool -- ^ Create a new process group
create_group :: Bool, -- ^ Create a new process group
delegate_ctlc:: Bool -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).
--
-- On Windows this has no effect.
}
data CmdSpec
......@@ -188,8 +196,6 @@ data StdStream
runGenProcess_
:: String -- ^ function name (for error messages)
-> CreateProcess
-> Maybe CLong -- ^ handler for SIGINT
-> Maybe CLong -- ^ handler for SIGQUIT
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
......@@ -206,8 +212,8 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
std_out = mb_stdout,
std_err = mb_stderr,
close_fds = mb_close_fds,
create_group = mb_create_group }
mb_sigint mb_sigquit
create_group = mb_create_group,
delegate_ctlc = mb_delegate_ctlc }
= do
let (cmd,args) = commandToProcess cmdsp
withFilePathException cmd $
......@@ -224,14 +230,8 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
fdout <- mbFd fun fd_stdout mb_stdout
fderr <- mbFd fun fd_stderr mb_stderr
let (set_int, inthand)
= case mb_sigint of
Nothing -> (0, 0)
Just hand -> (1, hand)
(set_quit, quithand)
= case mb_sigquit of
Nothing -> (0, 0)
Just hand -> (1, hand)
when mb_delegate_ctlc
startDelegateControlC
-- runInteractiveProcess() blocks signals around the fork().
-- Since blocking/unblocking of signals is a global state
......@@ -241,7 +241,7 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
c_runInteractiveProcess pargs pWorkDir pEnv
fdin fdout fderr
pfdStdInput pfdStdOutput pfdStdError
set_int inthand set_quit quithand
(if mb_delegate_ctlc then 1 else 0)
((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
.|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0))
pFailedDoing
......@@ -255,13 +255,89 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
hndStdError <- mbPipe mb_stderr pfdStdError ReadMode
ph <- mkProcessHandle proc_handle
ph <- mkProcessHandle proc_handle mb_delegate_ctlc
return (hndStdInput, hndStdOutput, hndStdError, ph)
{-# NOINLINE runInteractiveProcess_lock #-}
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()
-- ----------------------------------------------------------------------------
-- Delegated control-C handling on Unix
-- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301
-- and http://www.cons.org/cracauer/sigint.html
--
-- While running an interactive console process like ghci or a shell, we want
-- to let that process handle Ctl-C keyboard interrupts how it sees fit.
-- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're
-- running such programs. And then if/when they do terminate, we need to check
-- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we
-- got the Ctl-C then, by throwing the UserInterrupt exception.
--
-- If we run multiple programs like this concurrently then we have to be
-- careful to avoid messing up the signal handlers. We keep a count and only
-- restore when the last one has finished.
{-# NOINLINE runInteractiveProcess_delegate_ctlc #-}
runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))
runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing
startDelegateControlC :: IO ()
startDelegateControlC =
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.
--
-- If another thread runs another process without using
-- delegation while we're doing this then it will inherit the
-- ignore ^C status.
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
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
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
-- And if the process did die due to SIGINT or SIGQUIT then
-- we throw our equivalent exception here (synchronously).
--
-- An alternative design would be to throw to the main thread, as the
-- normal signal handler does. But since we can be sync here, we do so.
-- It allows the code locally to catch it and do something.
case exitCode of
ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt
_ -> return ()
where
isSigIntQuit n = sig == sigINT || sig == sigQUIT
where
sig = fromIntegral (-n)
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
:: Ptr CString
......@@ -273,10 +349,7 @@ foreign import ccall unsafe "runInteractiveProcess"
-> Ptr FD
-> Ptr FD
-> Ptr FD
-> CInt -- non-zero: set child's SIGINT handler
-> CLong -- SIGINT handler
-> CInt -- non-zero: set child's SIGQUIT handler
-> CLong -- SIGQUIT handler
-> CInt -- reset child's SIGINT & SIGQUIT handlers
-> CInt -- flags
-> Ptr CString
-> IO PHANDLE
......@@ -298,8 +371,8 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
std_out = mb_stdout,
std_err = mb_stderr,
close_fds = mb_close_fds,
create_group = mb_create_group }
_ignored_mb_sigint _ignored_mb_sigquit
create_group = mb_create_group,
delegate_ctlc = _ignored }
= do
(cmd, cmdline) <- commandToProcess cmdsp
withFilePathException cmd $
......@@ -343,6 +416,12 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()
startDelegateControlC :: IO ()
startDelegateControlC = return ()
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC _ = return ()
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
:: CWString
......
......@@ -57,8 +57,7 @@ runInteractiveProcess (char *const args[],
char *workingDirectory, char **environment,
int fdStdIn, int fdStdOut, int fdStdErr,
int *pfdStdInput, int *pfdStdOutput, int *pfdStdError,
int set_inthandler, long inthandler,
int set_quithandler, long quithandler,
int reset_int_quit_handlers,
int flags,
char **failed_doing)
{
......@@ -205,20 +204,15 @@ runInteractiveProcess (char *const args[],
}
}
/* Set the SIGINT/SIGQUIT signal handlers in the child, if requested
/* Reset the SIGINT/SIGQUIT signal handlers in the child, if requested
*/
{
if (reset_int_quit_handlers) {
struct sigaction dfl;
(void)sigemptyset(&dfl.sa_mask);
dfl.sa_flags = 0;
if (set_inthandler) {
dfl.sa_handler = (void *)inthandler;
(void)sigaction(SIGINT, &dfl, NULL);
}
if (set_quithandler) {
dfl.sa_handler = (void *)quithandler;
(void)sigaction(SIGQUIT, &dfl, NULL);
}
dfl.sa_handler = SIG_DFL;
(void)sigaction(SIGINT, &dfl, NULL);
(void)sigaction(SIGQUIT, &dfl, NULL);
}
/* the child */
......
......@@ -62,8 +62,7 @@ extern ProcHandle runInteractiveProcess( char *const args[],
int *pfdStdInput,
int *pfdStdOutput,
int *pfdStdError,
int set_inthandler, long inthandler,
int set_quithandler, long quithandler,
int reset_int_quit_handlers,
int flags,
char **failed_doing);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment