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