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