{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module System.Process.Posix
    ( mkProcessHandle
    , translateInternal
    , createProcess_Internal
    , withCEnvironment
    , closePHANDLE
    , startDelegateControlC
    , endDelegateControlC
    , stopDelegateControlC
    , isDefaultSignal
    , ignoreSignal
    , defaultSignal
    , c_execvpe
    , pPrPr_disableITimers
    , createPipeInternal
    , createPipeInternalFd
    , interruptProcessGroupOfInternal
    , runInteractiveProcess_lock
    ) where

import Control.Concurrent
import Control.Exception
import Data.Bits
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

import Control.Monad
import Data.Char
import System.IO
import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )
import System.Posix.Types

import System.Posix.Internals
import GHC.IO.Exception
import System.Posix.Signals as Sig
import qualified System.Posix.IO as Posix
import System.Posix.Process (getProcessGroupIDOf)

import System.Process.Common hiding (mb_delegate_ctlc)

#include "HsProcessConfig.h"
#include "processFlags.h"

mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle
mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle
mkProcessHandle PHANDLE
p Bool
mb_delegate_ctlc = do
  MVar ProcessHandle__
m <- ProcessHandle__ -> IO (MVar ProcessHandle__)
forall a. a -> IO (MVar a)
newMVar (PHANDLE -> ProcessHandle__
OpenHandle PHANDLE
p)
  MVar ()
l <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  ProcessHandle -> IO ProcessHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar ProcessHandle__ -> Bool -> MVar () -> ProcessHandle
ProcessHandle MVar ProcessHandle__
m Bool
mb_delegate_ctlc MVar ()
l)

closePHANDLE :: PHANDLE -> IO ()
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE PHANDLE
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ----------------------------------------------------------------------------
-- commandToProcess

{- | Turns a shell command into a raw command.  Usually this involves
     wrapping it in an invocation of the shell.

   There's a difference in the signature of commandToProcess between
   the Windows and Unix versions.  On Unix, exec takes a list of strings,
   and we want to pass our command to /bin/sh as a single argument.

   On Windows, CreateProcess takes a single string for the command,
   which is later decomposed by cmd.exe.  In this case, we just want
   to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line.  The
   command-line translation that we normally do for arguments on
   Windows isn't required (or desirable) here.
-}

commandToProcess :: CmdSpec -> (FilePath, [String])
commandToProcess :: CmdSpec -> (FilePath, [FilePath])
commandToProcess (ShellCommand FilePath
string) = (FilePath
"/bin/sh", [FilePath
"-c", FilePath
string])
commandToProcess (RawCommand FilePath
cmd [FilePath]
args) = (FilePath
cmd, [FilePath]
args)

translateInternal :: String -> String
translateInternal :: FilePath -> FilePath
translateInternal FilePath
"" = FilePath
"''"
translateInternal FilePath
str
   -- goodChar is a pessimistic predicate, such that if an argument is
   -- non-empty and only contains goodChars, then there is no need to
   -- do any quoting or escaping
 | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
goodChar FilePath
str = FilePath
str
 | Bool
otherwise        = Char
'\'' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (Char -> FilePath -> FilePath) -> FilePath -> FilePath -> FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> FilePath -> FilePath
escape FilePath
"'" FilePath
str
  where escape :: Char -> FilePath -> FilePath
escape Char
'\'' = FilePath -> FilePath -> FilePath
showString FilePath
"'\\''"
        escape Char
c    = Char -> FilePath -> FilePath
showChar Char
c
        goodChar :: Char -> Bool
goodChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
"-_.,/"

-- ----------------------------------------------------------------------------
-- Utils

withCEnvironment :: [(String,String)] -> (Ptr CString  -> IO a) -> IO a
withCEnvironment :: [(FilePath, FilePath)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment [(FilePath, FilePath)]
envir Ptr CString -> IO a
act =
  let env' :: [FilePath]
env' = ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\(FilePath
name, FilePath
val) -> FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Char
'='Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
val)) [(FilePath, FilePath)]
envir
  in (FilePath -> (CString -> IO a) -> IO a)
-> [FilePath] -> ([CString] -> IO a) -> IO a
forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany FilePath -> (CString -> IO a) -> IO a
forall a. FilePath -> (CString -> IO a) -> IO a
withFilePath [FilePath]
env' (\[CString]
pEnv -> CString -> [CString] -> (Ptr CString -> IO a) -> IO a
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 CString
forall a. Ptr a
nullPtr [CString]
pEnv Ptr CString -> IO a
act)

-- -----------------------------------------------------------------------------
-- POSIX runProcess with signal handling in the child

createProcess_Internal
    :: String
    -> CreateProcess
    -> IO ProcRetHandles
createProcess_Internal :: FilePath -> CreateProcess -> IO ProcRetHandles
createProcess_Internal FilePath
fun
                   CreateProcess{ cmdspec :: CreateProcess -> CmdSpec
cmdspec = CmdSpec
cmdsp,
                                  cwd :: CreateProcess -> Maybe FilePath
cwd = Maybe FilePath
mb_cwd,
                                  env :: CreateProcess -> Maybe [(FilePath, FilePath)]
env = Maybe [(FilePath, FilePath)]
mb_env,
                                  std_in :: CreateProcess -> StdStream
std_in = StdStream
mb_stdin,
                                  std_out :: CreateProcess -> StdStream
std_out = StdStream
mb_stdout,
                                  std_err :: CreateProcess -> StdStream
std_err = StdStream
mb_stderr,
                                  close_fds :: CreateProcess -> Bool
close_fds = Bool
mb_close_fds,
                                  create_group :: CreateProcess -> Bool
create_group = Bool
mb_create_group,
                                  delegate_ctlc :: CreateProcess -> Bool
delegate_ctlc = Bool
mb_delegate_ctlc,
                                  detach_console :: CreateProcess -> Bool
detach_console = Bool
mb_detach_console,
                                  create_new_console :: CreateProcess -> Bool
create_new_console = Bool
mb_create_new_console,
                                  new_session :: CreateProcess -> Bool
new_session = Bool
mb_new_session,
                                  child_group :: CreateProcess -> Maybe GroupID
child_group = Maybe GroupID
mb_child_group,
                                  child_user :: CreateProcess -> Maybe UserID
child_user = Maybe UserID
mb_child_user }
 = do
  let (FilePath
cmd,[FilePath]
args) = CmdSpec -> (FilePath, [FilePath])
commandToProcess CmdSpec
cmdsp
  FilePath -> IO ProcRetHandles -> IO ProcRetHandles
forall a. FilePath -> IO a -> IO a
withFilePathException FilePath
cmd (IO ProcRetHandles -> IO ProcRetHandles)
-> IO ProcRetHandles -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$
   (Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdInput  ->
   (Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdOutput ->
   (Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr FD -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdError  ->
   (Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \ Ptr CString
pFailedDoing ->
   ([(FilePath, FilePath)]
 -> (Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> Maybe [(FilePath, FilePath)]
-> (Ptr CString -> IO ProcRetHandles)
-> IO ProcRetHandles
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith [(FilePath, FilePath)]
-> (Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a. [(FilePath, FilePath)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment Maybe [(FilePath, FilePath)]
mb_env ((Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \Ptr CString
pEnv ->
   (FilePath -> (CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> Maybe FilePath
-> (CString -> IO ProcRetHandles)
-> IO ProcRetHandles
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith FilePath -> (CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a. FilePath -> (CString -> IO a) -> IO a
withFilePath Maybe FilePath
mb_cwd ((CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \CString
pWorkDir ->
   (GroupID
 -> (Ptr GroupID -> IO ProcRetHandles) -> IO ProcRetHandles)
-> Maybe GroupID
-> (Ptr GroupID -> IO ProcRetHandles)
-> IO ProcRetHandles
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith GroupID -> (Ptr GroupID -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Maybe GroupID
mb_child_group ((Ptr GroupID -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr GroupID -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \Ptr GroupID
pChildGroup ->
   (UserID -> (Ptr UserID -> IO ProcRetHandles) -> IO ProcRetHandles)
-> Maybe UserID
-> (Ptr UserID -> IO ProcRetHandles)
-> IO ProcRetHandles
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith UserID -> (Ptr UserID -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Maybe UserID
mb_child_user ((Ptr UserID -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr UserID -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \Ptr UserID
pChildUser ->
   (FilePath -> (CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> [FilePath]
-> ([CString] -> IO ProcRetHandles)
-> IO ProcRetHandles
forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany FilePath -> (CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a. FilePath -> (CString -> IO a) -> IO a
withFilePath (FilePath
cmdFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
args) (([CString] -> IO ProcRetHandles) -> IO ProcRetHandles)
-> ([CString] -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \[CString]
cstrs ->
   CString
-> [CString]
-> (Ptr CString -> IO ProcRetHandles)
-> IO ProcRetHandles
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 CString
forall a. Ptr a
nullPtr [CString]
cstrs ((Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles)
-> (Ptr CString -> IO ProcRetHandles) -> IO ProcRetHandles
forall a b. (a -> b) -> a -> b
$ \Ptr CString
pargs -> do

     FD
fdin  <- FilePath -> FD -> StdStream -> IO FD
mbFd FilePath
fun FD
fd_stdin  StdStream
mb_stdin
     FD
fdout <- FilePath -> FD -> StdStream -> IO FD
mbFd FilePath
fun FD
fd_stdout StdStream
mb_stdout
     FD
fderr <- FilePath -> FD -> StdStream -> IO FD
mbFd FilePath
fun FD
fd_stderr StdStream
mb_stderr

     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mb_delegate_ctlc
       IO ()
startDelegateControlC

     let flags :: FD
flags = (if Bool
mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
                  FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)
                  FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
mb_detach_console then RUN_PROCESS_DETACHED else 0)
                  FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)
                  FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
mb_new_session then RUN_PROCESS_NEW_SESSION else 0)
                  FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
mb_delegate_ctlc then RESET_INT_QUIT_HANDLERS else 0)

     -- See the comment on runInteractiveProcess_lock
     PHANDLE
proc_handle <- MVar () -> (() -> IO PHANDLE) -> IO PHANDLE
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
runInteractiveProcess_lock ((() -> IO PHANDLE) -> IO PHANDLE)
-> (() -> IO PHANDLE) -> IO PHANDLE
forall a b. (a -> b) -> a -> b
$ \()
_ ->
                         Ptr CString
-> CString
-> Ptr CString
-> FD
-> FD
-> FD
-> Ptr FD
-> Ptr FD
-> Ptr FD
-> Ptr GroupID
-> Ptr UserID
-> FD
-> Ptr CString
-> IO PHANDLE
c_runInteractiveProcess Ptr CString
pargs CString
pWorkDir Ptr CString
pEnv
                                FD
fdin FD
fdout FD
fderr
                                Ptr FD
pfdStdInput Ptr FD
pfdStdOutput Ptr FD
pfdStdError
                                Ptr GroupID
pChildGroup Ptr UserID
pChildUser
                                FD
flags
                                Ptr CString
pFailedDoing

     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PHANDLE
proc_handle PHANDLE -> PHANDLE -> Bool
forall a. Eq a => a -> a -> Bool
== -PHANDLE
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
         CString
cFailedDoing <- Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
pFailedDoing
         FilePath
failedDoing <- CString -> IO FilePath
peekCString CString
cFailedDoing
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mb_delegate_ctlc
           IO ()
stopDelegateControlC
         FilePath -> IO ()
forall a. FilePath -> IO a
throwErrno (FilePath
fun FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
failedDoing)

     Maybe Handle
hndStdInput  <- StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe StdStream
mb_stdin  Ptr FD
pfdStdInput  IOMode
WriteMode
     Maybe Handle
hndStdOutput <- StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe StdStream
mb_stdout Ptr FD
pfdStdOutput IOMode
ReadMode
     Maybe Handle
hndStdError  <- StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe StdStream
mb_stderr Ptr FD
pfdStdError  IOMode
ReadMode

     ProcessHandle
ph <- PHANDLE -> Bool -> IO ProcessHandle
mkProcessHandle PHANDLE
proc_handle Bool
mb_delegate_ctlc
     ProcRetHandles -> IO ProcRetHandles
forall (m :: * -> *) a. Monad m => a -> m a
return ProcRetHandles :: Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> ProcRetHandles
ProcRetHandles { hStdInput :: Maybe Handle
hStdInput    = Maybe Handle
hndStdInput
                           , hStdOutput :: Maybe Handle
hStdOutput   = Maybe Handle
hndStdOutput
                           , hStdError :: Maybe Handle
hStdError    = Maybe Handle
hndStdError
                           , procHandle :: ProcessHandle
procHandle   = ProcessHandle
ph
                           }

{-# NOINLINE runInteractiveProcess_lock #-}
-- | 'runInteractiveProcess' blocks signals around the fork().
-- Since blocking/unblocking of signals is a global state operation, we need to
-- ensure mutual exclusion of calls to 'runInteractiveProcess'.
-- This lock is exported so that other libraries which also need to fork()
-- (and also need to make the same global state changes) can protect their changes
-- with the same lock.
-- See https://github.com/haskell/process/pull/154.
--
-- @since 1.6.6.0
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
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 :: MVar (Maybe (Int, Handler, Handler))
runInteractiveProcess_delegate_ctlc = IO (MVar (Maybe (Int, Handler, Handler)))
-> MVar (Maybe (Int, Handler, Handler))
forall a. IO a -> a
unsafePerformIO (IO (MVar (Maybe (Int, Handler, Handler)))
 -> MVar (Maybe (Int, Handler, Handler)))
-> IO (MVar (Maybe (Int, Handler, Handler)))
-> MVar (Maybe (Int, Handler, Handler))
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Handler, Handler)
-> IO (MVar (Maybe (Int, Handler, Handler)))
forall a. a -> IO (MVar a)
newMVar Maybe (Int, Handler, Handler)
forall a. Maybe a
Nothing

startDelegateControlC :: IO ()
startDelegateControlC :: IO ()
startDelegateControlC =
    MVar (Maybe (Int, Handler, Handler))
-> (Maybe (Int, Handler, Handler)
    -> IO (Maybe (Int, Handler, Handler)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe (Int, Handler, Handler))
runInteractiveProcess_delegate_ctlc ((Maybe (Int, Handler, Handler)
  -> IO (Maybe (Int, Handler, Handler)))
 -> IO ())
-> (Maybe (Int, Handler, Handler)
    -> IO (Maybe (Int, Handler, Handler)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Int, Handler, Handler)
delegating -> do
      case Maybe (Int, Handler, Handler)
delegating of
        Maybe (Int, Handler, Handler)
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.
          Handler
old_int  <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigINT  Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
          Handler
old_quit <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigQUIT Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
          Maybe (Int, Handler, Handler) -> IO (Maybe (Int, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Handler, Handler) -> Maybe (Int, Handler, Handler)
forall a. a -> Maybe a
Just (Int
1, Handler
old_int, Handler
old_quit))

        Just (Int
count, Handler
old_int, Handler
old_quit) -> do
          -- If we're already doing it, just increment the count
          let !count' :: Int
count' = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          Maybe (Int, Handler, Handler) -> IO (Maybe (Int, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Handler, Handler) -> Maybe (Int, Handler, Handler)
forall a. a -> Maybe a
Just (Int
count', Handler
old_int, Handler
old_quit))

stopDelegateControlC :: IO ()
stopDelegateControlC :: IO ()
stopDelegateControlC =
    MVar (Maybe (Int, Handler, Handler))
-> (Maybe (Int, Handler, Handler)
    -> IO (Maybe (Int, Handler, Handler)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe (Int, Handler, Handler))
runInteractiveProcess_delegate_ctlc ((Maybe (Int, Handler, Handler)
  -> IO (Maybe (Int, Handler, Handler)))
 -> IO ())
-> (Maybe (Int, Handler, Handler)
    -> IO (Maybe (Int, Handler, Handler)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Int, Handler, Handler)
delegating -> do
      case Maybe (Int, Handler, Handler)
delegating of
        Just (Int
1, Handler
old_int, Handler
old_quit) -> do
          -- Last process, so restore the old signal handlers
          Handler
_ <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigINT  Handler
old_int  Maybe SignalSet
forall a. Maybe a
Nothing
          Handler
_ <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigQUIT Handler
old_quit Maybe SignalSet
forall a. Maybe a
Nothing
          Maybe (Int, Handler, Handler) -> IO (Maybe (Int, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Handler, Handler)
forall a. Maybe a
Nothing

        Just (Int
count, Handler
old_int, Handler
old_quit) -> do
          -- Not the last, just decrement the count
          let !count' :: Int
count' = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          Maybe (Int, Handler, Handler) -> IO (Maybe (Int, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Handler, Handler) -> Maybe (Int, Handler, Handler)
forall a. a -> Maybe a
Just (Int
count', Handler
old_int, Handler
old_quit))

        Maybe (Int, Handler, Handler)
Nothing -> Maybe (Int, Handler, Handler) -> IO (Maybe (Int, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Handler, Handler)
forall a. Maybe a
Nothing -- should be impossible

endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC ExitCode
exitCode = do
    IO ()
stopDelegateControlC

    -- 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
exitCode of
      ExitFailure Int
n | Int -> Bool
forall a. Integral a => a -> Bool
isSigIntQuit Int
n -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
UserInterrupt
      ExitCode
_                              -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    isSigIntQuit :: a -> Bool
isSigIntQuit a
n = FD
sig FD -> FD -> Bool
forall a. Eq a => a -> a -> Bool
== FD
sigINT Bool -> Bool -> Bool
|| FD
sig FD -> FD -> Bool
forall a. Eq a => a -> a -> Bool
== FD
sigQUIT
      where
        sig :: FD
sig = a -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-a
n)

foreign import ccall unsafe "runInteractiveProcess"
  c_runInteractiveProcess
        ::  Ptr CString
        -> CString
        -> Ptr CString
        -> FD
        -> FD
        -> FD
        -> Ptr FD
        -> Ptr FD
        -> Ptr FD
        -> Ptr CGid
        -> Ptr CUid
        -> CInt                         -- flags
        -> Ptr CString
        -> IO PHANDLE

ignoreSignal, defaultSignal :: CLong
ignoreSignal :: CLong
ignoreSignal  = CONST_SIG_IGN
defaultSignal :: CLong
defaultSignal = CONST_SIG_DFL

isDefaultSignal :: CLong -> Bool
isDefaultSignal :: CLong -> Bool
isDefaultSignal = (CLong -> CLong -> Bool
forall a. Eq a => a -> a -> Bool
== CLong
defaultSignal)

createPipeInternal :: IO (Handle, Handle)
createPipeInternal :: IO (Handle, Handle)
createPipeInternal = do
    (Fd
readfd, Fd
writefd) <- IO (Fd, Fd)
Posix.createPipe
    Handle
readh <- Fd -> IO Handle
Posix.fdToHandle Fd
readfd
    Handle
writeh <- Fd -> IO Handle
Posix.fdToHandle Fd
writefd
    (Handle, Handle) -> IO (Handle, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
readh, Handle
writeh)

createPipeInternalFd :: IO (FD, FD)
createPipeInternalFd :: IO (FD, FD)
createPipeInternalFd = do
   (Fd FD
readfd, Fd FD
writefd) <- IO (Fd, Fd)
Posix.createPipe
   (FD, FD) -> IO (FD, FD)
forall (m :: * -> *) a. Monad m => a -> m a
return (FD
readfd, FD
writefd)

interruptProcessGroupOfInternal
    :: ProcessHandle    -- ^ A process in the process group
    -> IO ()
interruptProcessGroupOfInternal :: ProcessHandle -> IO ()
interruptProcessGroupOfInternal ProcessHandle
ph = do
    ProcessHandle -> (ProcessHandle__ -> IO ()) -> IO ()
forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle ProcessHandle
ph ((ProcessHandle__ -> IO ()) -> IO ())
-> (ProcessHandle__ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
p_ -> do
        case ProcessHandle__
p_ of
            OpenExtHandle{} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ClosedHandle  ExitCode
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            OpenHandle    PHANDLE
h -> do
                PHANDLE
pgid <- PHANDLE -> IO PHANDLE
getProcessGroupIDOf PHANDLE
h
                FD -> PHANDLE -> IO ()
signalProcessGroup FD
sigINT PHANDLE
pgid