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 #else
  26 # ifdef __GLASGOW_HASKELL__
  27         runProcessWin32, translate,
  28 # endif
  29 #endif
  30         commandToProcess,
  31         withFilePathException, withCEnvironment
  32   ) where
  33
  34 import Prelude -- necessary to get dependencies right
  35
  36 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  37 import System.Posix.Types ( CPid )
  38 import System.IO        ( Handle )
  39 #else
  40 import Data.Word ( Word32 )
  41 #endif
  42
  43 import Data.Maybe       ( fromMaybe )
  44 # ifdef __GLASGOW_HASKELL__
  45 import GHC.IOBase       ( haFD, FD, Exception(..), IOException(..) )
  46 import GHC.Handle       ( stdin, stdout, stderr, withHandle_ )
  47 # elif __HUGS__
  48 import Hugs.Exception   ( Exception(..), IOException(..) )
  49 # endif
  50
  51 import Control.Exception ( handle, throwIO )
  52 import Foreign.C
  53 import Foreign
  54
  55 #ifdef __HUGS__
  56 {-# CFILES cbits/execvpe.c  #-}
  57 #endif
  58
  59 #include "HsBaseConfig.h"
  60
  61 -- ----------------------------------------------------------------------------
  62 -- ProcessHandle type
  63
  64 {- | A handle to a process, which can be used to wait for termination
  65      of the process using 'waitForProcess'.
  66
  67      None of the process-creation functions in this library wait for
  68      termination: they all return a 'ProcessHandle' which may be used
  69      to wait for the process later.
  70 -}
  71 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  72 type PHANDLE = CPid
  73 #else
  74 type PHANDLE = Word32
  75 #endif
  76
  77 newtype ProcessHandle = ProcessHandle PHANDLE
  78
  79 -- ----------------------------------------------------------------------------
  80
  81 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  82
  83 -- this function disables the itimer, which would otherwise cause confusing
  84 -- signals to be sent to the new process.
  85 foreign import ccall unsafe "pPrPr_disableITimers"
  86   pPrPr_disableITimers :: IO ()
  87
  88 foreign import ccall unsafe "execvpe"
  89   c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
  90
  91 #endif
  92
  93 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
  94
  95 #ifdef __GLASGOW_HASKELL__
  96 -- -----------------------------------------------------------------------------
  97 -- POSIX runProcess with signal handling in the child
  98
  99 runProcessPosix
 100   :: String
 101   -> FilePath                   -- ^ Filename of the executable
 102   -> [String]                   -- ^ Arguments to pass to the executable
 103   -> Maybe FilePath             -- ^ Optional path to the working directory
 104   -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)
 105   -> Maybe Handle               -- ^ Handle to use for @stdin@
 106   -> Maybe Handle               -- ^ Handle to use for @stdout@
 107   -> Maybe Handle               -- ^ Handle to use for @stderr@
 108   -> Maybe CLong                -- handler for SIGINT
 109   -> Maybe CLong                -- handler for SIGQUIT
 110   -> IO ProcessHandle
 111
 112 runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
 113         mb_sigint mb_sigquit
 114  = withFilePathException cmd $
 115      withHandle_ fun (fromMaybe stdin  mb_stdin)  $ \hndStdInput  ->
 116      withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
 117      withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
 118      maybeWith withCEnvironment mb_env $ \pEnv ->
 119      maybeWith withCString mb_cwd $ \pWorkDir ->
 120      withMany withCString (cmd:args) $ \cstrs ->
 121      let (set_int, inthand)
 122                 = case mb_sigint of
 123                         Nothing   -> (0, 0)
 124                         Just hand -> (1, hand)
 125          (set_quit, quithand)
 126                 = case mb_sigquit of
 127                         Nothing   -> (0, 0)
 128                         Just hand -> (1, hand)
 129      in
 130      withArray0 nullPtr cstrs $ \pargs -> do
 131          ph <- throwErrnoIfMinus1 fun $
 132                  c_runProcess pargs pWorkDir pEnv
 133                         (haFD hndStdInput)
 134                         (haFD hndStdOutput)
 135                         (haFD hndStdError)
 136                         set_int inthand set_quit quithand
 137          return (ProcessHandle ph)
 138
 139 foreign import ccall unsafe "runProcess"
 140   c_runProcess
 141         :: Ptr CString                  -- args
 142         -> CString                      -- working directory (or NULL)
 143         -> Ptr CString                  -- env (or NULL)
 144         -> FD                           -- stdin
 145         -> FD                           -- stdout
 146         -> FD                           -- stderr
 147         -> CInt                         -- non-zero: set child's SIGINT handler
 148         -> CLong                        -- SIGINT handler
 149         -> CInt                         -- non-zero: set child's SIGQUIT handler
 150         -> CLong                        -- SIGQUIT handler
 151         -> IO PHANDLE
 152
 153 #endif /* __GLASGOW_HASKELL__ */
 154
 155 ignoreSignal  = CONST_SIG_IGN :: CLong
 156 defaultSignal = CONST_SIG_DFL :: CLong
 157
 158 #else
 159
 160 #ifdef __GLASGOW_HASKELL__
 161
 162 runProcessWin32 fun cmd args mb_cwd mb_env
 163         mb_stdin mb_stdout mb_stderr extra_cmdline
 164  = withFilePathException cmd $
 165      withHandle_ fun (fromMaybe stdin  mb_stdin)  $ \hndStdInput  ->
 166      withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
 167      withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
 168      maybeWith withCEnvironment mb_env $ \pEnv -> do
 169      maybeWith withCString      mb_cwd $ \pWorkDir -> do
 170        let cmdline = translate cmd ++
 171                    concat (map ((' ':) . translate) args) ++
 172                    (if null extra_cmdline then "" else ' ':extra_cmdline)
 173        withCString cmdline $ \pcmdline -> do
 174          proc_handle <- throwErrnoIfMinus1 fun
 175                           (c_runProcess pcmdline pWorkDir pEnv
 176                                 (haFD hndStdInput)
 177                                 (haFD hndStdOutput)
 178                                 (haFD hndStdError))
 179          return (ProcessHandle proc_handle)
 180
 181 foreign import ccall unsafe "runProcess"
 182   c_runProcess
 183         :: CString
 184         -> CString
 185         -> Ptr ()
 186         -> FD
 187         -> FD
 188         -> FD
 189         -> IO PHANDLE
 190
 191 -- ------------------------------------------------------------------------
 192 -- Passing commands to the OS on Windows
 193
 194 {-
 195 On Windows this is tricky.  We use CreateProcess, passing a single
 196 command-line string (lpCommandLine) as its argument.  (CreateProcess
 197 is well documented on http://msdn.microsoft/com.)
 198
 199       - It parses the beginning of the string to find the command. If the
 200         file name has embedded spaces, it must be quoted, using double
 201         quotes thus
 202                 "foo\this that\cmd" arg1 arg2
 203
 204       - The invoked command can in turn access the entire lpCommandLine string,
 205         and the C runtime does indeed do so, parsing it to generate the
 206         traditional argument vector argv[0], argv[1], etc.  It does this
 207         using a complex and arcane set of rules which are described here:
 208
 209            http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
 210
 211         (if this URL stops working, you might be able to find it by
 212         searching for "Parsing C Command-Line Arguments" on MSDN.  Also,
 213         the code in the Microsoft C runtime that does this translation
 214         is shipped with VC++).
 215
 216 Our goal in runProcess is to take a command filename and list of
 217 arguments, and construct a string which inverts the translatsions
 218 described above, such that the program at the other end sees exactly
 219 the same arguments in its argv[] that we passed to rawSystem.
 220
 221 This inverse translation is implemented by 'translate' below.
 222
 223 Here are some pages that give informations on Windows-related
 224 limitations and deviations from Unix conventions:
 225
 226     http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
 227     Command lines and environment variables effectively limited to 8191
 228     characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
 229
 230     http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
 231     Command-line substitution under Windows XP. IIRC these facilities (or at
 232     least a large subset of them) are available on Win NT and 2000. Some
 233     might be available on Win 9x.
 234
 235     http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
 236     How CMD.EXE processes command lines.
 237
 238
 239 Note: CreateProcess does have a separate argument (lpApplicationName)
 240 with which you can specify the command, but we have to slap the
 241 command into lpCommandLine anyway, so that argv[0] is what a C program
 242 expects (namely the application name).  So it seems simpler to just
 243 use lpCommandLine alone, which CreateProcess supports.
 244 -}
 245
 246 -- Translate command-line arguments for passing to CreateProcess().
 247 translate :: String -> String
 248 translate str = '"' : snd (foldr escape (True,"\"") str)
 249   where escape '"'  (b,     str) = (True,  '\\' : '"'  : str)
 250         escape '\\' (True,  str) = (True,  '\\' : '\\' : str)
 251         escape '\\' (False, str) = (False, '\\' : str)
 252         escape c    (b,     str) = (False, c : str)
 253         -- See long comment above for what this function is trying to do.
 254         --
 255         -- The Bool passed back along the string is True iff the
 256         -- rest of the string is a sequence of backslashes followed by
 257         -- a double quote.
 258
 259 #endif /* __GLASGOW_HASKELL__ */
 260
 261 #endif
 262
 263 -- ----------------------------------------------------------------------------
 264 -- commandToProcess
 265
 266 {- | Turns a shell command into a raw command.  Usually this involves
 267      wrapping it in an invocation of the shell.
 268
 269    There's a difference in the signature of commandToProcess between
 270    the Windows and Unix versions.  On Unix, exec takes a list of strings,
 271    and we want to pass our command to /bin/sh as a single argument.
 272
 273    On Windows, CreateProcess takes a single string for the command,
 274    which is later decomposed by cmd.exe.  In this case, we just want
 275    to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line.  The
 276    command-line translation that we normally do for arguments on
 277    Windows isn't required (or desirable) here.
 278 -}
 279
 280 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 281
 282 commandToProcess
 283   :: String
 284   -> IO (FilePath,[String])
 285 commandToProcess string = return ("/bin/sh", ["-c", string])
 286
 287 #else
 288
 289 commandToProcess
 290   :: String
 291   -> IO (FilePath,String)
 292 commandToProcess string = do
 293   sysDir <- allocaBytes 1024 (\pdir -> c_getSystemDirectory pdir 1024 >> peekCString pdir)
 294   return (sysDir ++ "\\CMD.EXE", "/c " ++ string)
 295         -- We don't want to put the cmd into a single
 296         -- argument, because cmd.exe will not try to split it up.  Instead,
 297         -- we just tack the command on the end of the cmd.exe command line,
 298         -- which partly works.  There seem to be some quoting issues, but
 299         -- I don't have the energy to find+fix them right now (ToDo). --SDM
 300
 301 foreign import stdcall unsafe "GetSystemDirectoryA"
 302   c_getSystemDirectory
 303         :: CString
 304         -> CInt
 305         -> IO CInt
 306
 307 #endif
 308
 309 -- ----------------------------------------------------------------------------
 310 -- Utils
 311
 312 withFilePathException :: FilePath -> IO a -> IO a
 313 withFilePathException fpath act = handle mapEx act
 314   where
 315     mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
 316     mapEx e                                       = throwIO e
 317
 318 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 319 withCEnvironment :: [(String,String)] -> (Ptr CString  -> IO a) -> IO a
 320 withCEnvironment env act =
 321   let env' = map (\(name, val) -> name ++ ('=':val)) env
 322   in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
 323 #else
 324 withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
 325 withCEnvironment env act =
 326   let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env
 327   in withCString env' (act . castPtr)
 328 #endif
 329