Remove Control.Parallel*, now in package parallel
[packages/random.git] / 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