System/Process/Internals.hs

   1 {-# OPTIONS_GHC -cpp -fffi #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  System.Process.Internals
   5 -- Copyright   :  (c) The University of Glasgow 2004
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  portable
  11 --
  12 -- Operations for creating and interacting with sub-processes.
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 -- #hide
  17 module System.Process.Internals (
  18         ProcessHandle(..), PHANDLE,
  19 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  20          pPrPr_disableITimers, c_execvpe,
  21         runProcessPosix, ignoreSignal, defaultSignal,
  22 #endif
  23         commandToProcess,
  24         withFilePathException, withCEnvironment
  25   ) where
  26
  27 import Prelude -- necessary to get dependencies right
  28
  29 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  30 import System.Posix.Types ( CPid )
  31 import GHC.IOBase       ( haFD, FD, Exception(..), IOException(..) )
  32 import GHC.Handle       ( stdin, stdout, stderr, withHandle_ )
  33 import System.IO        ( Handle )
  34 import Data.Maybe       ( fromMaybe )
  35 #else
  36 import Data.Word ( Word32 )
  37 #endif
  38
  39 import Control.Exception ( handle, throwIO )
  40 import Foreign.C
  41 import Foreign
  42
  43 #ifdef __HUGS__
  44 {-# CFILES cbits/execvpe.c  #-}
  45 #endif
  46
  47 #include "HsBaseConfig.h"
  48
  49 -- ----------------------------------------------------------------------------
  50 -- ProcessHandle type
  51
  52 {- | A handle to a process, which can be used to wait for termination
  53      of the process using 'waitForProcess'.
  54
  55      None of the process-creation functions in this library wait for
  56      termination: they all return a 'ProcessHandle' which may be used
  57      to wait for the process later.
  58 -}
  59 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  60 type PHANDLE = CPid
  61 #else
  62 type PHANDLE = Word32
  63 #endif
  64
  65 newtype ProcessHandle = ProcessHandle PHANDLE
  66
  67 -- ----------------------------------------------------------------------------
  68
  69 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  70
  71 -- this function disables the itimer, which would otherwise cause confusing
  72 -- signals to be sent to the new process.
  73 foreign import ccall unsafe "pPrPr_disableITimers"
  74   pPrPr_disableITimers :: IO ()
  75
  76 foreign import ccall unsafe "execvpe"
  77   c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
  78
  79 #endif
  80
  81 -- -----------------------------------------------------------------------------
  82 -- POSIX runProcess with signal handling in the child
  83
  84 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  85
  86 runProcessPosix
  87   :: String
  88   -> FilePath                   -- ^ Filename of the executable
  89   -> [String]                   -- ^ Arguments to pass to the executable
  90   -> Maybe FilePath             -- ^ Optional path to the working directory
  91   -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)
  92   -> Maybe Handle               -- ^ Handle to use for @stdin@
  93   -> Maybe Handle               -- ^ Handle to use for @stdout@
  94   -> Maybe Handle               -- ^ Handle to use for @stderr@
  95   -> Maybe CLong                -- handler for SIGINT
  96   -> Maybe CLong                -- handler for SIGQUIT
  97   -> IO ProcessHandle
  98
  99 runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
 100         mb_sigint mb_sigquit
 101  = withFilePathException cmd $
 102      withHandle_ fun (fromMaybe stdin  mb_stdin)  $ \hndStdInput  ->
 103      withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
 104      withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
 105      maybeWith withCEnvironment mb_env $ \pEnv ->
 106      maybeWith withCString mb_cwd $ \pWorkDir ->
 107      withMany withCString (cmd:args) $ \cstrs ->
 108      let (set_int, inthand)
 109                 = case mb_sigint of
 110                         Nothing   -> (0, 0)
 111                         Just hand -> (1, hand)
 112          (set_quit, quithand)
 113                 = case mb_sigquit of
 114                         Nothing   -> (0, 0)
 115                         Just hand -> (1, hand)
 116      in
 117      withArray0 nullPtr cstrs $ \pargs -> do
 118          ph <- throwErrnoIfMinus1 fun $
 119                  c_runProcess pargs pWorkDir pEnv
 120                         (haFD hndStdInput)
 121                         (haFD hndStdOutput)
 122                         (haFD hndStdError)
 123                         set_int inthand set_quit quithand
 124          return (ProcessHandle ph)
 125
 126 ignoreSignal  = CONST_SIG_IGN :: CLong
 127 defaultSignal = CONST_SIG_DFL :: CLong
 128
 129 foreign import ccall unsafe "runProcess"
 130   c_runProcess
 131         :: Ptr CString                  -- args
 132         -> CString                      -- working directory (or NULL)
 133         -> Ptr CString                  -- env (or NULL)
 134         -> FD                           -- stdin
 135         -> FD                           -- stdout
 136         -> FD                           -- stderr
 137         -> CInt                         -- non-zero: set child's SIGINT handler
 138         -> CLong                        -- SIGINT handler
 139         -> CInt                         -- non-zero: set child's SIGQUIT handler
 140         -> CLong                        -- SIGQUIT handler
 141         -> IO PHANDLE
 142
 143 #endif
 144
 145 -- ----------------------------------------------------------------------------
 146 -- commandToProcess
 147
 148 {- | Turns a shell command into a raw command.  Usually this involves
 149      wrapping it in an invocation of the shell.
 150
 151    There's a difference in the signature of commandToProcess between
 152    the Windows and Unix versions.  On Unix, exec takes a list of strings,
 153    and we want to pass our command to /bin/sh as a single argument.
 154
 155    On Windows, CreateProcess takes a single string for the command,
 156    which is later decomposed by cmd.exe.  In this case, we just want
 157    to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line.  The
 158    command-line translation that we normally do for arguments on
 159    Windows isn't required (or desirable) here.
 160 -}
 161
 162 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 163
 164 commandToProcess
 165   :: String
 166   -> IO (FilePath,[String])
 167 commandToProcess string = return ("/bin/sh", ["-c", string])
 168
 169 #else
 170
 171 commandToProcess
 172   :: String
 173   -> IO (FilePath,String)
 174 commandToProcess string = do
 175   sysDir <- allocaBytes 1024 (\pdir -> c_getSystemDirectory pdir 1024 >> peekCString pdir)
 176   return (sysDir ++ "\\CMD.EXE", "/c " ++ string)
 177         -- We don't want to put the cmd into a single
 178         -- argument, because cmd.exe will not try to split it up.  Instead,
 179         -- we just tack the command on the end of the cmd.exe command line,
 180         -- which partly works.  There seem to be some quoting issues, but
 181         -- I don't have the energy to find+fix them right now (ToDo). --SDM
 182
 183 foreign import stdcall unsafe "GetSystemDirectoryA"
 184   c_getSystemDirectory
 185         :: CString
 186         -> CInt
 187         -> IO CInt
 188
 189 #endif
 190
 191 -- ----------------------------------------------------------------------------
 192 -- Utils
 193
 194 withFilePathException :: FilePath -> IO a -> IO a
 195 withFilePathException fpath act = handle mapEx act
 196   where
 197     mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
 198     mapEx e                                       = throwIO e
 199
 200 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 201 withCEnvironment :: [(String,String)] -> (Ptr CString  -> IO a) -> IO a
 202 withCEnvironment env act =
 203   let env' = map (\(name, val) -> name ++ ('=':val)) env
 204   in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
 205 #else
 206 withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
 207 withCEnvironment env act =
 208   let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env
 209   in withCString env' (act . castPtr)
 210 #endif
 211