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