{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module System.Process.Common
    ( CreateProcess (..)
    , CmdSpec (..)
    , StdStream (..)
    , ProcessHandle(..)
    , ProcessHandle__(..)
    , ProcRetHandles (..)
    , withFilePathException
    , PHANDLE
    , GroupID
    , UserID
    , modifyProcessHandle
    , withProcessHandle
    , fd_stdin
    , fd_stdout
    , fd_stderr
    , mbFd
    , mbPipe
    , pfdToHandle

-- Avoid a warning on Windows
#ifdef WINDOWS
    , CGid (..)
#else
    , CGid
#endif

-- WINIO is only available on GHC 8.12 and up.
#if defined(__IO_MANAGER_WINIO__)
    , HANDLE
    , mbHANDLE
    , mbPipeHANDLE
#endif
    ) where

import Control.Concurrent
import Control.Exception
import Data.String
import Foreign.Ptr
import Foreign.Storable

import System.Posix.Internals
import GHC.IO.Exception
import GHC.IO.Encoding
import qualified GHC.IO.FD as FD
import GHC.IO.Device
#if defined(__IO_MANAGER_WINIO__)
import GHC.IO.Handle.Windows
import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
#endif
import GHC.IO.Handle.FD
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types hiding (ClosedHandle)
import System.IO.Error
import Data.Typeable
import System.IO (IOMode)

#if defined(javascript_HOST_ARCH)
import GHC.JS.Prim (JSVal)
#endif

-- We do a minimal amount of CPP here to provide uniform data types across
-- Windows and POSIX.
#ifdef WINDOWS
import Data.Word (Word32)
import System.Win32.DebugApi (PHANDLE)
#if defined(__IO_MANAGER_WINIO__)
import System.Win32.Types (HANDLE)
#endif
#else
import System.Posix.Types
#endif

#if defined(javascript_HOST_ARCH)
type PHANDLE = JSVal
#elif defined(WINDOWS)
-- Define some missing types for Windows compatibility. Note that these values
-- will never actually be used, as the setuid/setgid system calls are not
-- applicable on Windows. No value of this type will ever exist.
newtype CGid = CGid Word32
  deriving (Show, Eq)
type GroupID = CGid
type UserID = CGid
#else
type PHANDLE = CPid
#endif
data CreateProcess = CreateProcess{
  CreateProcess -> CmdSpec
cmdspec      :: CmdSpec,                 -- ^ Executable & arguments, or shell command.  If 'cwd' is 'Nothing', relative paths are resolved with respect to the current working directory.  If 'cwd' is provided, it is implementation-dependent whether relative paths are resolved with respect to 'cwd' or the current working directory, so absolute paths should be used to ensure portability.
  CreateProcess -> Maybe FilePath
cwd          :: Maybe FilePath,          -- ^ Optional path to the working directory for the new process
  CreateProcess -> Maybe [(FilePath, FilePath)]
env          :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)
  CreateProcess -> StdStream
std_in       :: StdStream,               -- ^ How to determine stdin
  CreateProcess -> StdStream
std_out      :: StdStream,               -- ^ How to determine stdout
  CreateProcess -> StdStream
std_err      :: StdStream,               -- ^ How to determine stderr
  CreateProcess -> Bool
close_fds    :: Bool,                    -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. XXX verify what happens with fds in nodejs child processes
  CreateProcess -> Bool
create_group :: Bool,                    -- ^ Create a new process group. On JavaScript this also creates a new session.
  CreateProcess -> Bool
delegate_ctlc:: Bool,                    -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).
                                           --
                                           --   @since 1.2.0.0
  CreateProcess -> Bool
detach_console :: Bool,                  -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms.
                                           --
                                           --   @since 1.3.0.0
  CreateProcess -> Bool
create_new_console :: Bool,              -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; does nothing on other platforms.
                                           --
                                           --   Default: @False@
                                           --
                                           --   @since 1.3.0.0
  CreateProcess -> Bool
new_session :: Bool,                     -- ^ Use posix setsid to start the new process in a new session; starts process in a new session on JavaScript; does nothing on other platforms.
                                           --
                                           --   @since 1.3.0.0
  CreateProcess -> Maybe GroupID
child_group :: Maybe GroupID,            -- ^ Use posix setgid to set child process's group id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.
                                           --
                                           --   Default: @Nothing@
                                           --
                                           --   @since 1.4.0.0
  CreateProcess -> Maybe UserID
child_user :: Maybe UserID,              -- ^ Use posix setuid to set child process's user id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.
                                           --
                                           --   Default: @Nothing@
                                           --
                                           --   @since 1.4.0.0
  CreateProcess -> Bool
use_process_jobs :: Bool                 -- ^ On Windows systems this flag indicates that we should wait for the entire process tree
                                           --   to finish before unblocking. On POSIX systems this flag is ignored. See $exec-on-windows for details.
                                           --
                                           --   Default: @False@
                                           --
                                           --   @since 1.5.0.0
 } deriving (Int -> CreateProcess -> ShowS
[CreateProcess] -> ShowS
CreateProcess -> FilePath
(Int -> CreateProcess -> ShowS)
-> (CreateProcess -> FilePath)
-> ([CreateProcess] -> ShowS)
-> Show CreateProcess
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CreateProcess -> ShowS
showsPrec :: Int -> CreateProcess -> ShowS
$cshow :: CreateProcess -> FilePath
show :: CreateProcess -> FilePath
$cshowList :: [CreateProcess] -> ShowS
showList :: [CreateProcess] -> ShowS
Show, CreateProcess -> CreateProcess -> Bool
(CreateProcess -> CreateProcess -> Bool)
-> (CreateProcess -> CreateProcess -> Bool) -> Eq CreateProcess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CreateProcess -> CreateProcess -> Bool
== :: CreateProcess -> CreateProcess -> Bool
$c/= :: CreateProcess -> CreateProcess -> Bool
/= :: CreateProcess -> CreateProcess -> Bool
Eq)

-- | contains the handles returned by a call to createProcess_Internal
data ProcRetHandles
  = ProcRetHandles { ProcRetHandles -> Maybe Handle
hStdInput      :: Maybe Handle
                   , ProcRetHandles -> Maybe Handle
hStdOutput     :: Maybe Handle
                   , ProcRetHandles -> Maybe Handle
hStdError      :: Maybe Handle
                   , ProcRetHandles -> ProcessHandle
procHandle     :: ProcessHandle
                   }

data CmdSpec
  = ShellCommand String
      -- ^ A command line to execute using the shell
  | RawCommand FilePath [String]
      -- ^ The name of an executable with a list of arguments
      --
      -- The 'FilePath' argument names the executable, and is interpreted
      -- according to the platform's standard policy for searching for
      -- executables. Specifically:
      --
      -- * on Unix systems the
      --   <http://pubs.opengroup.org/onlinepubs/9699919799/functions/execvp.html execvp(3)>
      --   semantics is used, where if the executable filename does not
      --   contain a slash (@/@) then the @PATH@ environment variable is
      --   searched for the executable.
      --
      -- * on Windows systems the Win32 @CreateProcess@ semantics is used.
      --   Briefly: if the filename does not contain a path, then the
      --   directory containing the parent executable is searched, followed
      --   by the current directory, then some standard locations, and
      --   finally the current @PATH@.  An @.exe@ extension is added if the
      --   filename does not already have an extension.  For full details
      --   see the
      --   <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365527%28v=vs.85%29.aspx documentation>
      --   for the Windows @SearchPath@ API.
      --
      --   Windows does not have a mechanism for passing multiple arguments.
      --   When using @RawCommand@ on Windows, the command line is serialised
      --   into a string, with arguments quoted separately.  Command line
      --   parsing is up individual programs, so the default behaviour may
      --   not work for some programs.  If you are not getting the desired
      --   results, construct the command line yourself and use 'ShellCommand'.
      --
  deriving (Int -> CmdSpec -> ShowS
[CmdSpec] -> ShowS
CmdSpec -> FilePath
(Int -> CmdSpec -> ShowS)
-> (CmdSpec -> FilePath) -> ([CmdSpec] -> ShowS) -> Show CmdSpec
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CmdSpec -> ShowS
showsPrec :: Int -> CmdSpec -> ShowS
$cshow :: CmdSpec -> FilePath
show :: CmdSpec -> FilePath
$cshowList :: [CmdSpec] -> ShowS
showList :: [CmdSpec] -> ShowS
Show, CmdSpec -> CmdSpec -> Bool
(CmdSpec -> CmdSpec -> Bool)
-> (CmdSpec -> CmdSpec -> Bool) -> Eq CmdSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CmdSpec -> CmdSpec -> Bool
== :: CmdSpec -> CmdSpec -> Bool
$c/= :: CmdSpec -> CmdSpec -> Bool
/= :: CmdSpec -> CmdSpec -> Bool
Eq)


-- | construct a `ShellCommand` from a string literal
--
-- @since 1.2.1.0
instance IsString CmdSpec where
  fromString :: FilePath -> CmdSpec
fromString = FilePath -> CmdSpec
ShellCommand

data StdStream
  = Inherit                  -- ^ Inherit Handle from parent
  | UseHandle Handle         -- ^ Use the supplied Handle
  | CreatePipe               -- ^ Create a new pipe.  The returned
                             -- @Handle@ will use the default encoding
                             -- and newline translation mode (just
                             -- like @Handle@s created by @openFile@).
  | NoStream                 -- ^ Close the stream's file descriptor without
                             -- passing a Handle. On POSIX systems this may
                             -- lead to strange behavior in the child process
                             -- because attempting to read or write after the
                             -- file has been closed throws an error. This
                             -- should only be used with child processes that
                             -- don't use the file descriptor at all. If you
                             -- wish to ignore the child process's output you
                             -- should either create a pipe and drain it
                             -- manually or pass a @Handle@ that writes to
                             -- @\/dev\/null@.
  deriving (StdStream -> StdStream -> Bool
(StdStream -> StdStream -> Bool)
-> (StdStream -> StdStream -> Bool) -> Eq StdStream
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StdStream -> StdStream -> Bool
== :: StdStream -> StdStream -> Bool
$c/= :: StdStream -> StdStream -> Bool
/= :: StdStream -> StdStream -> Bool
Eq, Int -> StdStream -> ShowS
[StdStream] -> ShowS
StdStream -> FilePath
(Int -> StdStream -> ShowS)
-> (StdStream -> FilePath)
-> ([StdStream] -> ShowS)
-> Show StdStream
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StdStream -> ShowS
showsPrec :: Int -> StdStream -> ShowS
$cshow :: StdStream -> FilePath
show :: StdStream -> FilePath
$cshowList :: [StdStream] -> ShowS
showList :: [StdStream] -> ShowS
Show)

-- ----------------------------------------------------------------------------
-- ProcessHandle type

data ProcessHandle__ = OpenHandle { ProcessHandle__ -> PHANDLE
phdlProcessHandle :: PHANDLE }
                     -- | 'OpenExtHandle' is only applicable for
                     -- Windows platform. It represents [Job
                     -- Objects](https://learn.microsoft.com/en-us/windows/win32/procthread/job-objects).
                     | OpenExtHandle { phdlProcessHandle :: PHANDLE
                                     -- ^ the process
                                     , ProcessHandle__ -> PHANDLE
phdlJobHandle     :: PHANDLE
                                     -- ^ the job containing the process and
                                     -- its subprocesses
                                     }
                     | ClosedHandle ExitCode

{- | A handle to a process, which can be used to wait for termination
     of the process using 'System.Process.waitForProcess'.

     None of the process-creation functions in this library wait for
     termination: they all return a 'ProcessHandle' which may be used
     to wait for the process later.

     On Windows a second wait method can be used to block for event
     completion. This requires two handles. A process job handle and
     a events handle to monitor.
-}
data ProcessHandle
  = ProcessHandle { ProcessHandle -> MVar ProcessHandle__
phandle          :: !(MVar ProcessHandle__)
                  , ProcessHandle -> Bool
mb_delegate_ctlc :: !Bool
                  , ProcessHandle -> MVar ()
waitpidLock      :: !(MVar ())
                  }

withFilePathException :: FilePath -> IO a -> IO a
withFilePathException :: forall a. FilePath -> IO a -> IO a
withFilePathException FilePath
fpath IO a
act = (IOError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO a
forall {a}. IOError -> IO a
mapEx IO a
act
  where
    mapEx :: IOError -> IO a
mapEx IOError
ex = IOError -> IO a
forall {a}. IOError -> IO a
ioError (IOError -> FilePath -> IOError
ioeSetFileName IOError
ex FilePath
fpath)

modifyProcessHandle
        :: ProcessHandle
        -> (ProcessHandle__ -> IO (ProcessHandle__, a))
        -> IO a
modifyProcessHandle :: forall a.
ProcessHandle
-> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a
modifyProcessHandle (ProcessHandle MVar ProcessHandle__
m Bool
_ MVar ()
_) ProcessHandle__ -> IO (ProcessHandle__, a)
io = MVar ProcessHandle__
-> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ProcessHandle__
m ProcessHandle__ -> IO (ProcessHandle__, a)
io

withProcessHandle
        :: ProcessHandle
        -> (ProcessHandle__ -> IO a)
        -> IO a
withProcessHandle :: forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle (ProcessHandle MVar ProcessHandle__
m Bool
_ MVar ()
_) ProcessHandle__ -> IO a
io = MVar ProcessHandle__ -> (ProcessHandle__ -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ProcessHandle__
m ProcessHandle__ -> IO a
io

fd_stdin, fd_stdout, fd_stderr :: FD
fd_stdin :: FD
fd_stdin  = FD
0
fd_stdout :: FD
fd_stdout = FD
1
fd_stderr :: FD
fd_stderr = FD
2

mbFd :: String -> FD -> StdStream -> IO FD
mbFd :: FilePath -> FD -> StdStream -> IO FD
mbFd FilePath
_   FD
_std StdStream
CreatePipe      = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (-FD
1)
mbFd FilePath
_fun FD
std StdStream
Inherit         = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
std
mbFd FilePath
_fn FD
_std StdStream
NoStream        = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (-FD
2)
mbFd FilePath
fun FD
_std (UseHandle Handle
hdl) =
  FilePath -> Handle -> (Handle__ -> IO (Handle__, FD)) -> IO FD
forall a.
FilePath -> Handle -> (Handle__ -> IO (Handle__, a)) -> IO a
withHandle FilePath
fun Handle
hdl ((Handle__ -> IO (Handle__, FD)) -> IO FD)
-> (Handle__ -> IO (Handle__, FD)) -> IO FD
forall a b. (a -> b) -> a -> b
$ \Handle__{haDevice :: ()
haDevice=dev
dev,Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer Char)
IORef (Buffer Word8)
IORef (BufferList Char)
Newline
BufferMode
HandleType
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer Char)
haBuffers :: IORef (BufferList Char)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOutputNL :: Handle__ -> Newline
haInputNL :: Handle__ -> Newline
haCodec :: Handle__ -> Maybe TextEncoding
haDecoder :: ()
haEncoder :: ()
haBuffers :: Handle__ -> IORef (BufferList Char)
haCharBuffer :: Handle__ -> IORef (Buffer Char)
haLastDecode :: ()
haBufferMode :: Handle__ -> BufferMode
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haType :: Handle__ -> HandleType
..} -> do
    case dev -> Maybe FD
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
      Just FD
fd -> do
#if !defined(javascript_HOST_ARCH)
         -- clear the O_NONBLOCK flag on this FD, if it is set, since
         -- we're exposing it externally (see #3316)
         fd' <- FD -> Bool -> IO FD
FD.setNonBlockingMode FD
fd Bool
False
#else
         -- on the JavaScript platform we cannot change the FD flags
         fd' <- pure fd
#endif
         return (Handle__{haDevice=fd',..}, FD.fdFD fd')
      Maybe FD
Nothing ->
          IOError -> IO (Handle__, FD)
forall {a}. IOError -> IO a
ioError (IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError IOErrorType
illegalOperationErrorType
                      FilePath
"createProcess" (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
hdl) Maybe FilePath
forall a. Maybe a
Nothing
                   IOError -> FilePath -> IOError
`ioeSetErrorString` FilePath
"handle is not a file descriptor")

mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe StdStream
CreatePipe Ptr FD
pfd  IOMode
mode = (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Ptr FD -> IOMode -> IO Handle
pfdToHandle Ptr FD
pfd IOMode
mode)
mbPipe StdStream
_std      Ptr FD
_pfd IOMode
_mode = Maybe Handle -> IO (Maybe Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing

pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle Ptr FD
pfd IOMode
mode = do
  fd <- Ptr FD -> IO FD
forall a. Storable a => Ptr a -> IO a
peek Ptr FD
pfd
  let filepath = FilePath
"fd:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FD -> FilePath
forall a. Show a => a -> FilePath
show FD
fd
  (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode
                       (Just (Stream,0,0)) -- avoid calling fstat()
                       False {-is_socket-}
                       False {-non-blocking-}
  fD' <- FD.setNonBlockingMode fD True -- see #3316
#if __GLASGOW_HASKELL__ >= 704
  enc <- getLocaleEncoding
#else
  let enc = localeEncoding
#endif
  mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)

#if defined(__IO_MANAGER_WINIO__)
-- It is not completely safe to pass the values -1 and -2 as HANDLE as it's an
-- unsigned type. -1 additionally is also the value for INVALID_HANDLE.  However
-- it should be safe in this case since an invalid handle would be an error here
-- anyway and the chances of us getting a handle with a value of -2 is
-- astronomical. However, sometime in the future process should really use a
-- proper structure here.
mbHANDLE :: HANDLE -> StdStream -> IO HANDLE
mbHANDLE _std CreatePipe      = return $ intPtrToPtr (-1)
mbHANDLE  std Inherit         = return std
mbHANDLE _std NoStream        = return $ intPtrToPtr (-2)
mbHANDLE _std (UseHandle hdl) = handleToHANDLE hdl

mbPipeHANDLE :: StdStream -> Ptr HANDLE -> IOMode -> IO (Maybe Handle)
mbPipeHANDLE CreatePipe pfd  mode =
  do raw_handle <- peek pfd
     let hwnd  = fromHANDLE raw_handle :: Io NativeHandle
         ident = "hwnd:" ++ show raw_handle
     enc <- fmap Just getLocaleEncoding
     Just <$> mkHandleFromHANDLE hwnd Stream ident mode enc
mbPipeHANDLE _std      _pfd _mode = return Nothing
#endif