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
|
{-# OPTIONS -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.Process
-- 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
--
-----------------------------------------------------------------------------
module System.Posix.Process (
-- * Processes
-- ** Forking and executing
forkProcess, forkProcessAll,
executeFile,
-- ** Exiting
exitImmediately,
-- ** Process environment
getProcessID,
getParentProcessID,
getProcessGroupID,
-- ** Process groups
createProcessGroup,
joinProcessGroup,
setProcessGroupID,
-- ** Sessions
createSession,
-- ** Process times
ProcessTimes(elapsedTime, systemTime, userTime,
childSystemTime, childUserTime),
getProcessTimes,
-- ** Scheduling priority
nice,
getProcessPriority,
getProcessGroupPriority,
getUserPriority,
setProcessPriority,
setProcessGroupPriority,
setUserPriority,
-- ** Process status
ProcessStatus(..),
getProcessStatus,
getAnyProcessStatus,
getGroupProcessStatus,
) where
#include "HsUnix.h"
import GHC.Conc ( forkProcessPrim )
import Foreign
import Foreign.C
import System.IO
import System.IO.Error
import System.Exit
import System.Posix.Types
import System.Posix.Signals
import Control.Monad
-- -----------------------------------------------------------------------------
-- Process environment
getProcessID :: IO ProcessID
getProcessID = c_getpid
foreign import ccall unsafe "getpid"
c_getpid :: IO CPid
getParentProcessID :: IO ProcessID
getParentProcessID = c_getppid
foreign import ccall unsafe "getppid"
c_getppid :: IO CPid
getProcessGroupID :: IO ProcessGroupID
getProcessGroupID = c_getpgrp
foreign import ccall unsafe "getpgrp"
c_getpgrp :: IO CPid
createProcessGroup :: ProcessID -> IO ProcessGroupID
createProcessGroup pid = do
throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0)
return pid
joinProcessGroup :: ProcessGroupID -> IO ()
joinProcessGroup pgid =
throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid)
setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
setProcessGroupID pid pgid =
throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid)
foreign import ccall unsafe "setpgid"
c_setpgid :: CPid -> CPid -> IO CInt
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 :: 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
})
type CTms = ()
foreign import ccall unsafe "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' is a wrapper around 'GHC.Conc.forkProcessPrim' similar to
'forkProcessAll' which returns a Maybe-type. The child receives @Nothing@,
the parent @Just (pid::ProcessID)@. In case of an error, an exception is thrown.
NOTE: currently, main threads are not stopped in the child process.
To work around this problem, call 'forkProcess' from the main thread.
If you really want to copy all threads into the new process, use
'forkProcessAll' instead.
-}
forkProcess :: IO (Maybe ProcessID)
forkProcess = do
pid <- throwErrnoIfMinus1 "forkProcess" forkProcessPrim
case pid of
0 -> return Nothing
_ -> return (Just (fromIntegral pid))
{- | 'forkProcessAll' is the low-level wrapper for the @fork@ system-call.
Standard disclaimer for lazy I\/O, shared file handles etc. apply. Notice that
all Concurrent Haskell threads will be copied into the new process. See
'forkProcess' on how to start a new process with only one active thread.
-}
forkProcessAll :: IO (Maybe ProcessID)
forkProcessAll = do
r <- throwErrnoIfMinus1 "forkProcess" c_fork
case r of
0 -> return Nothing
pid -> return (Just (fromIntegral pid))
foreign import ccall unsafe "fork"
c_fork :: IO CInt
executeFile :: FilePath -- Command
-> Bool -- Search PATH?
-> [String] -- Arguments
-> Maybe [(String, String)] -- Environment
-> IO ()
executeFile path search args Nothing = do
withCString path $ \s ->
withMany withCString (path:args) $ \cstrs ->
withArray0 nullPtr cstrs $ \arr -> do
pPrPr_disableITimers
if search
then throwErrnoIfMinus1_ "executeFile" (c_execvp s arr)
else throwErrnoIfMinus1_ "executeFile" (c_execv s arr)
executeFile path search args (Just env) = do
withCString path $ \s ->
withMany withCString (path:args) $ \cstrs ->
withArray0 nullPtr cstrs $ \arg_arr ->
let env' = map (\ (name, val) -> name ++ ('=' : val)) env in
withMany withCString env' $ \cenv ->
withArray0 nullPtr cenv $ \env_arr -> do
pPrPr_disableITimers
if search
then throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr)
else throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr)
-- this function disables the itimer, which would otherwise cause confusing
-- signals to be sent to the new process.
foreign import ccall unsafe "pPrPr_disableITimers"
pPrPr_disableITimers :: IO ()
foreign import ccall unsafe "execvp"
c_execvp :: CString -> Ptr CString -> IO CInt
foreign import ccall unsafe "execv"
c_execv :: CString -> Ptr CString -> IO CInt
foreign import ccall unsafe "execvpe"
c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
foreign import ccall unsafe "execve"
c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt
-- -----------------------------------------------------------------------------
-- Waiting for process termination
data ProcessStatus = Exited ExitCode
| Terminated Signal
| Stopped Signal
deriving (Eq, Ord, Show)
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 <- decipherWaitStatus wstatp
return (Just ps)
foreign import ccall unsafe "waitpid"
c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
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 <- decipherWaitStatus wstatp
return (Just (pid, ps))
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
decipherWaitStatus :: Ptr CInt -> IO ProcessStatus
decipherWaitStatus wstatp = do
wstat <- peek wstatp
if c_WIFEXITED wstat /= 0
then do
let exitstatus = c_WEXITSTATUS wstat
if exitstatus == 0
then return (Exited ExitSuccess)
else return (Exited (ExitFailure (fromIntegral exitstatus)))
else do
if c_WIFSIGNALED wstat /= 0
then do
let termsig = c_WTERMSIG wstat
return (Terminated (fromIntegral termsig))
else do
if c_WIFSTOPPED wstat /= 0
then do
let stopsig = c_WSTOPSIG wstat
return (Stopped (fromIntegral stopsig))
else do
ioError (mkIOError illegalOperationErrorType
"waitStatus" Nothing Nothing)
foreign import ccall unsafe "__hsunix_wifexited"
c_WIFEXITED :: CInt -> CInt
foreign import ccall unsafe "__hsunix_wexitstatus"
c_WEXITSTATUS :: CInt -> CInt
foreign import ccall unsafe "__hsunix_wifsignaled"
c_WIFSIGNALED :: CInt -> CInt
foreign import ccall unsafe "__hsunix_wtermsig"
c_WTERMSIG :: CInt -> CInt
foreign import ccall unsafe "__hsunix_wifstopped"
c_WIFSTOPPED :: CInt -> CInt
foreign import ccall unsafe "__hsunix_wstopsig"
c_WSTOPSIG :: CInt -> CInt
-- -----------------------------------------------------------------------------
-- Exiting
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 ()
-- -----------------------------------------------------------------------------
|