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