Fix conditional pragma to work with 6.12
[packages/unix.git] / System / Posix / Process.hsc
1 {-# LANGUAGE ForeignFunctionInterface #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Trustworthy #-}
4 #endif
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module      :  System.Posix.Process
8 -- Copyright   :  (c) The University of Glasgow 2002
9 -- License     :  BSD-style (see the file libraries/base/LICENSE)
10 -- 
11 -- Maintainer  :  libraries@haskell.org
12 -- Stability   :  provisional
13 -- Portability :  non-portable (requires POSIX)
14 --
15 -- POSIX process support.  See also the System.Cmd and System.Process
16 -- modules in the process package.
17 --
18 -----------------------------------------------------------------------------
19
20 module System.Posix.Process (
21     -- * Processes
22
23     -- ** Forking and executing
24 #ifdef __GLASGOW_HASKELL__
25     forkProcess,
26 #endif
27     executeFile,
28     
29     -- ** Exiting
30     exitImmediately,
31
32     -- ** Process environment
33     getProcessID,
34     getParentProcessID,
35
36     -- ** Process groups
37     getProcessGroupID,
38     getProcessGroupIDOf,
39     createProcessGroupFor,
40     joinProcessGroup,
41     setProcessGroupIDOf,
42
43     -- ** Sessions
44     createSession,
45
46     -- ** Process times
47     ProcessTimes(..),
48     getProcessTimes,
49
50     -- ** Scheduling priority
51     nice,
52     getProcessPriority,
53     getProcessGroupPriority,
54     getUserPriority,
55     setProcessPriority,
56     setProcessGroupPriority,
57     setUserPriority,
58
59     -- ** Process status
60     ProcessStatus(..),
61     getProcessStatus,
62     getAnyProcessStatus,
63     getGroupProcessStatus,
64
65     -- ** Deprecated
66     createProcessGroup,
67     setProcessGroupID,
68
69  ) where
70
71 #include "HsUnix.h"
72
73 import Foreign.C.Error
74 import Foreign.C.String
75 import Foreign.C.Types ( CInt, CClock )
76 import Foreign.Marshal.Alloc ( alloca, allocaBytes )
77 import Foreign.Marshal.Array ( withArray0 )
78 import Foreign.Marshal.Utils ( withMany )
79 import Foreign.Ptr ( Ptr, nullPtr )
80 import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr )
81 import Foreign.Storable ( Storable(..) )
82 import System.Exit
83 import System.Posix.Process.Internals
84 import System.Posix.Types
85 import Control.Monad
86
87 #ifdef __GLASGOW_HASKELL__
88 import GHC.TopHandler   ( runIO )
89 #endif
90
91 #if __GLASGOW_HASKELL__ > 611
92 import System.Posix.Internals ( withFilePath )
93 #else
94 withFilePath :: FilePath -> (CString -> IO a) -> IO a
95 withFilePath = withCString
96 #endif
97
98 #ifdef __HUGS__
99 {-# CFILES cbits/HsUnix.c  #-}
100 #endif
101
102 -- -----------------------------------------------------------------------------
103 -- Process environment
104
105 -- | 'getProcessID' calls @getpid@ to obtain the 'ProcessID' for
106 --   the current process.
107 getProcessID :: IO ProcessID
108 getProcessID = c_getpid
109
110 foreign import ccall unsafe "getpid"
111    c_getpid :: IO CPid
112
113 -- | 'getProcessID' calls @getppid@ to obtain the 'ProcessID' for
114 --   the parent of the current process.
115 getParentProcessID :: IO ProcessID
116 getParentProcessID = c_getppid
117
118 foreign import ccall unsafe "getppid"
119   c_getppid :: IO CPid
120
121 -- | 'getProcessGroupID' calls @getpgrp@ to obtain the
122 --   'ProcessGroupID' for the current process.
123 getProcessGroupID :: IO ProcessGroupID
124 getProcessGroupID = c_getpgrp
125
126 foreign import ccall unsafe "getpgrp"
127   c_getpgrp :: IO CPid
128
129 -- | @'getProcessGroupIDOf' pid@ calls @getpgid@ to obtain the
130 --   'ProcessGroupID' for process @pid@.
131 getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID
132 getProcessGroupIDOf pid =
133   throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid)
134
135 foreign import ccall unsafe "getpgid"
136   c_getpgid :: CPid -> IO CPid
137
138 {-
139    To be added in the future, after the deprecation period for the
140    existing createProcessGroup has elapsed:
141
142 -- | 'createProcessGroup' calls @setpgid(0,0)@ to make
143 --   the current process a new process group leader.
144 createProcessGroup :: IO ProcessGroupID
145 createProcessGroup = do
146   throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0)
147   pgid <- getProcessGroupID
148   return pgid
149 -}
150
151 -- | @'createProcessGroupFor' pid@ calls @setpgid@ to make
152 --   process @pid@ a new process group leader.
153 createProcessGroupFor :: ProcessID -> IO ProcessGroupID
154 createProcessGroupFor pid = do
155   throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0)
156   return pid
157
158 -- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the
159 --   'ProcessGroupID' of the current process to @pgid@.
160 joinProcessGroup :: ProcessGroupID -> IO ()
161 joinProcessGroup pgid =
162   throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid)
163
164 {-
165    To be added in the future, after the deprecation period for the
166    existing setProcessGroupID has elapsed:
167
168 -- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the
169 --   'ProcessGroupID' of the current process to @pgid@.
170 setProcessGroupID :: ProcessGroupID -> IO ()
171 setProcessGroupID pgid =
172   throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid)
173 -}
174
175 -- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the
176 --   'ProcessGroupIDOf' for process @pid@ to @pgid@.
177 setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO ()
178 setProcessGroupIDOf pid pgid =
179   throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid)
180
181 foreign import ccall unsafe "setpgid"
182   c_setpgid :: CPid -> CPid -> IO CInt
183
184 -- | 'createSession' calls @setsid@ to create a new session
185 --   with the current process as session leader.
186 createSession :: IO ProcessGroupID
187 createSession = throwErrnoIfMinus1 "createSession" c_setsid
188
189 foreign import ccall unsafe "setsid"
190   c_setsid :: IO CPid
191
192 -- -----------------------------------------------------------------------------
193 -- Process times
194
195 -- All times in clock ticks (see getClockTick)
196
197 data ProcessTimes
198   = ProcessTimes { elapsedTime     :: ClockTick
199                  , userTime        :: ClockTick
200                  , systemTime      :: ClockTick
201                  , childUserTime   :: ClockTick
202                  , childSystemTime :: ClockTick
203                  }
204
205 -- | 'getProcessTimes' calls @times@ to obtain time-accounting
206 --   information for the current process and its children.
207 getProcessTimes :: IO ProcessTimes
208 getProcessTimes = do
209    allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do
210      elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms)
211      ut  <- (#peek struct tms, tms_utime)  p_tms
212      st  <- (#peek struct tms, tms_stime)  p_tms
213      cut <- (#peek struct tms, tms_cutime) p_tms
214      cst <- (#peek struct tms, tms_cstime) p_tms
215      return (ProcessTimes{ elapsedTime     = elapsed,
216                            userTime        = ut,
217                            systemTime      = st,
218                            childUserTime   = cut,
219                            childSystemTime = cst
220                           })
221
222 type CTms = ()
223
224 foreign import ccall unsafe "__hsunix_times"
225   c_times :: Ptr CTms -> IO CClock
226
227 -- -----------------------------------------------------------------------------
228 -- Process scheduling priority
229
230 nice :: Int -> IO ()
231 nice prio = do
232   resetErrno
233   res <- c_nice (fromIntegral prio)
234   when (res == -1) $ do
235     err <- getErrno
236     when (err /= eOK) (throwErrno "nice")
237
238 foreign import ccall unsafe "nice"
239   c_nice :: CInt -> IO CInt
240
241 getProcessPriority      :: ProcessID      -> IO Int
242 getProcessGroupPriority :: ProcessGroupID -> IO Int
243 getUserPriority         :: UserID         -> IO Int
244
245 getProcessPriority pid = do
246   r <- throwErrnoIfMinus1 "getProcessPriority" $
247          c_getpriority (#const PRIO_PROCESS) (fromIntegral pid)
248   return (fromIntegral r)
249
250 getProcessGroupPriority pid = do
251   r <- throwErrnoIfMinus1 "getProcessPriority" $
252          c_getpriority (#const PRIO_PGRP) (fromIntegral pid)
253   return (fromIntegral r)
254
255 getUserPriority uid = do
256   r <- throwErrnoIfMinus1 "getUserPriority" $
257          c_getpriority (#const PRIO_USER) (fromIntegral uid)
258   return (fromIntegral r)
259
260 foreign import ccall unsafe "getpriority"
261   c_getpriority :: CInt -> CInt -> IO CInt
262
263 setProcessPriority      :: ProcessID      -> Int -> IO ()
264 setProcessGroupPriority :: ProcessGroupID -> Int -> IO ()
265 setUserPriority         :: UserID         -> Int -> IO ()
266
267 setProcessPriority pid val = 
268   throwErrnoIfMinus1_ "setProcessPriority" $
269     c_setpriority (#const PRIO_PROCESS) (fromIntegral pid) (fromIntegral val)
270
271 setProcessGroupPriority pid val =
272   throwErrnoIfMinus1_ "setProcessPriority" $
273     c_setpriority (#const PRIO_PGRP) (fromIntegral pid) (fromIntegral val)
274
275 setUserPriority uid val =
276   throwErrnoIfMinus1_ "setUserPriority" $
277     c_setpriority (#const PRIO_USER) (fromIntegral uid) (fromIntegral val)
278
279 foreign import ccall unsafe "setpriority"
280   c_setpriority :: CInt -> CInt -> CInt -> IO CInt
281
282 -- -----------------------------------------------------------------------------
283 -- Forking, execution
284
285 #ifdef __GLASGOW_HASKELL__
286 {- | 'forkProcess' corresponds to the POSIX @fork@ system call.
287 The 'IO' action passed as an argument is executed in the child process; no other
288 threads will be copied to the child process.
289 On success, 'forkProcess' returns the child's 'ProcessID' to the parent process;
290 in case of an error, an exception is thrown.
291
292 'forkProcess' comes with a giant warning: since any other running
293 threads are not copied into the child process, it's easy to go wrong:
294 e.g. by accessing some shared resource that was held by another thread
295 in the parent.
296
297 GHC note: 'forkProcess' is not currently supported when using multiple
298 processors (@+RTS -N@), although it is supported with @-threaded@ as
299 long as only one processor is being used.
300 -}
301
302 forkProcess :: IO () -> IO ProcessID
303 forkProcess action = do
304   stable <- newStablePtr (runIO action)
305   pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)
306   freeStablePtr stable
307   return pid
308
309 foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
310 #endif /* __GLASGOW_HASKELL__ */
311
312 -- | @'executeFile' cmd args env@ calls one of the
313 --   @execv*@ family, depending on whether or not the current
314 --   PATH is to be searched for the command, and whether or not an
315 --   environment is provided to supersede the process's current
316 --   environment.  The basename (leading directory names suppressed) of
317 --   the command is passed to @execv*@ as @arg[0]@;
318 --   the argument list passed to 'executeFile' therefore 
319 --   begins with @arg[1]@.
320 executeFile :: FilePath                     -- ^ Command
321             -> Bool                         -- ^ Search PATH?
322             -> [String]                     -- ^ Arguments
323             -> Maybe [(String, String)]     -- ^ Environment
324             -> IO a
325 executeFile path search args Nothing = do
326   withFilePath path $ \s ->
327     withMany withFilePath (path:args) $ \cstrs ->
328       withArray0 nullPtr cstrs $ \arr -> do
329         pPrPr_disableITimers
330         if search 
331            then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr)
332            else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr)
333         return undefined -- never reached
334
335 executeFile path search args (Just env) = do
336   withFilePath path $ \s ->
337     withMany withFilePath (path:args) $ \cstrs ->
338       withArray0 nullPtr cstrs $ \arg_arr ->
339     let env' = map (\ (name, val) -> name ++ ('=' : val)) env in
340     withMany withFilePath env' $ \cenv ->
341       withArray0 nullPtr cenv $ \env_arr -> do
342         pPrPr_disableITimers
343         if search 
344            then throwErrnoPathIfMinus1_ "executeFile" path
345                    (c_execvpe s arg_arr env_arr)
346            else throwErrnoPathIfMinus1_ "executeFile" path
347                    (c_execve s arg_arr env_arr)
348         return undefined -- never reached
349
350 foreign import ccall unsafe "execvp"
351   c_execvp :: CString -> Ptr CString -> IO CInt
352
353 foreign import ccall unsafe "execv"
354   c_execv :: CString -> Ptr CString -> IO CInt
355
356 foreign import ccall unsafe "execve"
357   c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt
358
359 -- -----------------------------------------------------------------------------
360 -- Waiting for process termination
361
362 -- | @'getProcessStatus' blk stopped pid@ calls @waitpid@, returning
363 --   @'Just' tc@, the 'ProcessStatus' for process @pid@ if it is
364 --   available, 'Nothing' otherwise.  If @blk@ is 'False', then
365 --   @WNOHANG@ is set in the options for @waitpid@, otherwise not.
366 --   If @stopped@ is 'True', then @WUNTRACED@ is set in the
367 --   options for @waitpid@, otherwise not.
368 getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
369 getProcessStatus block stopped pid =
370   alloca $ \wstatp -> do
371     pid' <- throwErrnoIfMinus1Retry "getProcessStatus"
372                 (c_waitpid pid wstatp (waitOptions block stopped))
373     case pid' of
374       0  -> return Nothing
375       _  -> do ps <- readWaitStatus wstatp
376                return (Just ps)
377
378 -- safe, because this call might block
379 foreign import ccall safe "waitpid"
380   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
381
382 -- | @'getGroupProcessStatus' blk stopped pgid@ calls @waitpid@,
383 --   returning @'Just' (pid, tc)@, the 'ProcessID' and
384 --   'ProcessStatus' for any process in group @pgid@ if one is
385 --   available, 'Nothing' otherwise.  If @blk@ is 'False', then
386 --   @WNOHANG@ is set in the options for @waitpid@, otherwise not.
387 --   If @stopped@ is 'True', then @WUNTRACED@ is set in the
388 --   options for @waitpid@, otherwise not.
389 getGroupProcessStatus :: Bool
390                       -> Bool
391                       -> ProcessGroupID
392                       -> IO (Maybe (ProcessID, ProcessStatus))
393 getGroupProcessStatus block stopped pgid =
394   alloca $ \wstatp -> do
395     pid <- throwErrnoIfMinus1Retry "getGroupProcessStatus"
396                 (c_waitpid (-pgid) wstatp (waitOptions block stopped))
397     case pid of
398       0  -> return Nothing
399       _  -> do ps <- readWaitStatus wstatp
400                return (Just (pid, ps))
401 -- | @'getAnyProcessStatus' blk stopped@ calls @waitpid@, returning
402 --   @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus' for any
403 --   child process if one is available, 'Nothing' otherwise.  If
404 --   @blk@ is 'False', then @WNOHANG@ is set in the options for
405 --   @waitpid@, otherwise not.  If @stopped@ is 'True', then
406 --   @WUNTRACED@ is set in the options for @waitpid@, otherwise not.
407 getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
408 getAnyProcessStatus block stopped = getGroupProcessStatus block stopped 1
409
410 waitOptions :: Bool -> Bool -> CInt
411 --             block   stopped
412 waitOptions False False = (#const WNOHANG)
413 waitOptions False True  = (#const (WNOHANG|WUNTRACED))
414 waitOptions True  False = 0
415 waitOptions True  True  = (#const WUNTRACED)
416
417 -- Turn a (ptr to a) wait status into a ProcessStatus
418
419 readWaitStatus :: Ptr CInt -> IO ProcessStatus
420 readWaitStatus wstatp = do
421   wstat <- peek wstatp
422   decipherWaitStatus wstat
423
424 -- -----------------------------------------------------------------------------
425 -- Exiting
426
427 -- | @'exitImmediately' status@ calls @_exit@ to terminate the process
428 --   with the indicated exit @status@.
429 --   The operation never returns.
430 exitImmediately :: ExitCode -> IO ()
431 exitImmediately exitcode = c_exit (exitcode2Int exitcode)
432   where
433     exitcode2Int ExitSuccess = 0
434     exitcode2Int (ExitFailure n) = fromIntegral n
435
436 foreign import ccall unsafe "exit"
437   c_exit :: CInt -> IO ()
438
439 -- -----------------------------------------------------------------------------
440 -- Deprecated or subject to change
441
442 {-# DEPRECATED createProcessGroup "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use createProcessGroupFor instead." #-}
443 -- | @'createProcessGroup' pid@ calls @setpgid@ to make
444 --   process @pid@ a new process group leader.
445 --   This function is currently deprecated,
446 --   and might be changed to making the current
447 --   process a new process group leader in future versions.
448 createProcessGroup :: ProcessID -> IO ProcessGroupID
449 createProcessGroup pid = do
450   throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0)
451   return pid
452
453 {-# DEPRECATED setProcessGroupID "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use setProcessGroupIdOf instead." #-}
454 -- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the
455 --   'ProcessGroupID' for process @pid@ to @pgid@.
456 --   This function is currently deprecated,
457 --   and might be changed to setting the 'ProcessGroupID'
458 --   for the current process in future versions.
459 setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
460 setProcessGroupID pid pgid =
461   throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid)
462
463 -- -----------------------------------------------------------------------------