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