rawfilepath-1.1.1: src/RawFilePath/Process/Posix.hs
module RawFilePath.Process.Posix (
createProcessInternal,
withCEnvironment,
closePHANDLE,
startDelegateControlC,
endDelegateControlC,
stopDelegateControlC,
c_execvpe,
pPrPr_disableITimers,
createPipe,
createPipeInternalFd,
) where
-- extra modules
import Data.ByteString.Internal (ByteString (..))
import RawFilePath.Import
-- local modules
import RawFilePath.Process.Common
import System.Posix.ByteString.FilePath (withFilePath)
import qualified System.Posix.IO as Posix
import System.Posix.Internals hiding (withFilePath)
import System.Posix.Process.Internals (c_execvpe, pPrPr_disableITimers)
import System.Posix.Signals
import qualified System.Posix.Signals as Sig
#include "processFlags.c"
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE _ = return ()
-- ----------------------------------------------------------------------------
-- Utils
withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a
withManyByteString bs action =
allocaBytes wholeLength $ \buf ->
allocaBytes ptrLength $ \cs -> do
copyByteStrings bs buf cs
action (castPtr cs)
where
ptrLength = (length bs + 1) * sizeOf (undefined :: Ptr CString)
wholeLength = sum (map (\(PS _ _ l) -> l + 1) bs)
copyByteStrings :: [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO ()
copyByteStrings [] _ cs = poke cs nullPtr
copyByteStrings (PS fp o l : xs) buf cs = withForeignPtr fp $ \p -> do
copyBytes buf (p `plusPtr` o) (fromIntegral l)
pokeByteOff buf l (0 :: Word8)
poke cs (buf :: Ptr Word8)
copyByteStrings
xs
(buf `plusPtr` (l + 1))
(cs `plusPtr` sizeOf (undefined :: Ptr CString))
withCEnvironment
:: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment envir act =
let env' = map (\(name, val) -> name <> "=" <> val) envir
in withManyByteString env' 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{..} =
alloca $ \pfdStdInput ->
alloca $ \pfdStdOutput ->
alloca $ \pfdStdError ->
alloca $ \pFailedDoing ->
maybeWith withCEnvironment env $ \pEnv ->
maybeWith withFilePath cwd $ \pWorkDir ->
maybeWith with childGroup $ \pChildGroup ->
maybeWith with childUser $ \pChildUser ->
withManyByteString cmdargs $ \pargs -> do
fdin <- mbFd fdStdin cfgStdin
fdout <- mbFd fdStdout cfgStdout
fderr <- mbFd fdStderr cfgStderr
when delegateCtlc 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().
procHandle <- withMVar runInteractiveProcessLock $ \_ ->
c_runInteractiveProcess
pargs
pWorkDir
pEnv
fdin
fdout
fderr
pfdStdInput
pfdStdOutput
pfdStdError
pChildGroup
pChildUser
(if delegateCtlc then 1 else 0)
( (if closeFds then RUN_PROCESS_IN_CLOSE_FDS else 0)
.|. (if createGroup then RUN_PROCESS_IN_NEW_GROUP else 0)
.|. (if createNewConsole then RUN_PROCESS_NEW_CONSOLE else 0)
.|. (if newSession then RUN_PROCESS_NEW_SESSION else 0)
)
pFailedDoing
when (procHandle == -1) $ do
cFailedDoing <- peek pFailedDoing
failedDoing <- peekCString cFailedDoing
when delegateCtlc stopDelegateControlC
-- TODO(XT): avoid String
throwErrno (show (head cmdargs) ++ ": " ++ failedDoing)
hIn <- mbPipe cfgStdin pfdStdInput WriteMode
hOut <- mbPipe cfgStdout pfdStdOutput ReadMode
hErr <- mbPipe cfgStderr pfdStdError ReadMode
mvarProcHandle <- newMVar (OpenHandle procHandle)
lock <- newMVar ()
return (Process hIn hOut hErr mvarProcHandle delegateCtlc lock)
{-# NOINLINE runInteractiveProcessLock #-}
runInteractiveProcessLock :: MVar ()
runInteractiveProcessLock = unsafePerformIO $ 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 = unsafePerformIO $ newMVar Nothing
startDelegateControlC :: IO ()
startDelegateControlC =
modifyMVar_ runInteractiveProcessDelegateCtlc $ \case
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.
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
return (Just (1, old_int, old_quit))
Just (count, old_int, old_quit) -> do
-- If we're already doing it, just increment the count
let !count' = count + 1
return (Just (count', old_int, old_quit))
stopDelegateControlC :: IO ()
stopDelegateControlC =
modifyMVar_ runInteractiveProcessDelegateCtlc $ \case
Just (1, old_int, old_quit) -> do
-- Last process, so restore the old signal handlers
_ <- installHandler sigINT old_int Nothing
_ <- installHandler sigQUIT old_quit Nothing
return Nothing
Just (count, old_int, old_quit) -> do
-- Not the last, just decrement the count
let !count' = count - 1
return (Just (count', old_int, old_quit))
Nothing -> return Nothing -- should be impossible
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC exitCode = do
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 of
ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt
_ -> return ()
where
isSigIntQuit n = sig == sigINT || sig == sigQUIT
where
sig = fromIntegral (-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 = do
(readfd, writefd) <- Posix.createPipe
readh <- Posix.fdToHandle readfd
writeh <- Posix.fdToHandle writefd
return (readh, writeh)
createPipeInternalFd :: IO (FD, FD)
createPipeInternalFd = do
(Fd readfd, Fd writefd) <- Posix.createPipe
return (readfd, writefd)