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