fix documentation for getAnyProcessStatus/getGroupProcessStatus (#5946)
[packages/unix.git] / System / Posix / Process / Common.hsc
1 {-# LANGUAGE ForeignFunctionInterface #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Trustworthy #-}
4 #endif
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module      :  System.Posix.Process.Common
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.Common (
21     -- * Processes
22
23     -- ** Forking and executing
24 #ifdef __GLASGOW_HASKELL__
25     forkProcess,
26 #endif
27
28     -- ** Exiting
29     exitImmediately,
30
31     -- ** Process environment
32     getProcessID,
33     getParentProcessID,
34
35     -- ** Process groups
36     getProcessGroupID,
37     getProcessGroupIDOf,
38     createProcessGroupFor,
39     joinProcessGroup,
40     setProcessGroupIDOf,
41
42     -- ** Sessions
43     createSession,
44
45     -- ** Process times
46     ProcessTimes(..),
47     getProcessTimes,
48
49     -- ** Scheduling priority
50     nice,
51     getProcessPriority,
52     getProcessGroupPriority,
53     getUserPriority,
54     setProcessPriority,
55     setProcessGroupPriority,
56     setUserPriority,
57
58     -- ** Process status
59     ProcessStatus(..),
60     getProcessStatus,
61     getAnyProcessStatus,
62     getGroupProcessStatus,
63
64     -- ** Deprecated
65     createProcessGroup,
66     setProcessGroupID,
67
68  ) where
69
70 #include "HsUnix.h"
71
72 import Foreign.C.Error
73 import Foreign.C.Types
74 import Foreign.Marshal.Alloc ( alloca, allocaBytes )
75 import Foreign.Ptr ( Ptr )
76 import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr )
77 import Foreign.Storable ( Storable(..) )
78 import System.Exit
79 import System.Posix.Process.Internals
80 import System.Posix.Types
81 import Control.Monad
82
83 #ifdef __GLASGOW_HASKELL__
84 import GHC.TopHandler   ( runIO )
85 #endif
86
87 #ifdef __HUGS__
88 {-# CFILES cbits/HsUnix.c  #-}
89 #endif
90
91 -- -----------------------------------------------------------------------------
92 -- Process environment
93
94 -- | 'getProcessID' calls @getpid@ to obtain the 'ProcessID' for
95 --   the current process.
96 getProcessID :: IO ProcessID
97 getProcessID = c_getpid
98
99 foreign import ccall unsafe "getpid"
100    c_getpid :: IO CPid
101
102 -- | 'getProcessID' calls @getppid@ to obtain the 'ProcessID' for
103 --   the parent of the current process.
104 getParentProcessID :: IO ProcessID
105 getParentProcessID = c_getppid
106
107 foreign import ccall unsafe "getppid"
108   c_getppid :: IO CPid
109
110 -- | 'getProcessGroupID' calls @getpgrp@ to obtain the
111 --   'ProcessGroupID' for the current process.
112 getProcessGroupID :: IO ProcessGroupID
113 getProcessGroupID = c_getpgrp
114
115 foreign import ccall unsafe "getpgrp"
116   c_getpgrp :: IO CPid
117
118 -- | @'getProcessGroupIDOf' pid@ calls @getpgid@ to obtain the
119 --   'ProcessGroupID' for process @pid@.
120 getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID
121 getProcessGroupIDOf pid =
122   throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid)
123
124 foreign import ccall unsafe "getpgid"
125   c_getpgid :: CPid -> IO CPid
126
127 {-
128    To be added in the future, after the deprecation period for the
129    existing createProcessGroup has elapsed:
130
131 -- | 'createProcessGroup' calls @setpgid(0,0)@ to make
132 --   the current process a new process group leader.
133 createProcessGroup :: IO ProcessGroupID
134 createProcessGroup = do
135   throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0)
136   pgid <- getProcessGroupID
137   return pgid
138 -}
139
140 -- | @'createProcessGroupFor' pid@ calls @setpgid@ to make
141 --   process @pid@ a new process group leader.
142 createProcessGroupFor :: ProcessID -> IO ProcessGroupID
143 createProcessGroupFor pid = do
144   throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0)
145   return pid
146
147 -- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the
148 --   'ProcessGroupID' of the current process to @pgid@.
149 joinProcessGroup :: ProcessGroupID -> IO ()
150 joinProcessGroup pgid =
151   throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid)
152
153 {-
154    To be added in the future, after the deprecation period for the
155    existing setProcessGroupID has elapsed:
156
157 -- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the
158 --   'ProcessGroupID' of the current process to @pgid@.
159 setProcessGroupID :: ProcessGroupID -> IO ()
160 setProcessGroupID pgid =
161   throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid)
162 -}
163
164 -- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the
165 --   'ProcessGroupIDOf' for process @pid@ to @pgid@.
166 setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO ()
167 setProcessGroupIDOf pid pgid =
168   throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid)
169
170 foreign import ccall unsafe "setpgid"
171   c_setpgid :: CPid -> CPid -> IO CInt
172
173 -- | 'createSession' calls @setsid@ to create a new session
174 --   with the current process as session leader.
175 createSession :: IO ProcessGroupID
176 createSession = throwErrnoIfMinus1 "createSession" c_setsid
177
178 foreign import ccall unsafe "setsid"
179   c_setsid :: IO CPid
180
181 -- -----------------------------------------------------------------------------
182 -- Process times
183
184 -- All times in clock ticks (see getClockTick)
185
186 data ProcessTimes
187   = ProcessTimes { elapsedTime     :: ClockTick
188                  , userTime        :: ClockTick
189                  , systemTime      :: ClockTick
190                  , childUserTime   :: ClockTick
191                  , childSystemTime :: ClockTick
192                  }
193
194 -- | 'getProcessTimes' calls @times@ to obtain time-accounting
195 --   information for the current process and its children.
196 getProcessTimes :: IO ProcessTimes
197 getProcessTimes = do
198    allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do
199      elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms)
200      ut  <- (#peek struct tms, tms_utime)  p_tms
201      st  <- (#peek struct tms, tms_stime)  p_tms
202      cut <- (#peek struct tms, tms_cutime) p_tms
203      cst <- (#peek struct tms, tms_cstime) p_tms
204      return (ProcessTimes{ elapsedTime     = elapsed,
205                            userTime        = ut,
206                            systemTime      = st,
207                            childUserTime   = cut,
208                            childSystemTime = cst
209                           })
210
211 type CTms = ()
212
213 foreign import ccall unsafe "__hsunix_times"
214   c_times :: Ptr CTms -> IO CClock
215
216 -- -----------------------------------------------------------------------------
217 -- Process scheduling priority
218
219 nice :: Int -> IO ()
220 nice prio = do
221   resetErrno
222   res <- c_nice (fromIntegral prio)
223   when (res == -1) $ do
224     err <- getErrno
225     when (err /= eOK) (throwErrno "nice")
226
227 foreign import ccall unsafe "nice"
228   c_nice :: CInt -> IO CInt
229
230 getProcessPriority      :: ProcessID      -> IO Int
231 getProcessGroupPriority :: ProcessGroupID -> IO Int
232 getUserPriority         :: UserID         -> IO Int
233
234 getProcessPriority pid = do
235   r <- throwErrnoIfMinus1 "getProcessPriority" $
236          c_getpriority (#const PRIO_PROCESS) (fromIntegral pid)
237   return (fromIntegral r)
238
239 getProcessGroupPriority pid = do
240   r <- throwErrnoIfMinus1 "getProcessPriority" $
241          c_getpriority (#const PRIO_PGRP) (fromIntegral pid)
242   return (fromIntegral r)
243
244 getUserPriority uid = do
245   r <- throwErrnoIfMinus1 "getUserPriority" $
246          c_getpriority (#const PRIO_USER) (fromIntegral uid)
247   return (fromIntegral r)
248
249 foreign import ccall unsafe "getpriority"
250   c_getpriority :: CInt -> CInt -> IO CInt
251
252 setProcessPriority      :: ProcessID      -> Int -> IO ()
253 setProcessGroupPriority :: ProcessGroupID -> Int -> IO ()
254 setUserPriority         :: UserID         -> Int -> IO ()
255
256 setProcessPriority pid val = 
257   throwErrnoIfMinus1_ "setProcessPriority" $
258     c_setpriority (#const PRIO_PROCESS) (fromIntegral pid) (fromIntegral val)
259
260 setProcessGroupPriority pid val =
261   throwErrnoIfMinus1_ "setProcessPriority" $
262     c_setpriority (#const PRIO_PGRP) (fromIntegral pid) (fromIntegral val)
263
264 setUserPriority uid val =
265   throwErrnoIfMinus1_ "setUserPriority" $
266     c_setpriority (#const PRIO_USER) (fromIntegral uid) (fromIntegral val)
267
268 foreign import ccall unsafe "setpriority"
269   c_setpriority :: CInt -> CInt -> CInt -> IO CInt
270
271 -- -----------------------------------------------------------------------------
272 -- Forking, execution
273
274 #ifdef __GLASGOW_HASKELL__
275 {- | 'forkProcess' corresponds to the POSIX @fork@ system call.
276 The 'IO' action passed as an argument is executed in the child process; no other
277 threads will be copied to the child process.
278 On success, 'forkProcess' returns the child's 'ProcessID' to the parent process;
279 in case of an error, an exception is thrown.
280
281 'forkProcess' comes with a giant warning: since any other running
282 threads are not copied into the child process, it's easy to go wrong:
283 e.g. by accessing some shared resource that was held by another thread
284 in the parent.
285 -}
286
287 forkProcess :: IO () -> IO ProcessID
288 forkProcess action = do
289   stable <- newStablePtr (runIO action)
290   pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)
291   freeStablePtr stable
292   return pid
293
294 foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
295 #endif /* __GLASGOW_HASKELL__ */
296
297 -- -----------------------------------------------------------------------------
298 -- Waiting for process termination
299
300 -- | @'getProcessStatus' blk stopped pid@ calls @waitpid@, returning
301 --   @'Just' tc@, the 'ProcessStatus' for process @pid@ if it is
302 --   available, 'Nothing' otherwise.  If @blk@ is 'False', then
303 --   @WNOHANG@ is set in the options for @waitpid@, otherwise not.
304 --   If @stopped@ is 'True', then @WUNTRACED@ is set in the
305 --   options for @waitpid@, otherwise not.
306 getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
307 getProcessStatus block stopped pid =
308   alloca $ \wstatp -> do
309     pid' <- throwErrnoIfMinus1Retry "getProcessStatus"
310                 (c_waitpid pid wstatp (waitOptions block stopped))
311     case pid' of
312       0  -> return Nothing
313       _  -> do ps <- readWaitStatus wstatp
314                return (Just ps)
315
316 -- safe, because this call might block
317 foreign import ccall safe "waitpid"
318   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
319
320 -- | @'getGroupProcessStatus' blk stopped pgid@ calls @waitpid@,
321 --   returning @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus'
322 --   for any process in group @pgid@ if one is available, or 'Nothing'
323 --   if there are child processes but none have exited.  If there are
324 --   no child processes, then 'getGroupProcessStatus' raises an
325 --   'isDoesNotExistError' exception.
326 --
327 --   If @blk@ is 'False', then @WNOHANG@ is set in the options for
328 --   @waitpid@, otherwise not.  If @stopped@ is 'True', then
329 --   @WUNTRACED@ is set in the options for @waitpid@, otherwise not.
330 getGroupProcessStatus :: Bool
331                       -> Bool
332                       -> ProcessGroupID
333                       -> IO (Maybe (ProcessID, ProcessStatus))
334 getGroupProcessStatus block stopped pgid =
335   alloca $ \wstatp -> do
336     pid <- throwErrnoIfMinus1Retry "getGroupProcessStatus"
337                 (c_waitpid (-pgid) wstatp (waitOptions block stopped))
338     case pid of
339       0  -> return Nothing
340       _  -> do ps <- readWaitStatus wstatp
341                return (Just (pid, ps))
342
343 -- | @'getAnyProcessStatus' blk stopped@ calls @waitpid@, returning
344 --   @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus' for any
345 --   child process if a child process has exited, or 'Nothing' if
346 --   there are child processes but none have exited.  If there are no
347 --   child processes, then 'getAnyProcessStatus' raises an
348 --   'isDoesNotExistError' exception.
349 --
350 --   If @blk@ is 'False', then @WNOHANG@ is set in the options for
351 --   @waitpid@, otherwise not.  If @stopped@ is 'True', then
352 --   @WUNTRACED@ is set in the options for @waitpid@, otherwise not.
353 getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
354 getAnyProcessStatus block stopped = getGroupProcessStatus block stopped 1
355
356 waitOptions :: Bool -> Bool -> CInt
357 --             block   stopped
358 waitOptions False False = (#const WNOHANG)
359 waitOptions False True  = (#const (WNOHANG|WUNTRACED))
360 waitOptions True  False = 0
361 waitOptions True  True  = (#const WUNTRACED)
362
363 -- Turn a (ptr to a) wait status into a ProcessStatus
364
365 readWaitStatus :: Ptr CInt -> IO ProcessStatus
366 readWaitStatus wstatp = do
367   wstat <- peek wstatp
368   decipherWaitStatus wstat
369
370 -- -----------------------------------------------------------------------------
371 -- Exiting
372
373 -- | @'exitImmediately' status@ calls @_exit@ to terminate the process
374 --   with the indicated exit @status@.
375 --   The operation never returns.
376 exitImmediately :: ExitCode -> IO ()
377 exitImmediately exitcode = c_exit (exitcode2Int exitcode)
378   where
379     exitcode2Int ExitSuccess = 0
380     exitcode2Int (ExitFailure n) = fromIntegral n
381
382 foreign import ccall unsafe "exit"
383   c_exit :: CInt -> IO ()
384
385 -- -----------------------------------------------------------------------------
386 -- Deprecated or subject to change
387
388 {-# 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." #-}
389 -- | @'createProcessGroup' pid@ calls @setpgid@ to make
390 --   process @pid@ a new process group leader.
391 --   This function is currently deprecated,
392 --   and might be changed to making the current
393 --   process a new process group leader in future versions.
394 createProcessGroup :: ProcessID -> IO ProcessGroupID
395 createProcessGroup pid = do
396   throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0)
397   return pid
398
399 {-# 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." #-}
400 -- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the
401 --   'ProcessGroupID' for process @pid@ to @pgid@.
402 --   This function is currently deprecated,
403 --   and might be changed to setting the 'ProcessGroupID'
404 --   for the current process in future versions.
405 setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
406 setProcessGroupID pid pgid =
407   throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid)
408
409 -- -----------------------------------------------------------------------------