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