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 20module 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 71import Foreign.C.Error 72import Foreign.C.Types 73import Foreign.Marshal.Alloc ( alloca, allocaBytes ) 74import Foreign.Ptr ( Ptr ) 75import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr ) 76import Foreign.Storable ( Storable(..) ) 77import System.Exit 78import System.Posix.Process.Internals 79import System.Posix.Types 80import Control.Monad 81 82import Control.Exception.Base ( bracket, getMaskingState, MaskingState(..) ) -- used by forkProcess 83import GHC.TopHandler ( runIO ) 84import GHC.IO ( unsafeUnmask, uninterruptibleMask_ ) 85 86-- ----------------------------------------------------------------------------- 87-- Process environment 88 89-- | 'getProcessID' calls @getpid@ to obtain the 'ProcessID' for 90-- the current process. 91getProcessID :: IO ProcessID 92getProcessID = c_getpid 93 94foreign 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. 99getParentProcessID :: IO ProcessID 100getParentProcessID = c_getppid 101 102foreign import ccall unsafe "getppid" 103 c_getppid :: IO CPid 104 105-- | 'getProcessGroupID' calls @getpgrp@ to obtain the 106-- 'ProcessGroupID' for the current process. 107getProcessGroupID :: IO ProcessGroupID 108getProcessGroupID = c_getpgrp 109 110foreign import ccall unsafe "getpgrp" 111 c_getpgrp :: IO CPid 112 113-- | @'getProcessGroupIDOf' pid@ calls @getpgid@ to obtain the 114-- 'ProcessGroupID' for process @pid@. 115getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID 116getProcessGroupIDOf pid = 117 throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid) 118 119foreign 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. 128createProcessGroup :: IO ProcessGroupID 129createProcessGroup = 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. 137createProcessGroupFor :: ProcessID -> IO ProcessGroupID 138createProcessGroupFor 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@. 144joinProcessGroup :: ProcessGroupID -> IO () 145joinProcessGroup 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@. 154setProcessGroupID :: ProcessGroupID -> IO () 155setProcessGroupID 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@. 161setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO () 162setProcessGroupIDOf pid pgid = 163 throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid) 164 165foreign 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. 170createSession :: IO ProcessGroupID 171createSession = throwErrnoIfMinus1 "createSession" c_setsid 172 173foreign import ccall unsafe "setsid" 174 c_setsid :: IO CPid 175 176-- ----------------------------------------------------------------------------- 177-- Process times 178 179-- All times in clock ticks (see getClockTick) 180 181data 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. 191getProcessTimes :: IO ProcessTimes 192getProcessTimes = 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 206data {-# CTYPE "struct tms" #-} CTms 207 208foreign import capi unsafe "HsUnix.h times" 209 c_times :: Ptr CTms -> IO CClock 210 211-- ----------------------------------------------------------------------------- 212-- Process scheduling priority 213 214nice :: Int -> IO () 215nice 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 222foreign import ccall unsafe "nice" 223 c_nice :: CInt -> IO CInt 224 225getProcessPriority :: ProcessID -> IO Int 226getProcessGroupPriority :: ProcessGroupID -> IO Int 227getUserPriority :: UserID -> IO Int 228 229getProcessPriority pid = do 230 r <- throwErrnoIfMinus1 "getProcessPriority" $ 231 c_getpriority (#const PRIO_PROCESS) (fromIntegral pid) 232 return (fromIntegral r) 233 234getProcessGroupPriority pid = do 235 r <- throwErrnoIfMinus1 "getProcessPriority" $ 236 c_getpriority (#const PRIO_PGRP) (fromIntegral pid) 237 return (fromIntegral r) 238 239getUserPriority uid = do 240 r <- throwErrnoIfMinus1 "getUserPriority" $ 241 c_getpriority (#const PRIO_USER) (fromIntegral uid) 242 return (fromIntegral r) 243 244foreign import ccall unsafe "getpriority" 245 c_getpriority :: CInt -> CInt -> IO CInt 246 247setProcessPriority :: ProcessID -> Int -> IO () 248setProcessGroupPriority :: ProcessGroupID -> Int -> IO () 249setUserPriority :: UserID -> Int -> IO () 250 251setProcessPriority pid val = 252 throwErrnoIfMinus1_ "setProcessPriority" $ 253 c_setpriority (#const PRIO_PROCESS) (fromIntegral pid) (fromIntegral val) 254 255setProcessGroupPriority pid val = 256 throwErrnoIfMinus1_ "setProcessPriority" $ 257 c_setpriority (#const PRIO_PGRP) (fromIntegral pid) (fromIntegral val) 258 259setUserPriority uid val = 260 throwErrnoIfMinus1_ "setUserPriority" $ 261 c_setpriority (#const PRIO_USER) (fromIntegral uid) (fromIntegral val) 262 263foreign 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. 270The 'IO' action passed as an argument is executed in the child process; no other 271threads will be copied to the child process. 272On success, 'forkProcess' returns the child's 'ProcessID' to the parent process; 273in case of an error, an exception is thrown. 274 275The 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 279threads are not copied into the child process, it's easy to go wrong: 280e.g. by accessing some shared resource that was held by another thread 281in the parent. 282-} 283 284forkProcess :: IO () -> IO ProcessID 285forkProcess 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 300foreign 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 305forkProcessWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ProcessID 306forkProcessWithUnmask 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. 317getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus) 318getProcessStatus 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 328foreign 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. 341getGroupProcessStatus :: Bool 342 -> Bool 343 -> ProcessGroupID 344 -> IO (Maybe (ProcessID, ProcessStatus)) 345getGroupProcessStatus 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. 364getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus)) 365getAnyProcessStatus block stopped = getGroupProcessStatus block stopped 1 366 367waitOptions :: Bool -> Bool -> CInt 368-- block stopped 369waitOptions False False = (#const WNOHANG) 370waitOptions False True = (#const (WNOHANG|WUNTRACED)) 371waitOptions True False = 0 372waitOptions True True = (#const WUNTRACED) 373 374-- Turn a (ptr to a) wait status into a ProcessStatus 375 376readWaitStatus :: Ptr CInt -> IO ProcessStatus 377readWaitStatus 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. 387exitImmediately :: ExitCode -> IO () 388exitImmediately exitcode = c_exit (exitcode2Int exitcode) 389 where 390 exitcode2Int ExitSuccess = 0 391 exitcode2Int (ExitFailure n) = fromIntegral n 392 393foreign 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. 405createProcessGroup :: ProcessID -> IO ProcessGroupID 406createProcessGroup 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. 416setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () 417setProcessGroupID pid pgid = 418 throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) 419 420-- ----------------------------------------------------------------------------- 421