{-# 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
| (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 a b. (a -> b -> b) -> b -> [a] -> b
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
"-_.,/"
withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment :: forall a. [(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)
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)
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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_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 ()
{-# 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
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 a. a -> IO a
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
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 a. a -> IO a
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
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 a. a -> IO a
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
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Handler, Handler)
forall a. Maybe a
Nothing
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC ExitCode
exitCode = do
IO ()
stopDelegateControlC
case ExitCode
exitCode of
ExitFailure Int
n | Int -> Bool
forall {p}. Integral p => p -> Bool
isSigIntQuit Int
n -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
UserInterrupt
ExitCode
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
isSigIntQuit :: p -> Bool
isSigIntQuit p
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 = p -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-p
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
-> 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FD
readfd, FD
writefd)
interruptProcessGroupOfInternal
:: ProcessHandle
-> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ClosedHandle ExitCode
_ -> () -> IO ()
forall a. a -> IO a
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