module RawFilePath.Process.Posix
    ( createProcessInternal
    , withCEnvironment
    , closePHANDLE
    , startDelegateControlC
    , endDelegateControlC
    , stopDelegateControlC
    , c_execvpe
    , pPrPr_disableITimers
    , createPipe
    , createPipeInternalFd
    ) where

import RawFilePath.Import

-- extra modules

import Data.ByteString.Internal (ByteString(..), memcpy)
import System.Posix.ByteString.FilePath (withFilePath)
import System.Posix.Internals hiding (withFilePath)
import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )
import System.Posix.Signals
import qualified System.Posix.Signals as Sig
import qualified System.Posix.IO as Posix

-- local modules

import RawFilePath.Process.Common

#include "processFlags.c"

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

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

withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString [ByteString]
bs Ptr CString -> IO a
action =
  Int -> (Ptr Word8 -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
wholeLength ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
buf ->
  Int -> (Ptr (Ptr Word8) -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
ptrLength ((Ptr (Ptr Word8) -> IO a) -> IO a)
-> (Ptr (Ptr Word8) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
cs -> do
    [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO ()
copyByteStrings [ByteString]
bs Ptr Word8
buf Ptr (Ptr Word8)
cs
    Ptr CString -> IO a
action (Ptr (Ptr Word8) -> Ptr CString
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr Word8)
cs)
  where
    ptrLength :: Int
ptrLength = ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Ptr CString -> Int
forall a. Storable a => a -> Int
sizeOf (Ptr CString
forall a. HasCallStack => a
undefined :: Ptr CString)
    wholeLength :: Int
wholeLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\ (PS ForeignPtr Word8
_ Int
_ Int
l) -> Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ByteString]
bs)

copyByteStrings :: [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO ()
copyByteStrings :: [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO ()
copyByteStrings [] Ptr Word8
_ Ptr (Ptr Word8)
cs = Ptr (Ptr Word8) -> Ptr Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr Word8)
cs Ptr Word8
forall a. Ptr a
nullPtr
copyByteStrings (PS ForeignPtr Word8
fp Int
o Int
l : [ByteString]
xs) Ptr Word8
buf Ptr (Ptr Word8)
cs = ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
p -> do
    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy Ptr Word8
buf (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
o) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
buf Int
l (Word8
0 :: Word8)
    Ptr (Ptr Word8) -> Ptr Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr Word8)
cs (Ptr Word8
buf :: Ptr Word8)
    [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO ()
copyByteStrings [ByteString]
xs (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        (Ptr (Ptr Word8)
cs Ptr (Ptr Word8) -> Int -> Ptr (Ptr Word8)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Ptr CString -> Int
forall a. Storable a => a -> Int
sizeOf (Ptr CString
forall a. HasCallStack => a
undefined :: Ptr CString))

withCEnvironment :: [(ByteString, ByteString)] -> (Ptr CString  -> IO a) -> IO a
withCEnvironment :: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment [(ByteString, ByteString)]
envir Ptr CString -> IO a
act =
  let env' :: [ByteString]
env' = ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
name, ByteString
val) -> ByteString
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
val) [(ByteString, ByteString)]
envir
  in [ByteString] -> (Ptr CString -> IO a) -> IO a
forall a. [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString [ByteString]
env' Ptr CString -> IO a
act

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

createProcessInternal
    :: (StreamType stdin, StreamType stdout, StreamType stderr)
    => ProcessConf stdin stdout stderr
    -> IO (Process stdin stdout stderr)
createProcessInternal :: ProcessConf stdin stdout stderr -> IO (Process stdin stdout stderr)
createProcessInternal ProcessConf{stdin
stdout
stderr
Bool
[ByteString]
Maybe [(ByteString, ByteString)]
Maybe GroupID
Maybe UserID
Maybe ByteString
childUser :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> Maybe UserID
childGroup :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> Maybe GroupID
newSession :: forall stdin stdout stderr. ProcessConf stdin stdout stderr -> Bool
createNewConsole :: forall stdin stdout stderr. ProcessConf stdin stdout stderr -> Bool
delegateCtlc :: forall stdin stdout stderr. ProcessConf stdin stdout stderr -> Bool
createGroup :: forall stdin stdout stderr. ProcessConf stdin stdout stderr -> Bool
closeFds :: forall stdin stdout stderr. ProcessConf stdin stdout stderr -> Bool
cfgStderr :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> stderr
cfgStdout :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> stdout
cfgStdin :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> stdin
env :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> Maybe [(ByteString, ByteString)]
cwd :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> Maybe ByteString
cmdargs :: forall stdin stdout stderr.
ProcessConf stdin stdout stderr -> [ByteString]
childUser :: Maybe UserID
childGroup :: Maybe GroupID
newSession :: Bool
createNewConsole :: Bool
delegateCtlc :: Bool
createGroup :: Bool
closeFds :: Bool
cfgStderr :: stderr
cfgStdout :: stdout
cfgStdin :: stdin
env :: Maybe [(ByteString, ByteString)]
cwd :: Maybe ByteString
cmdargs :: [ByteString]
..}
  = (Ptr FD -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FD -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr FD -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdInput  ->
    (Ptr FD -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FD -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr FD -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdOutput ->
    (Ptr FD -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FD -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr FD -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdError  ->
    (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CString -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \ Ptr CString
pFailedDoing ->
    ([(ByteString, ByteString)]
 -> (Ptr CString -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> Maybe [(ByteString, ByteString)]
-> (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith [(ByteString, ByteString)]
-> (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a.
[(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment Maybe [(ByteString, ByteString)]
env ((Ptr CString -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \Ptr CString
pEnv ->
    (ByteString
 -> (CString -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> Maybe ByteString
-> (CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith ByteString
-> (CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a. ByteString -> (CString -> IO a) -> IO a
withFilePath Maybe ByteString
cwd ((CString -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \CString
pWorkDir ->
    (GroupID
 -> (Ptr GroupID -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> Maybe GroupID
-> (Ptr GroupID -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith GroupID
-> (Ptr GroupID -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Maybe GroupID
childGroup ((Ptr GroupID -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr GroupID -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \Ptr GroupID
pChildGroup ->
    (UserID
 -> (Ptr UserID -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> Maybe UserID
-> (Ptr UserID -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith UserID
-> (Ptr UserID -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Maybe UserID
childUser ((Ptr UserID -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr UserID -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \Ptr UserID
pChildUser ->
    [ByteString]
-> (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a. [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString [ByteString]
cmdargs ((Ptr CString -> IO (Process stdin stdout stderr))
 -> IO (Process stdin stdout stderr))
-> (Ptr CString -> IO (Process stdin stdout stderr))
-> IO (Process stdin stdout stderr)
forall a b. (a -> b) -> a -> b
$ \Ptr CString
pargs -> do

        FD
fdin  <- FD -> stdin -> IO FD
forall c. StreamType c => FD -> c -> IO FD
mbFd FD
fdStdin  stdin
cfgStdin
        FD
fdout <- FD -> stdout -> IO FD
forall c. StreamType c => FD -> c -> IO FD
mbFd FD
fdStdout stdout
cfgStdout
        FD
fderr <- FD -> stderr -> IO FD
forall c. StreamType c => FD -> c -> IO FD
mbFd FD
fdStderr stderr
cfgStderr

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

        -- runInteractiveProcess() blocks signals around the fork().
        -- Since blocking/unblocking of signals is a global state
        -- operation, we better ensure mutual exclusion of calls to
        -- runInteractiveProcess().
        PHANDLE
procHandle <- MVar () -> (() -> IO PHANDLE) -> IO PHANDLE
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
runInteractiveProcessLock ((() -> 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
-> 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
            (if Bool
delegateCtlc then FD
1 else FD
0)
            ((if Bool
closeFds then RUN_PROCESS_IN_CLOSE_FDS else 0)
            FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
createGroup then RUN_PROCESS_IN_NEW_GROUP else 0)
            FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
createNewConsole then RUN_PROCESS_NEW_CONSOLE else 0)
            FD -> FD -> FD
forall a. Bits a => a -> a -> a
.|.(if Bool
newSession then RUN_PROCESS_NEW_SESSION else 0))
            Ptr CString
pFailedDoing

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PHANDLE
procHandle 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
            String
failedDoing <- CString -> IO String
peekCString CString
cFailedDoing
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delegateCtlc IO ()
stopDelegateControlC
            -- TODO(XT): avoid String
            String -> IO ()
forall a. String -> IO a
throwErrno (ByteString -> String
forall a. Show a => a -> String
show ([ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
cmdargs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
failedDoing)

        Maybe Handle
hIn  <- stdin -> Ptr FD -> IOMode -> IO (Maybe Handle)
forall c.
StreamType c =>
c -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe stdin
cfgStdin  Ptr FD
pfdStdInput  IOMode
WriteMode
        Maybe Handle
hOut <- stdout -> Ptr FD -> IOMode -> IO (Maybe Handle)
forall c.
StreamType c =>
c -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe stdout
cfgStdout Ptr FD
pfdStdOutput IOMode
ReadMode
        Maybe Handle
hErr <- stderr -> Ptr FD -> IOMode -> IO (Maybe Handle)
forall c.
StreamType c =>
c -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe stderr
cfgStderr Ptr FD
pfdStdError  IOMode
ReadMode

        MVar ProcessHandle__
mvarProcHandle <- ProcessHandle__ -> IO (MVar ProcessHandle__)
forall a. a -> IO (MVar a)
newMVar (PHANDLE -> ProcessHandle__
OpenHandle PHANDLE
procHandle)
        MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        Process stdin stdout stderr -> IO (Process stdin stdout stderr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> MVar ProcessHandle__
-> Bool
-> MVar ()
-> Process stdin stdout stderr
forall stdin stdout stderr.
Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> MVar ProcessHandle__
-> Bool
-> MVar ()
-> Process stdin stdout stderr
Process Maybe Handle
hIn Maybe Handle
hOut Maybe Handle
hErr MVar ProcessHandle__
mvarProcHandle Bool
delegateCtlc MVar ()
lock)

{-# NOINLINE runInteractiveProcessLock #-}
runInteractiveProcessLock :: MVar ()
runInteractiveProcessLock :: MVar ()
runInteractiveProcessLock = 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 runInteractiveProcessDelegateCtlc #-}
runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))
runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Handler, Handler))
runInteractiveProcessDelegateCtlc = 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))
runInteractiveProcessDelegateCtlc ((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
$ \ case
        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))
runInteractiveProcessDelegateCtlc ((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
$ \ case
        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                         -- reset child's SIGINT & SIGQUIT handlers
    -> CInt                         -- flags
    -> Ptr CString
    -> IO PHANDLE

createPipe :: IO (Handle, Handle)
createPipe :: IO (Handle, Handle)
createPipe = 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)