Merge pull request #278 from Mistuke/wip/implement-delegate-ctrl-windows

Windows: Implement delegate_ctlc on Windows

Author: snoyberg

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.

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

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:
--- <https://github.com/haskell/process/pull/21>
+-- ----------------------------------------------------------------------------
+-- 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

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*