module System.Posix.Process (
forkProcess,
executeFile,
exitImmediately,
getProcessID,
getParentProcessID,
getProcessGroupID,
createProcessGroup,
joinProcessGroup,
setProcessGroupID,
createSession,
ProcessTimes(..),
getProcessTimes,
nice,
getProcessPriority,
getProcessGroupPriority,
getUserPriority,
setProcessPriority,
setProcessGroupPriority,
setUserPriority,
ProcessStatus(..),
getProcessStatus,
getAnyProcessStatus,
getGroupProcessStatus,
) where
import Foreign.C.Error
import Foreign.C.String ( CString, withCString )
import Foreign.C.Types ( CInt, CClock )
import Foreign.Marshal.Alloc ( alloca, allocaBytes )
import Foreign.Marshal.Array ( withArray0 )
import Foreign.Marshal.Utils ( withMany )
import Foreign.Ptr ( Ptr, nullPtr )
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 GHC.TopHandler ( runIO )
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
data ProcessTimes
= ProcessTimes { elapsedTime :: ClockTick
, userTime :: ClockTick
, systemTime :: ClockTick
, childUserTime :: ClockTick
, childSystemTime :: ClockTick
}
getProcessTimes :: IO ProcessTimes
getProcessTimes = do
allocaBytes (32) $ \p_tms -> do
elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms)
ut <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p_tms
st <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p_tms
cut <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p_tms
cst <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p_tms
return (ProcessTimes{ elapsedTime = elapsed,
userTime = ut,
systemTime = st,
childUserTime = cut,
childSystemTime = cst
})
type CTms = ()
foreign import ccall unsafe "__hsunix_times"
c_times :: Ptr CTms -> IO CClock
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 (0) (fromIntegral pid)
return (fromIntegral r)
getProcessGroupPriority pid = do
r <- throwErrnoIfMinus1 "getProcessPriority" $
c_getpriority (1) (fromIntegral pid)
return (fromIntegral r)
getUserPriority uid = do
r <- throwErrnoIfMinus1 "getUserPriority" $
c_getpriority (2) (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 (0) (fromIntegral pid) (fromIntegral val)
setProcessGroupPriority pid val =
throwErrnoIfMinus1_ "setProcessPriority" $
c_setpriority (1) (fromIntegral pid) (fromIntegral val)
setUserPriority uid val =
throwErrnoIfMinus1_ "setUserPriority" $
c_setpriority (2) (fromIntegral uid) (fromIntegral val)
foreign import ccall unsafe "setpriority"
c_setpriority :: CInt -> CInt -> CInt -> IO CInt
forkProcess :: IO () -> IO ProcessID
forkProcess action = do
stable <- newStablePtr (runIO action)
pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)
freeStablePtr stable
return $ fromIntegral pid
foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
executeFile :: FilePath
-> Bool
-> [String]
-> Maybe [(String, String)]
-> IO a
executeFile path search args Nothing = do
withCString path $ \s ->
withMany withCString (path:args) $ \cstrs ->
withArray0 nullPtr cstrs $ \arr -> do
pPrPr_disableITimers
if search
then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr)
else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr)
return undefined
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 throwErrnoPathIfMinus1_ "executeFile" path
(c_execvpe s arg_arr env_arr)
else throwErrnoPathIfMinus1_ "executeFile" path
(c_execve s arg_arr env_arr)
return undefined
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 "execve"
c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt
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)
foreign import ccall safe "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 <- readWaitStatus wstatp
return (Just (pid, ps))
getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus block stopped = getGroupProcessStatus block stopped 1
waitOptions :: Bool -> Bool -> CInt
waitOptions False False = (1)
waitOptions False True = (3)
waitOptions True False = 0
waitOptions True True = (2)
readWaitStatus :: Ptr CInt -> IO ProcessStatus
readWaitStatus wstatp = do
wstat <- peek wstatp
decipherWaitStatus wstat
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 ()