{-# 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 <- forall a. a -> IO (MVar a)
newMVar (PHANDLE -> ProcessHandle__
OpenHandle PHANDLE
p)
  MVar ()
l <- forall a. a -> IO (MVar a)
newMVar ()
  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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ----------------------------------------------------------------------------
-- commandToProcess

{- | Turns a shell command into a raw command.  Usually this involves
     wrapping it in an invocation of the shell.

   There's a difference in the signature of commandToProcess between
   the Windows and Unix versions.  On Unix, exec takes a list of strings,
   and we want to pass our command to /bin/sh as a single argument.

   On Windows, CreateProcess takes a single string for the command,
   which is later decomposed by cmd.exe.  In this case, we just want
   to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line.  The
   command-line translation that we normally do for arguments on
   Windows isn't required (or desirable) here.
-}

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
   -- goodChar is a pessimistic predicate, such that if an argument is
   -- non-empty and only contains goodChars, then there is no need to
   -- do any quoting or escaping
 | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
goodChar FilePath
str = FilePath
str
 | Bool
otherwise        = Char
'\'' forall a. a -> [a] -> [a]
: 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
"-_.,/"

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

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' = forall a b. (a -> b) -> [a] -> [b]
map (\(FilePath
name, FilePath
val) -> FilePath
name forall a. [a] -> [a] -> [a]
++ (Char
'='forall a. a -> [a] -> [a]
:FilePath
val)) [(FilePath, FilePath)]
envir
  in forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany forall a. FilePath -> (CString -> IO a) -> IO a
withFilePath [FilePath]
env' (\[CString]
pEnv -> forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 forall a. Ptr a
nullPtr [CString]
pEnv Ptr CString -> IO a
act)

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

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
  forall a. FilePath -> IO a -> IO a
withFilePathException FilePath
cmd forall a b. (a -> b) -> a -> b
$
   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. [(FilePath, FilePath)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment Maybe [(FilePath, FilePath)]
mb_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. FilePath -> (CString -> IO a) -> IO a
withFilePath Maybe FilePath
mb_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
mb_child_group 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
mb_child_user forall a b. (a -> b) -> a -> b
$ \Ptr UserID
pChildUser ->
   forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany forall a. FilePath -> (CString -> IO a) -> IO a
withFilePath (FilePath
cmdforall a. a -> [a] -> [a]
:[FilePath]
args) forall a b. (a -> b) -> a -> b
$ \[CString]
cstrs ->
   forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 forall a. Ptr a
nullPtr [CString]
cstrs 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

     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)
                  forall a. Bits a => a -> a -> a
.|.(if Bool
mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)
                  forall a. Bits a => a -> a -> a
.|.(if Bool
mb_detach_console then RUN_PROCESS_DETACHED else 0)
                  forall a. Bits a => a -> a -> a
.|.(if Bool
mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)
                  forall a. Bits a => a -> a -> a
.|.(if Bool
mb_new_session then RUN_PROCESS_NEW_SESSION else 0)
                  forall a. Bits a => a -> a -> a
.|.(if Bool
mb_delegate_ctlc then RESET_INT_QUIT_HANDLERS else 0)

     -- See the comment on runInteractiveProcess_lock
     PHANDLE
proc_handle <- forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
runInteractiveProcess_lock 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

     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PHANDLE
proc_handle 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
         FilePath
failedDoing <- CString -> IO FilePath
peekCString CString
cFailedDoing
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mb_delegate_ctlc
           IO ()
stopDelegateControlC
         forall a. FilePath -> IO a
throwErrno (FilePath
fun forall a. [a] -> [a] -> [a]
++ 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
     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' blocks signals around the fork().
-- Since blocking/unblocking of signals is a global state operation, we need to
-- ensure mutual exclusion of calls to 'runInteractiveProcess'.
-- This lock is exported so that other libraries which also need to fork()
-- (and also need to make the same global state changes) can protect their changes
-- with the same lock.
-- See https://github.com/haskell/process/pull/154.
--
-- @since 1.6.6.0
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = 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 runInteractiveProcess_delegate_ctlc #-}
runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))
runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Handler, Handler))
runInteractiveProcess_delegate_ctlc = 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))
runInteractiveProcess_delegate_ctlc 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
          -- 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))
runInteractiveProcess_delegate_ctlc 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
          -- 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                         -- flags
        -> 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 = (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
    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)

interruptProcessGroupOfInternal
    :: ProcessHandle    -- ^ A process in the process group
    -> IO ()
interruptProcessGroupOfInternal :: ProcessHandle -> IO ()
interruptProcessGroupOfInternal ProcessHandle
ph = do
    forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle ProcessHandle
ph forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
p_ -> do
        case ProcessHandle__
p_ of
            OpenExtHandle{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ClosedHandle  ExitCode
_ -> 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