diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 140fab6a..18a2482d 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -91,8 +91,6 @@ data CreateProcess = CreateProcess{ 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). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. 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. -- -- @since 1.2.0.0 detach_console :: Bool, -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms. diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index a421df08..d48be8b8 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -171,7 +171,6 @@ runGenProcess_ -> Maybe CLong -- ^ handler for SIGINT -> Maybe CLong -- ^ handler for SIGQUIT -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) --- On Windows, setting delegate_ctlc has no impact runGenProcess_ fun c (Just sig) (Just sig') | isDefaultSignal sig && sig == sig' = createProcess_ fun c { delegate_ctlc = True } runGenProcess_ fun c _ _ = createProcess_ fun c diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index e61d8581..f6c97b2e 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE InterruptibleFFI #-} module System.Process.Windows ( mkProcessHandle @@ -22,6 +23,7 @@ module System.Process.Windows import System.Process.Common import Control.Concurrent import Control.Exception +import Control.Monad import Data.Bits import Foreign.C import Foreign.Marshal @@ -65,14 +67,14 @@ 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 -> IO ProcessHandle -mkProcessHandle h job = do +mkProcessHandle :: PHANDLE -> Bool -> PHANDLE -> IO ProcessHandle +mkProcessHandle h ignore_signals job = do m <- if job == nullPtr then newMVar (OpenHandle h) else newMVar (OpenExtHandle h job) _ <- mkWeakMVar m (processHandleFinaliser m) l <- newMVar () - return (ProcessHandle m False l) + return (ProcessHandle m ignore_signals l) processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m = @@ -114,7 +116,6 @@ createProcess_Internal_mio fun def@CreateProcess{ std_err = mb_stderr, close_fds = mb_close_fds, create_group = mb_create_group, - delegate_ctlc = _ignored, detach_console = mb_detach_console, create_new_console = mb_create_new_console, new_session = mb_new_session, @@ -166,7 +167,7 @@ createProcess_Internal_wrapper _fun CreateProcess{ cmdspec = cmdsp, cwd = mb_cwd, env = mb_env, - delegate_ctlc = _ignored } + delegate_ctlc = ignore_signals } action = do let lenPtr = sizeOf (undefined :: WordPtr) @@ -183,8 +184,15 @@ createProcess_Internal_wrapper _fun CreateProcess{ (proc_handle, hndStdInput, hndStdOutput, hndStdError) <- action pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline + -- If we have successfully created the process then check if we have to + -- detach from the console. I'm not sure why the posix version changes + -- the state right before creating the child process, but doing so here + -- means the first child also inherits this + when ignore_signals $ + startDelegateControlC + phJob <- peek hJob - ph <- mkProcessHandle proc_handle phJob + ph <- mkProcessHandle proc_handle ignore_signals phJob return ProcRetHandles { hStdInput = hndStdInput , hStdOutput = hndStdOutput , hStdError = hndStdError @@ -203,7 +211,6 @@ createProcess_Internal_winio fun def@CreateProcess{ std_err = mb_stderr, close_fds = mb_close_fds, create_group = mb_create_group, - delegate_ctlc = _ignored, detach_console = mb_detach_console, create_new_console = mb_create_new_console, new_session = mb_new_session, @@ -260,18 +267,71 @@ createProcess_Internal_winio fun def@CreateProcess{ runInteractiveProcess_lock :: MVar () runInteractiveProcess_lock = unsafePerformIO $ newMVar () --- The following functions are always present in the export list. For --- compatibility with the non-Windows code, we provide the same functions with --- matching type signatures, but implemented as no-ops. For details, see: --- +-- ---------------------------------------------------------------------------- +-- Delegated control-C handling on Windows + +-- See https://learn.microsoft.com/en-us/windows/console/setconsolectrlhandler +-- +-- 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 CTRL_C_EVENT/CTRL_BREAK_EVENT Windows +-- events while we're running such programs. +-- +-- 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. +-- +-- To do this we have to use SetConsoleCtrlHandler which masks the events for +-- the current process and any child it creates from that point. +-- +-- In this case we can't use FreeConsole/AttachConsole since those destroy +-- the signal handler stack for the application when called. This means we'd +-- have to recreate them and process doesn't know what's there. + +{-# NOINLINE runInteractiveProcess_delegate_ctlc #-} +runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int)) +runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing + startDelegateControlC :: IO () -startDelegateControlC = return () +startDelegateControlC = + modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do + case delegating of + Nothing -> do + -- 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. + _ <- c_setConsoleCtrlHandler nullPtr True + return (Just 1) + + Just count -> do + -- If we're already doing it, just increment the count + let !count' = count + 1 + return (Just count') + +stopDelegateControlC :: IO () +stopDelegateControlC = + modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do + case delegating of + Just 1 -> do + -- Last process, so restore the old signal handlers + _ <- c_setConsoleCtrlHandler nullPtr False + return Nothing + + Just count -> do + -- Not the last, just decrement the count + let !count' = count - 1 + return (Just count') + + Nothing -> return Nothing -- should be impossible endDelegateControlC :: ExitCode -> IO () -endDelegateControlC _ = return () +-- I don't think there's a standard exit code for program interruptions +-- on Windows, so I'll just ignore it for now. +endDelegateControlC _ = stopDelegateControlC -stopDelegateControlC :: IO () -stopDelegateControlC = return () -- End no-op functions @@ -308,6 +368,12 @@ foreign import WINDOWS_CCONV unsafe "TerminateJobObject" -> CUInt -> IO Bool +foreign import WINDOWS_CCONV unsafe "SetConsoleCtrlHandler" + c_setConsoleCtrlHandler + :: Ptr () + -> Bool + -> IO Bool + foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block c_waitForJobCompletion :: PHANDLE diff --git a/changelog.md b/changelog.md index 02dd7740..88d05970 100644 --- a/changelog.md +++ b/changelog.md @@ -3,6 +3,7 @@ ## unreleased * Fix deadlock when waiting for process completion and process jobs [#273](https://github.com/haskell/process/issues/273) +* Support delegate_ctlc on Windows. [#278](https://github.com/haskell/process/pull/278) ## 1.6.17.0 *February 2023*