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