System/Process/Common.hs

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

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

    #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{
      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.
      cwd          :: Maybe FilePath,          -- ^ Optional path to the working directory for the new process
      env          :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)
      std_in       :: StdStream,               -- ^ How to determine stdin
      std_out      :: StdStream,               -- ^ How to determine stdout
      std_err      :: StdStream,               -- ^ How to determine stderr
      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.
      create_group :: Bool,                    -- ^ Create a new process group
      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
      detach_console :: Bool,                  -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms.
                                               --
                                               --   @since 1.3.0.0
      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
      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
      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
      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
      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 (Show, Eq)

    -- | contains the handles returned by a call to createProcess_Internal
    data ProcRetHandles
      = ProcRetHandles { hStdInput      :: Maybe Handle
                       , hStdOutput     :: Maybe Handle
                       , hStdError      :: Maybe Handle
                       , 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 (Show, Eq)

    -- | construct a `ShellCommand` from a string literal
    --
    -- @since 1.2.1.0
    instance IsString CmdSpec where
      fromString = 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 (Eq, Show)

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

    data ProcessHandle__ = OpenHandle { phdlProcessHandle :: PHANDLE }
                         | OpenExtHandle { phdlProcessHandle :: PHANDLE
                                         -- ^ the process
                                         , 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 { phandle          :: !(MVar ProcessHandle__)
                      , mb_delegate_ctlc :: !Bool
                      , waitpidLock      :: !(MVar ())
                      }

    withFilePathException :: FilePath -> IO a -> IO a
    withFilePathException fpath act = handle mapEx act
      where
        mapEx ex = ioError (ioeSetFileName ex fpath)

    modifyProcessHandle
            :: ProcessHandle
            -> (ProcessHandle__ -> IO (ProcessHandle__, a))
            -> IO a
    modifyProcessHandle (ProcessHandle m _ _) io = modifyMVar m io

    withProcessHandle
            :: ProcessHandle
            -> (ProcessHandle__ -> IO a)
            -> IO a
    withProcessHandle (ProcessHandle m _ _) io = withMVar m io

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

    mbFd :: String -> FD -> StdStream -> IO FD
    mbFd _   _std CreatePipe      = return (-1)
    mbFd _fun std Inherit         = return std
    mbFd _fn _std NoStream        = return (-2)
    mbFd fun _std (UseHandle hdl) =
      withHandle fun hdl $ \Handle__{haDevice=dev,..} ->
        case cast dev of
          Just fd -> do
             -- clear the O_NONBLOCK flag on this FD, if it is set, since
             -- we're exposing it externally (see #3316)
             fd' <- FD.setNonBlockingMode fd False
             return (Handle__{haDevice=fd',..}, FD.fdFD fd')
          Nothing ->
              ioError (mkIOError illegalOperationErrorType
                          "createProcess" (Just hdl) Nothing
                       `ioeSetErrorString` "handle is not a file descriptor")

    mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
    mbPipe CreatePipe pfd  mode = fmap Just (pfdToHandle pfd mode)
    mbPipe _std      _pfd _mode = return Nothing

    pfdToHandle :: Ptr FD -> IOMode -> IO Handle
    pfdToHandle pfd mode = do
      fd <- peek pfd
      let filepath = "fd:" ++ show 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