{-# 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
    ) 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
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)

-- 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)
#else
import System.Posix.Types
#endif

#ifdef 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 an every fd from 3 to the maximum of open files, which can be slow for high maximum of open files.
  CreateProcess -> Bool
create_group :: Bool,                    -- ^ Create a new process group
  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).
                                           --
                                           --   On Windows this has no effect.
                                           --
                                           --   @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; 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; 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; 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
showList :: [CreateProcess] -> ShowS
$cshowList :: [CreateProcess] -> ShowS
show :: CreateProcess -> FilePath
$cshow :: CreateProcess -> FilePath
showsPrec :: Int -> CreateProcess -> ShowS
$cshowsPrec :: Int -> CreateProcess -> ShowS
Show, CreateProcess -> CreateProcess -> Bool
(CreateProcess -> CreateProcess -> Bool)
-> (CreateProcess -> CreateProcess -> Bool) -> Eq CreateProcess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CreateProcess -> CreateProcess -> Bool
$c/= :: CreateProcess -> CreateProcess -> Bool
== :: CreateProcess -> CreateProcess -> Bool
$c== :: 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.
  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
showList :: [CmdSpec] -> ShowS
$cshowList :: [CmdSpec] -> ShowS
show :: CmdSpec -> FilePath
$cshow :: CmdSpec -> FilePath
showsPrec :: Int -> CmdSpec -> ShowS
$cshowsPrec :: Int -> CmdSpec -> ShowS
Show, CmdSpec -> CmdSpec -> Bool
(CmdSpec -> CmdSpec -> Bool)
-> (CmdSpec -> CmdSpec -> Bool) -> Eq CmdSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CmdSpec -> CmdSpec -> Bool
$c/= :: CmdSpec -> CmdSpec -> Bool
== :: CmdSpec -> CmdSpec -> Bool
$c== :: 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
/= :: StdStream -> StdStream -> Bool
$c/= :: StdStream -> StdStream -> Bool
== :: StdStream -> StdStream -> Bool
$c== :: 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
showList :: [StdStream] -> ShowS
$cshowList :: [StdStream] -> ShowS
show :: StdStream -> FilePath
$cshow :: StdStream -> FilePath
showsPrec :: Int -> StdStream -> ShowS
$cshowsPrec :: Int -> StdStream -> ShowS
Show)

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

{- | 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__ = OpenHandle { ProcessHandle__ -> PHANDLE
phdlProcessHandle :: PHANDLE }
                     | OpenExtHandle { phdlProcessHandle :: PHANDLE
                                     -- ^ the process
                                     , ProcessHandle__ -> PHANDLE
phdlJobHandle     :: PHANDLE
                                     -- ^ the job containing the process and
                                     -- its subprocesses
                                     }
                     | ClosedHandle ExitCode
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 :: 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 :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (-FD
1)
mbFd FilePath
_fun FD
std StdStream
Inherit         = FD -> IO FD
forall (m :: * -> *) a. Monad m => a -> m a
return FD
std
mbFd FilePath
_fn FD
_std StdStream
NoStream        = FD -> IO FD
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 (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
Maybe TextEncoding
Maybe (MVar Handle__)
HandleType
BufferMode
Newline
IORef (dec_state, Buffer Word8)
IORef (BufferList CharBufElem)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
haType :: Handle__ -> HandleType
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haBufferMode :: Handle__ -> BufferMode
haLastDecode :: ()
haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haEncoder :: ()
haDecoder :: ()
haCodec :: Handle__ -> Maybe TextEncoding
haInputNL :: Handle__ -> Newline
haOutputNL :: Handle__ -> Newline
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOtherSide :: Maybe (MVar Handle__)
haOutputNL :: Newline
haInputNL :: Newline
haCodec :: Maybe TextEncoding
haDecoder :: Maybe (TextDecoder dec_state)
haEncoder :: Maybe (TextEncoder enc_state)
haBuffers :: IORef (BufferList CharBufElem)
haCharBuffer :: IORef (Buffer CharBufElem)
haLastDecode :: IORef (dec_state, Buffer Word8)
haBufferMode :: BufferMode
haByteBuffer :: IORef (Buffer Word8)
haType :: HandleType
..} ->
    case dev -> Maybe FD
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
      Just FD
fd -> do
         -- clear the O_NONBLOCK flag on this FD, if it is set, since
         -- we're exposing it externally (see #3316)
         FD
fd' <- FD -> Bool -> IO FD
FD.setNonBlockingMode FD
fd Bool
False
         (Handle__, FD) -> IO (Handle__, FD)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle__ :: forall dev enc_state dec_state.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> HandleType
-> IORef (Buffer Word8)
-> BufferMode
-> IORef (dec_state, Buffer Word8)
-> IORef (Buffer CharBufElem)
-> IORef (BufferList CharBufElem)
-> Maybe (TextEncoder enc_state)
-> Maybe (TextDecoder dec_state)
-> Maybe TextEncoding
-> Newline
-> Newline
-> Maybe (MVar Handle__)
-> Handle__
Handle__{haDevice :: FD
haDevice=FD
fd',Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
Maybe TextEncoding
Maybe (MVar Handle__)
HandleType
BufferMode
Newline
IORef (dec_state, Buffer Word8)
IORef (BufferList CharBufElem)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer CharBufElem)
haBuffers :: IORef (BufferList CharBufElem)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
haOtherSide :: Maybe (MVar Handle__)
haOutputNL :: Newline
haInputNL :: Newline
haCodec :: Maybe TextEncoding
haDecoder :: Maybe (TextDecoder dec_state)
haEncoder :: Maybe (TextEncoder enc_state)
haBuffers :: IORef (BufferList CharBufElem)
haCharBuffer :: IORef (Buffer CharBufElem)
haLastDecode :: IORef (dec_state, Buffer Word8)
haBufferMode :: BufferMode
haByteBuffer :: IORef (Buffer Word8)
haType :: HandleType
..}, FD -> FD
FD.fdFD FD
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 (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 (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
fd <- Ptr FD -> IO FD
forall a. Storable a => Ptr a -> IO a
peek Ptr FD
pfd
  let filepath :: FilePath
filepath = FilePath
"fd:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FD -> FilePath
forall a. Show a => a -> FilePath
show FD
fd
  (FD
fD,IODeviceType
fd_type) <- FD
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD (FD -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
fd) IOMode
mode
                       ((IODeviceType, CDev, CIno) -> Maybe (IODeviceType, CDev, CIno)
forall a. a -> Maybe a
Just (IODeviceType
Stream,CDev
0,CIno
0)) -- avoid calling fstat()
                       Bool
False {-is_socket-}
                       Bool
False {-non-blocking-}
  FD
fD' <- FD -> Bool -> IO FD
FD.setNonBlockingMode FD
fD Bool
True -- see #3316
#if __GLASGOW_HASKELL__ >= 704
  TextEncoding
enc <- IO TextEncoding
getLocaleEncoding
#else
  let enc = localeEncoding
#endif
  FD
-> IODeviceType
-> FilePath
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
mkHandleFromFD FD
fD' IODeviceType
fd_type FilePath
filepath IOMode
mode Bool
False {-is_socket-} (TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
enc)