module RawFilePath.Process.Posix
( createProcessInternal
, withCEnvironment
, closePHANDLE
, startDelegateControlC
, endDelegateControlC
, stopDelegateControlC
, c_execvpe
, pPrPr_disableITimers
, createPipe
, createPipeInternalFd
) where
import RawFilePath.Import
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
import RawFilePath.Process.Common
#include "processFlags.c"
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE PHANDLE
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString :: forall a. [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString [ByteString]
bs Ptr CString -> IO a
action =
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
wholeLength forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
buf ->
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
ptrLength 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 (forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr Word8)
cs)
where
ptrLength :: Int
ptrLength = (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
bs forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Ptr CString)
wholeLength :: Int
wholeLength = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (\ (PS ForeignPtr Word8
_ Int
_ Int
l) -> Int
l 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 = forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr Word8)
cs forall a. Ptr a
nullPtr
copyByteStrings (PS ForeignPtr Word8
fp Int
o Int
l : [ByteString]
xs) Ptr Word8
buf Ptr (Ptr Word8)
cs = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
p -> do
Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy Ptr Word8
buf (Ptr Word8
p forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
o) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
buf Int
l (Word8
0 :: Word8)
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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
l forall a. Num a => a -> a -> a
+ Int
1))
(Ptr (Ptr Word8)
cs forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Ptr CString))
withCEnvironment :: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment :: forall a.
[(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment [(ByteString, ByteString)]
envir Ptr CString -> IO a
act =
let env' :: [ByteString]
env' = forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
name, ByteString
val) -> ByteString
name forall a. Semigroup a => a -> a -> a
<> ByteString
"=" forall a. Semigroup a => a -> a -> a
<> ByteString
val) [(ByteString, ByteString)]
envir
in forall a. [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString [ByteString]
env' Ptr CString -> IO a
act
createProcessInternal
:: (StreamType stdin, StreamType stdout, StreamType stderr)
=> ProcessConf stdin stdout stderr
-> IO (Process stdin stdout stderr)
createProcessInternal :: forall stdin stdout stderr.
(StreamType stdin, StreamType stdout, StreamType stderr) =>
ProcessConf stdin stdout stderr -> IO (Process stdin stdout stderr)
createProcessInternal ProcessConf{stdin
stdout
stderr
Bool
[ByteString]
Maybe [(ByteString, ByteString)]
Maybe UserID
Maybe GroupID
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]
..}
= forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdInput ->
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdOutput ->
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \ Ptr FD
pfdStdError ->
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \ Ptr CString
pFailedDoing ->
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith forall a.
[(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment Maybe [(ByteString, ByteString)]
env forall a b. (a -> b) -> a -> b
$ \Ptr CString
pEnv ->
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith forall a. ByteString -> (CString -> IO a) -> IO a
withFilePath Maybe ByteString
cwd forall a b. (a -> b) -> a -> b
$ \CString
pWorkDir ->
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Maybe GroupID
childGroup forall a b. (a -> b) -> a -> b
$ \Ptr GroupID
pChildGroup ->
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Maybe UserID
childUser forall a b. (a -> b) -> a -> b
$ \Ptr UserID
pChildUser ->
forall a. [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString [ByteString]
cmdargs forall a b. (a -> b) -> a -> b
$ \Ptr CString
pargs -> do
FD
fdin <- forall c. StreamType c => FD -> c -> IO FD
mbFd FD
fdStdin stdin
cfgStdin
FD
fdout <- forall c. StreamType c => FD -> c -> IO FD
mbFd FD
fdStdout stdout
cfgStdout
FD
fderr <- forall c. StreamType c => FD -> c -> IO FD
mbFd FD
fdStderr stderr
cfgStderr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delegateCtlc IO ()
startDelegateControlC
PHANDLE
procHandle <- forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
runInteractiveProcessLock 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)
forall a. Bits a => a -> a -> a
.|.(if Bool
createGroup then RUN_PROCESS_IN_NEW_GROUP else 0)
forall a. Bits a => a -> a -> a
.|.(if Bool
createNewConsole then RUN_PROCESS_NEW_CONSOLE else 0)
forall a. Bits a => a -> a -> a
.|.(if Bool
newSession then RUN_PROCESS_NEW_SESSION else 0))
Ptr CString
pFailedDoing
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PHANDLE
procHandle forall a. Eq a => a -> a -> Bool
== -PHANDLE
1) forall a b. (a -> b) -> a -> b
$ do
CString
cFailedDoing <- forall a. Storable a => Ptr a -> IO a
peek Ptr CString
pFailedDoing
[Char]
failedDoing <- CString -> IO [Char]
peekCString CString
cFailedDoing
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delegateCtlc IO ()
stopDelegateControlC
forall a. [Char] -> IO a
throwErrno (forall a. Show a => a -> [Char]
show (forall a. [a] -> a
head [ByteString]
cmdargs) forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
failedDoing)
Maybe Handle
hIn <- forall c.
StreamType c =>
c -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe stdin
cfgStdin Ptr FD
pfdStdInput IOMode
WriteMode
Maybe Handle
hOut <- forall c.
StreamType c =>
c -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe stdout
cfgStdout Ptr FD
pfdStdOutput IOMode
ReadMode
Maybe Handle
hErr <- forall c.
StreamType c =>
c -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe stderr
cfgStderr Ptr FD
pfdStdError IOMode
ReadMode
MVar ProcessHandle__
mvarProcHandle <- forall a. a -> IO (MVar a)
newMVar (PHANDLE -> ProcessHandle__
OpenHandle PHANDLE
procHandle)
MVar ()
lock <- forall a. a -> IO (MVar a)
newMVar ()
forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar ()
{-# NOINLINE runInteractiveProcessDelegateCtlc #-}
runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))
runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Handler, Handler))
runInteractiveProcessDelegateCtlc = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar forall a. Maybe a
Nothing
startDelegateControlC :: IO ()
startDelegateControlC :: IO ()
startDelegateControlC =
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe (Int, Handler, Handler))
runInteractiveProcessDelegateCtlc forall a b. (a -> b) -> a -> b
$ \ case
Maybe (Int, Handler, Handler)
Nothing -> do
Handler
old_int <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigINT Handler
Ignore forall a. Maybe a
Nothing
Handler
old_quit <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigQUIT Handler
Ignore forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. Num a => a -> a -> a
+ Int
1
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Int
count', Handler
old_int, Handler
old_quit))
stopDelegateControlC :: IO ()
stopDelegateControlC :: IO ()
stopDelegateControlC =
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe (Int, Handler, Handler))
runInteractiveProcessDelegateCtlc forall a b. (a -> b) -> a -> b
$ \ case
Just (Int
1, Handler
old_int, Handler
old_quit) -> do
Handler
_ <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigINT Handler
old_int forall a. Maybe a
Nothing
Handler
_ <- FD -> Handler -> Maybe SignalSet -> IO Handler
installHandler FD
sigQUIT Handler
old_quit forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (Int
count, Handler
old_int, Handler
old_quit) -> do
let !count' :: Int
count' = Int
count forall a. Num a => a -> a -> a
- Int
1
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Int
count', Handler
old_int, Handler
old_quit))
Maybe (Int, Handler, Handler)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC ExitCode
exitCode = do
IO ()
stopDelegateControlC
case ExitCode
exitCode of
ExitFailure Int
n | forall {p}. Integral p => p -> Bool
isSigIntQuit Int
n -> forall e a. Exception e => e -> IO a
throwIO AsyncException
UserInterrupt
ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
isSigIntQuit :: p -> Bool
isSigIntQuit p
n = FD
sig forall a. Eq a => a -> a -> Bool
== FD
sigINT Bool -> Bool -> Bool
|| FD
sig forall a. Eq a => a -> a -> Bool
== FD
sigQUIT
where
sig :: FD
sig = 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
-> CInt
-> 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
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
forall (m :: * -> *) a. Monad m => a -> m a
return (FD
readfd, FD
writefd)