e349d9b494b5a0ab9b7f59ccbfa11a861f4c667f
[packages/random.git] / System / Process.hsc
1 {-# OPTIONS -cpp -fffi #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module      :  System.Process
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 -- ToDo:
17 --      * Flag to control whether exiting the parent also kills the child.
18 --      * Windows impl of runProcess should close the Handles.
19 --      * Add system/rawSystem replacements
20
21 {- NOTES on createPipe:
22  
23    createPipe is no longer exported, because of the following problems:
24
25         - it wasn't used to implement runInteractiveProcess on Unix, because
26           the file descriptors for the unused ends of the pipe need to be closed
27           in the child process.
28
29         - on Windows, a special version of createPipe is needed that sets
30           the inheritance flags correctly on the ends of the pipe (see
31           mkAnonPipe below).
32 -}
33
34 module System.Process (
35         -- * Running sub-processes
36         ProcessHandle,
37         runCommand,
38         runProcess,
39         runInteractiveCommand,
40         runInteractiveProcess,
41
42         -- * Process completion
43         waitForProcess,
44         getProcessExitCode,
45         terminateProcess,
46  ) where
47
48 import System.Process.Internals
49
50 import Foreign
51 import Foreign.C 
52 import Data.Maybe       ( fromMaybe )
53 import System.IO        ( IOMode(..), Handle )
54 import System.Exit      ( ExitCode(..) )
55 import Control.Exception ( handle, throwIO )
56
57 import System.Posix.Internals
58 import GHC.IOBase       ( haFD, FD, Exception(..), IOException(..) )
59 import GHC.Handle       ( stdin, stdout, stderr, withHandle_, openFd )
60
61 -- ----------------------------------------------------------------------------
62 -- runCommand
63
64 {- | Runs a command using the shell.
65  -}
66 runCommand
67   :: String
68   -> IO ProcessHandle
69
70 runCommand string = do
71   (cmd,args) <- commandToProcess string
72 #if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
73   runProcess1 "runProcess" cmd args Nothing Nothing Nothing Nothing Nothing
74 #else
75   runProcess1 "runProcess" cmd [] Nothing Nothing Nothing Nothing Nothing args
76 #endif
77
78 -- ----------------------------------------------------------------------------
79 -- runProcess
80
81 {- | Runs a raw command, optionally specifying 'Handle's from which to
82      take the @stdin@, @stdout@ and @stderr@ channels for the new
83      process.  
84
85      Any 'Handle's passed to 'runProcess' are placed immediately in the 
86      closed state, so may no longer be referenced by the Haskell process.
87 -}
88 runProcess
89   :: FilePath                   -- ^ Filename of the executable
90   -> [String]                   -- ^ Arguments to pass to the executable
91   -> Maybe FilePath             -- ^ Optional path to the working directory
92   -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)
93   -> Maybe Handle               -- ^ Handle to use for @stdin@
94   -> Maybe Handle               -- ^ Handle to use for @stdout@
95   -> Maybe Handle               -- ^ Handle to use for @stderr@
96   -> IO ProcessHandle
97
98 #if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
99
100 runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
101  = runProcess1 "runProcess" cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
102
103 runProcess1 fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
104  = withFilePathException cmd $
105      withHandle_ fun (fromMaybe stdin  mb_stdin)  $ \hndStdInput  ->
106      withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
107      withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
108      maybeWith withCEnvironment mb_env $ \pEnv ->
109      maybeWith withCString mb_cwd $ \pWorkDir ->
110      withMany withCString (cmd:args) $ \cstrs ->
111      withArray0 nullPtr cstrs $ \pargs -> do
112          ph <- throwErrnoIfMinus1 fun
113                 (c_runProcess pargs pWorkDir pEnv 
114                         (haFD hndStdInput)
115                         (haFD hndStdOutput)
116                         (haFD hndStdError))
117          return (ProcessHandle ph)
118
119 foreign import ccall unsafe "runProcess" 
120   c_runProcess
121         :: Ptr CString                  -- args
122         -> CString                      -- working directory (or NULL)
123         -> Ptr CString                  -- env (or NULL)
124         -> FD                           -- stdin
125         -> FD                           -- stdout
126         -> FD                           -- stderr
127         -> IO PHANDLE
128
129 #else
130
131 runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr =
132   runProcess1 "runProcess" cmd args mb_cwd mb_env 
133         mb_stdin mb_stdout mb_stderr ""
134
135 runProcess1 fun cmd args mb_cwd mb_env
136         mb_stdin mb_stdout mb_stderr extra_cmdline
137  = withFilePathException cmd $
138      withHandle_ fun (fromMaybe stdin  mb_stdin)  $ \hndStdInput  ->
139      withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
140      withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
141      maybeWith withCEnvironment mb_env $ \pEnv -> do
142      maybeWith withCString      mb_cwd $ \pWorkDir -> do
143        let cmdline = translate cmd ++ 
144                    concat (map ((' ':) . translate) args) ++
145                    (if null extra_cmdline then "" else ' ':extra_cmdline)
146        withCString cmdline $ \pcmdline -> do
147          proc_handle <- throwErrnoIfMinus1 fun
148                           (c_runProcess pcmdline pWorkDir pEnv 
149                                 (haFD hndStdInput)
150                                 (haFD hndStdOutput)
151                                 (haFD hndStdError))
152          return (ProcessHandle proc_handle)
153
154 foreign import ccall unsafe "runProcess" 
155   c_runProcess
156         :: CString
157         -> CString
158         -> Ptr ()
159         -> FD
160         -> FD
161         -> FD
162         -> IO PHANDLE
163
164      -- Set the standard HANDLEs for the child process appropriately.  NOTE:
165      -- this relies on the HANDLEs being inheritable.  By default, the
166      -- runtime open() function creates inheritable handles (unless O_NOINHERIT
167      -- is specified).  But perhaps we should DuplicateHandle() to make sure
168      -- the handle is inheritable?
169 #endif
170
171 -- ----------------------------------------------------------------------------
172 -- runInteractiveCommand
173
174 {- | Runs a command using the shell, and returns 'Handle's that may
175      be used to communicate with the process via its @stdin@, @stdout@,
176      and @stderr@ respectively.
177 -}
178 runInteractiveCommand
179   :: String
180   -> IO (Handle,Handle,Handle,ProcessHandle)
181
182 runInteractiveCommand string = do
183   (cmd,args) <- commandToProcess string
184 #if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
185   runInteractiveProcess1 "runInteractiveCommand" cmd args Nothing Nothing
186 #else
187   runInteractiveProcess1 "runInteractiveCommand" cmd [] Nothing Nothing args
188 #endif
189
190 -- ----------------------------------------------------------------------------
191 -- runInteractiveProcess
192
193 {- | Runs a raw command, and returns 'Handle's that may be used to communicate
194      with the process via its @stdin@, @stdout@ and @stderr@ respectively.
195
196     For example, to start a process and feed a string to its stdin:
197    
198 >   (in,out,err,pid) <- runInteractiveProcess "..."
199 >   forkIO (hPutStr in str)
200 -}
201 runInteractiveProcess
202   :: FilePath                   -- ^ Filename of the executable
203   -> [String]                   -- ^ Arguments to pass to the executable
204   -> Maybe FilePath             -- ^ Optional path to the working directory
205   -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)
206   -> IO (Handle,Handle,Handle,ProcessHandle)
207
208 #if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
209
210 runInteractiveProcess cmd args mb_cwd mb_env = 
211   runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env
212
213 runInteractiveProcess1 fun cmd args mb_cwd mb_env = do
214   withFilePathException cmd $
215    alloca $ \ pfdStdInput  ->
216    alloca $ \ pfdStdOutput ->
217    alloca $ \ pfdStdError  ->
218    maybeWith withCEnvironment mb_env $ \pEnv ->
219    maybeWith withCString mb_cwd $ \pWorkDir ->
220    withMany withCString (cmd:args) $ \cstrs ->
221    withArray0 nullPtr cstrs $ \pargs -> do
222      proc_handle <- throwErrnoIfMinus1 fun
223                           (c_runInteractiveProcess pargs pWorkDir pEnv 
224                                 pfdStdInput pfdStdOutput pfdStdError)
225      hndStdInput  <- fdToHandle pfdStdInput  WriteMode
226      hndStdOutput <- fdToHandle pfdStdOutput ReadMode
227      hndStdError  <- fdToHandle pfdStdError  ReadMode
228      return (hndStdInput, hndStdOutput, hndStdError, ProcessHandle proc_handle)
229
230 foreign import ccall unsafe "runInteractiveProcess" 
231   c_runInteractiveProcess
232         ::  Ptr CString
233         -> CString
234         -> Ptr CString
235         -> Ptr FD
236         -> Ptr FD
237         -> Ptr FD
238         -> IO PHANDLE
239
240 #else
241
242 runInteractiveProcess cmd args mb_cwd mb_env = 
243   runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env ""
244
245 runInteractiveProcess1 fun cmd args workDir env extra_cmdline
246  = withFilePathException cmd $ do
247      let cmdline = translate cmd ++ 
248                        concat (map ((' ':) . translate) args) ++
249                        (if null extra_cmdline then "" else ' ':extra_cmdline)
250      withCString cmdline $ \pcmdline ->
251       alloca $ \ pfdStdInput  ->
252       alloca $ \ pfdStdOutput ->
253       alloca $ \ pfdStdError  -> do
254       maybeWith withCEnvironment env $ \pEnv -> do
255       maybeWith withCString workDir $ \pWorkDir -> do
256         proc_handle <- throwErrnoIfMinus1 fun $
257                              c_runInteractiveProcess pcmdline pWorkDir pEnv
258                                   pfdStdInput pfdStdOutput pfdStdError
259         hndStdInput  <- fdToHandle pfdStdInput  WriteMode
260         hndStdOutput <- fdToHandle pfdStdOutput ReadMode
261         hndStdError  <- fdToHandle pfdStdError  ReadMode
262         return (hndStdInput, hndStdOutput, hndStdError, 
263                 ProcessHandle proc_handle)
264
265 foreign import ccall unsafe "runInteractiveProcess" 
266   c_runInteractiveProcess
267         :: CString 
268         -> CString
269         -> Ptr ()
270         -> Ptr FD
271         -> Ptr FD
272         -> Ptr FD
273         -> IO PHANDLE
274
275 #endif
276
277 fdToHandle :: Ptr FD -> IOMode -> IO Handle
278 fdToHandle pfd mode = do
279   fd <- peek pfd
280   openFd fd (Just Stream) 
281 #if __GLASGOW_HASKELL__ >= 603
282      False{-not a socket-}
283 #endif
284      ("fd:" ++ show fd) mode True{-binary-} False{-no truncate-}
285
286 -- ----------------------------------------------------------------------------
287 -- waitForProcess
288
289 {- | Waits for the specified process to terminate, and returns its exit code.
290    
291      GHC Note: in order to call waitForProcess without blocking all the
292      other threads in the system, you must compile the program with
293      @-threaded@.
294 -}
295 waitForProcess
296   :: ProcessHandle
297   -> IO ExitCode
298 waitForProcess (ProcessHandle handle) = do
299   code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess handle)
300   if (code == 0) 
301     then return ExitSuccess
302     else return (ExitFailure (fromIntegral code))
303
304 -- ----------------------------------------------------------------------------
305 -- terminateProcess
306
307 -- | Attempts to terminate the specified process.  This function should
308 -- not be used under normal circumstances - no guarantees are given regarding
309 -- how cleanly the process is terminated.  To check whether the process
310 -- has indeed terminated, use 'getProcessExitCode'.
311 --
312 -- On Unix systems, 'terminateProcess' sends the process the SIGKILL signal.
313 -- On Windows systems, the Win32 @TerminateProcess@ function is called, passing
314 -- an exit code of 1.
315 terminateProcess :: ProcessHandle -> IO ()
316 terminateProcess (ProcessHandle pid) =
317   throwErrnoIfMinus1_ "terminateProcess" (c_terminateProcess pid)
318
319 -- ----------------------------------------------------------------------------
320 -- getProcessExitCode
321
322 {- | Verifies whether the process is completed and if it is then returns the exit code.
323    If the process is still running the function returns Nothing
324 -}
325 getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
326 getProcessExitCode (ProcessHandle handle) =
327   alloca $ \pExitCode -> do
328     res <- throwErrnoIfMinus1 "getProcessExitCode" (c_getProcessExitCode handle pExitCode)
329     code <- peek pExitCode
330     if res == 0
331       then return Nothing
332       else if code == 0
333              then return (Just ExitSuccess)
334              else return (Just (ExitFailure (fromIntegral code)))
335
336 -- ----------------------------------------------------------------------------
337 -- commandToProcess
338
339 {- | Turns a shell command into a raw command.  Usually this involves
340      wrapping it in an invocation of the shell.
341
342    There's a difference in the signature of commandToProcess between
343    the Windows and Unix versions.  On Unix, exec takes a list of strings,
344    and we want to pass our command to /bin/sh as a single argument.  
345
346    On Windows, CreateProcess takes a single string for the command,
347    which is later decomposed by cmd.exe.  In this case, we just want
348    to prepend "c:\WINDOWS\CMD.EXE /c" to our command line.  The
349    command-line translation that we normally do for arguments on
350    Windows isn't required (or desirable) here.
351 -}
352
353 #if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
354
355 commandToProcess
356   :: String
357   -> IO (FilePath,[String])
358 commandToProcess string = return ("/bin/sh", ["-c", string])
359
360 #else
361
362 commandToProcess
363   :: String
364   -> IO (FilePath,String)
365 commandToProcess string = do
366   sysDir <- allocaBytes 1024 (\pdir -> c_getSystemDirectory pdir 1024 >> peekCString pdir)
367   return (sysDir ++ "\\CMD.EXE", "/c " ++ string)
368         -- We don't want to put the cmd into a single
369         -- argument, because cmd.exe will not try to split it up.  Instead,
370         -- we just tack the command on the end of the cmd.exe command line,
371         -- which partly works.  There seem to be some quoting issues, but
372         -- I don't have the energy to find+fix them right now (ToDo). --SDM
373
374 foreign import stdcall unsafe "GetSystemDirectoryA" 
375   c_getSystemDirectory 
376         :: CString 
377         -> CInt 
378         -> IO CInt
379
380 #endif
381
382 -- ----------------------------------------------------------------------------
383 -- Utils
384
385 withFilePathException :: FilePath -> IO a -> IO a
386 withFilePathException fpath act = handle mapEx act
387   where
388     mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
389     mapEx e                                       = throwIO e
390
391 #if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
392 withCEnvironment :: [(String,String)] -> (Ptr CString  -> IO a) -> IO a
393 withCEnvironment env act =
394   let env' = map (\(name, val) -> name ++ ('=':val)) env 
395   in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
396 #else
397 withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
398 withCEnvironment env act =
399   let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env 
400   in withCString env' (act . castPtr)
401 #endif
402
403
404 -- ----------------------------------------------------------------------------
405 -- Interface to C bits
406
407 foreign import ccall unsafe "terminateProcess"
408   c_terminateProcess
409         :: PHANDLE
410         -> IO CInt
411
412 foreign import ccall unsafe "getProcessExitCode"
413   c_getProcessExitCode
414         :: PHANDLE
415         -> Ptr CInt
416         -> IO CInt
417
418 foreign import ccall safe "waitForProcess" -- NB. safe - can block
419   c_waitForProcess
420         :: PHANDLE
421         -> IO CInt
422
423 -- ------------------------------------------------------------------------
424 -- Passing commands to the OS on Windows
425
426 {-
427 On Windows this is tricky.  We use CreateProcess, passing a single
428 command-line string (lpCommandLine) as its argument.  (CreateProcess
429 is well documented on http://msdn.microsoft/com.)
430
431       - It parses the beginning of the string to find the command. If the
432         file name has embedded spaces, it must be quoted, using double
433         quotes thus 
434                 "foo\this that\cmd" arg1 arg2
435
436       - The invoked command can in turn access the entire lpCommandLine string,
437         and the C runtime does indeed do so, parsing it to generate the 
438         traditional argument vector argv[0], argv[1], etc.  It does this
439         using a complex and arcane set of rules which are described here:
440         
441            http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
442
443         (if this URL stops working, you might be able to find it by
444         searching for "Parsing C Command-Line Arguments" on MSDN.  Also,
445         the code in the Microsoft C runtime that does this translation
446         is shipped with VC++).
447
448 Our goal in runProcess is to take a command filename and list of
449 arguments, and construct a string which inverts the translatsions
450 described above, such that the program at the other end sees exactly
451 the same arguments in its argv[] that we passed to rawSystem.
452
453 This inverse translation is implemented by 'translate' below.
454
455 Here are some pages that give informations on Windows-related 
456 limitations and deviations from Unix conventions:
457
458     http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
459     Command lines and environment variables effectively limited to 8191 
460     characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
461
462     http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
463     Command-line substitution under Windows XP. IIRC these facilities (or at 
464     least a large subset of them) are available on Win NT and 2000. Some 
465     might be available on Win 9x.
466
467     http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
468     How CMD.EXE processes command lines.
469
470
471 Note: CreateProcess does have a separate argument (lpApplicationName)
472 with which you can specify the command, but we have to slap the
473 command into lpCommandLine anyway, so that argv[0] is what a C program
474 expects (namely the application name).  So it seems simpler to just
475 use lpCommandLine alone, which CreateProcess supports.
476 -}
477
478 #if defined(mingw32_TARGET_OS)
479
480 -- Translate command-line arguments for passing to CreateProcess().
481 translate :: String -> String
482 translate str = '"' : snd (foldr escape (True,"\"") str)
483   where escape '"'  (b,     str) = (True,  '\\' : '"'  : str)
484         escape '\\' (True,  str) = (True,  '\\' : '\\' : str)
485         escape '\\' (False, str) = (False, '\\' : str)
486         escape c    (b,     str) = (False, c : str)
487         -- See long comment above for what this function is trying to do.
488         --
489         -- The Bool passed back along the string is True iff the
490         -- rest of the string is a sequence of backslashes followed by
491         -- a double quote.
492
493 #endif