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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

-- -----------------------------------------------------------------------------
-- 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 :: 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

        -- 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 <- 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
            -- TODO(XT): avoid String
            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 ()

-- ----------------------------------------------------------------------------
-- 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 = 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
          -- 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 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
          -- If we're already doing it, just increment the count
          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
          -- Last process, so restore the old signal handlers
          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
          -- Not the last, just decrement the count
          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 -- 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 | 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                         -- 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
    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)