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