diff options
Diffstat (limited to 'System')
-rw-r--r-- | System/Posix.hs | 7 | ||||
-rw-r--r-- | System/Posix/Files.hsc | 111 | ||||
-rw-r--r-- | System/Posix/IO.hsc | 327 | ||||
-rw-r--r-- | System/Posix/Process.hsc | 351 | ||||
-rw-r--r-- | System/Posix/Unistd.hsc | 181 |
5 files changed, 786 insertions, 191 deletions
diff --git a/System/Posix.hs b/System/Posix.hs index 9d4d244..fa4ac6d 100644 --- a/System/Posix.hs +++ b/System/Posix.hs @@ -18,9 +18,9 @@ module System.Posix ( module System.Posix.Directory, module System.Posix.Files, module System.Posix.Unistd, - -- module System.Posix.IO, + module System.Posix.IO, + module System.Posix.Process, -- module System.Posix.Time, - -- module System.Posix.Proc, ) where import System.Posix.Types @@ -28,3 +28,6 @@ import System.Posix.Signals import System.Posix.Directory import System.Posix.Files import System.Posix.Unistd +import System.Posix.Process +import System.Posix.IO + diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc index 9dc5555..69e4924 100644 --- a/System/Posix/Files.hsc +++ b/System/Posix/Files.hsc @@ -48,6 +48,9 @@ module System.Posix.Files ( -- * Hard links createLink, removeLink, + -- * Symbolic links + createSymbolicLink, readSymbolicLink, + -- * Renaming files rename, @@ -57,14 +60,8 @@ module System.Posix.Files ( -- * Changing file timestamps setFileTimes, touchFile, - -- * Standard file descriptors - stdInput, stdOutput, stdError, - - -- * Opening and closing files - OpenMode(..), - OpenFileFlags(..), defaultFileFlags, - openFd, createFile, - closeFd, + -- * Setting file sizes + setFileSize, setFdSize, {- -- run-time limit & POSIX feature testing @@ -86,6 +83,7 @@ import Foreign.C #include <unistd.h> #include <utime.h> #include <fcntl.h> +#include <limits.h> -- ----------------------------------------------------------------------------- -- POSIX file modes @@ -334,6 +332,32 @@ removeLink name = throwErrnoIfMinus1_ "removeLink" (c_unlink s) -- ----------------------------------------------------------------------------- +-- Symbolic Links + +createSymbolicLink :: FilePath -> FilePath -> IO () +createSymbolicLink file1 file2 = + withCString file1 $ \s1 -> + withCString file2 $ \s2 -> + throwErrnoIfMinus1_ "createSymbolicLink" (c_symlink s1 s2) + +foreign import ccall unsafe "symlink" + c_symlink :: CString -> CString -> IO CInt + +-- ToDo: should really use SYMLINK_MAX, but not everyone supports it yet, +-- and it seems that the intention is that SYMLINK_MAX is no larger than +-- PATH_MAX. +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = + allocaArray0 (#const PATH_MAX) $ \buf -> do + withCString file $ \s -> + throwErrnoIfMinus1_ "readSymbolicLink" $ + c_readlink s buf (#const PATH_MAX) + peekCString buf + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- -- Renaming files rename :: FilePath -> FilePath -> IO () @@ -385,67 +409,20 @@ touchFile name = do throwErrnoIfMinus1_ "touchFile" (c_utime s nullPtr) -- ----------------------------------------------------------------------------- --- opening files - -stdInput, stdOutput, stdError :: Fd -stdInput = Fd (#const STDIN_FILENO) -stdOutput = Fd (#const STDOUT_FILENO) -stdError = Fd (#const STDERR_FILENO) - -data OpenMode = ReadOnly | WriteOnly | ReadWrite - -data OpenFileFlags = - OpenFileFlags { - append :: Bool, - exclusive :: Bool, - noctty :: Bool, - nonBlock :: Bool, - trunc :: Bool - } - -defaultFileFlags :: OpenFileFlags -defaultFileFlags = - OpenFileFlags { - append = False, - exclusive = False, - noctty = False, - nonBlock = False, - trunc = False - } - -openFd :: FilePath - -> OpenMode - -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist - -> OpenFileFlags - -> IO Fd -openFd name how maybe_mode (OpenFileFlags append exclusive noctty - nonBlock truncate) = do - withCString name $ \s -> do - fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w) - return (Fd fd) - where - all_flags = creat .|. flags .|. open_mode - - flags = - (if append then (#const O_APPEND) else 0) .|. - (if exclusive then (#const O_EXCL) else 0) .|. - (if noctty then (#const O_NOCTTY) else 0) .|. - (if nonBlock then (#const O_NONBLOCK) else 0) .|. - (if truncate then (#const O_TRUNC) else 0) +-- Setting file sizes - (creat, mode_w) = case maybe_mode of - Nothing -> (0,0) - Just x -> ((#const O_CREAT), x) +setFileSize :: FilePath -> FileOffset -> IO () +setFileSize file off = + withCString file $ \s -> + throwErrnoIfMinus1_ "setFileSize" (c_truncate s off) - open_mode = case how of - ReadOnly -> (#const O_RDONLY) - WriteOnly -> (#const O_WRONLY) - ReadWrite -> (#const O_RDWR) +foreign import ccall unsafe "truncate" + c_truncate :: CString -> COff -> IO CInt +setFdSize :: Fd -> FileOffset -> IO () +setFdSize fd off = + throwErrnoIfMinus1_ "setFdSize" (c_ftruncate fd off) -createFile :: FilePath -> FileMode -> IO Fd -createFile name mode - = openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True } +foreign import ccall unsafe "ftruncate" + c_ftruncate :: Fd -> COff -> IO CInt -closeFd :: Fd -> IO () -closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc new file mode 100644 index 0000000..f324841 --- /dev/null +++ b/System/Posix/IO.hsc @@ -0,0 +1,327 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.IO +-- 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 IO support +-- +----------------------------------------------------------------------------- + +module System.Posix.IO ( + -- * Input \/ Output + + -- ** Standard file descriptors + stdInput, stdOutput, stdError, + + -- ** Opening and closing files + OpenMode(..), + OpenFileFlags(..), defaultFileFlags, + openFd, createFile, + closeFd, + + -- ** Reading/writing data +{- + fdRead, fdWrite, +-} + + -- ** Seeking + fdSeek, + + -- ** File options + FdOption(..), + queryFdOption, + setFdOption, + + -- ** Locking + FileLock, + LockRequest(..), + getLock, setLock, + waitToSetLock, + + -- ** Pipes + createPipe, + + -- ** Duplicating file descriptors + dup, dupTo, + + -- ** Converting file descriptors to/from Handles + handleToFd, fdToHandle, + + ) where + +import System.IO +import System.IO.Error +import System.Posix.Types +import Control.Exception ( throw ) + +import Foreign +import Foreign.C +import Data.Bits + +#ifdef __GLASGOW_HASKELL__ +import GHC.IOBase +import GHC.Handle hiding (fdToHandle, openFd) +import qualified GHC.Handle +#endif + +#include <unistd.h> +#include <fcntl.h> + +-- ----------------------------------------------------------------------------- +-- Pipes + +createPipe :: IO (Fd, Fd) +createPipe = + allocaArray 2 $ \p_fd -> do + throwErrnoIfMinus1_ "createPipe" (c_pipe p_fd) + rfd <- peekElemOff p_fd 0 + wfd <- peekElemOff p_fd 1 + return (rfd, wfd) + +foreign import ccall unsafe "pipe" + c_pipe :: Ptr Fd -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Duplicating file descriptors + +dup :: Fd -> IO Fd +dup fd = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r) + +foreign import ccall unsafe "dup" + c_dup :: Fd -> IO CInt + +dupTo :: Fd -> Fd -> IO Fd +dupTo fd1 fd2 = throwErrnoIfMinus1 "dupTp" (c_dup2 fd1 fd2) + +foreign import ccall unsafe "dup2" + c_dup2 :: Fd -> Fd -> IO Fd + +-- ----------------------------------------------------------------------------- +-- Opening and closing files + +stdInput, stdOutput, stdError :: Fd +stdInput = Fd (#const STDIN_FILENO) +stdOutput = Fd (#const STDOUT_FILENO) +stdError = Fd (#const STDERR_FILENO) + +data OpenMode = ReadOnly | WriteOnly | ReadWrite + +data OpenFileFlags = + OpenFileFlags { + append :: Bool, + exclusive :: Bool, + noctty :: Bool, + nonBlock :: Bool, + trunc :: Bool + } + +defaultFileFlags :: OpenFileFlags +defaultFileFlags = + OpenFileFlags { + append = False, + exclusive = False, + noctty = False, + nonBlock = False, + trunc = False + } + +openFd :: FilePath + -> OpenMode + -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist + -> OpenFileFlags + -> IO Fd +openFd name how maybe_mode (OpenFileFlags append exclusive noctty + nonBlock truncate) = do + withCString name $ \s -> do + fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w) + return (Fd fd) + where + all_flags = creat .|. flags .|. open_mode + + flags = + (if append then (#const O_APPEND) else 0) .|. + (if exclusive then (#const O_EXCL) else 0) .|. + (if noctty then (#const O_NOCTTY) else 0) .|. + (if nonBlock then (#const O_NONBLOCK) else 0) .|. + (if truncate then (#const O_TRUNC) else 0) + + (creat, mode_w) = case maybe_mode of + Nothing -> (0,0) + Just x -> ((#const O_CREAT), x) + + open_mode = case how of + ReadOnly -> (#const O_RDONLY) + WriteOnly -> (#const O_WRONLY) + ReadWrite -> (#const O_RDWR) + +foreign import ccall unsafe "open" + c_open :: CString -> CInt -> CMode -> IO CInt + +createFile :: FilePath -> FileMode -> IO Fd +createFile name mode + = openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True } + +closeFd :: Fd -> IO () +closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) + +foreign import ccall unsafe "close" + c_close :: CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Converting file descriptors to/from Handles + +#ifdef __GLASGOW_HASKELL__ +handleToFd :: Handle -> IO Fd +handleToFd h = withHandle "handleToFd" h $ \ h_ -> do + -- converting a Handle into an Fd effectively means + -- letting go of the Handle; it is put into a closed + -- state as a result. + let fd = haFD h_ + flushWriteBufferOnly h_ + unlockFile (fromIntegral fd) + -- setting the Handle's fd to (-1) as well as its 'type' + -- to closed, is enough to disable the finalizer that + -- eventually is run on the Handle. + return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd)) + +fdToHandle :: Fd -> IO Handle +fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd) +#endif + +-- ----------------------------------------------------------------------------- +-- Fd options + +data FdOption = AppendOnWrite + | CloseOnExec + | NonBlockingRead + | SynchronousWrites + +queryFdOption :: Fd -> FdOption -> IO Bool +queryFdOption fd opt = do + r <- throwErrnoIfMinus1 "queryFdOption" (c_fcntl_read fd flag) + return ((r .&. opt_val) /= 0) + where + flag = case opt of + CloseOnExec -> (#const F_GETFD) + other -> (#const F_GETFL) + + opt_val = case opt of + CloseOnExec -> (#const FD_CLOEXEC) + AppendOnWrite -> (#const O_APPEND) + NonBlockingRead -> (#const O_NONBLOCK) + SynchronousWrites -> (#const O_SYNC) + +foreign import ccall unsafe "fcntl" + c_fcntl_read :: Fd -> CInt -> IO CInt + +setFdOption :: Fd -> FdOption -> Bool -> IO () +setFdOption fd opt val = do + r <- throwErrnoIfMinus1 "setFdOption" (c_fcntl_read fd flag) + let r' | val = r .|. opt_val + | otherwise = r .&. (complement opt_val) + throwErrnoIfMinus1_ "setFdOption" (c_fcntl_write fd flag r') + where + flag = case opt of + CloseOnExec -> (#const F_GETFD) + other -> (#const F_GETFL) + opt_val = case opt of + CloseOnExec -> (#const FD_CLOEXEC) + AppendOnWrite -> (#const O_APPEND) + NonBlockingRead -> (#const O_NONBLOCK) + SynchronousWrites -> (#const O_SYNC) + +foreign import ccall unsafe "fcntl" + c_fcntl_write :: Fd -> CInt -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Seeking + +mode2Int :: SeekMode -> CInt +mode2Int AbsoluteSeek = (#const SEEK_SET) +mode2Int RelativeSeek = (#const SEEK_CUR) +mode2Int SeekFromEnd = (#const SEEK_END) + +fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset +fdSeek fd mode off = + throwErrnoIfMinus1 "fdSeek" (c_lseek fd off (mode2Int mode)) + +foreign import ccall unsafe "lseek" + c_lseek :: Fd -> COff -> CInt -> IO COff + +-- ----------------------------------------------------------------------------- +-- Locking + +data LockRequest = ReadLock + | WriteLock + | Unlock + +type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset) + +type CFLock = () + +getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock)) +getLock fd lock = + allocaLock lock $ \p_flock -> do + throwErrnoIfMinus1_ "getLock" (c_fcntl_flock fd (#const F_GETLK) p_flock) + result <- bytes2ProcessIDAndLock p_flock + return (maybeResult result) + where + maybeResult (_, (Unlock, _, _, _)) = Nothing + maybeResult x = Just x + +foreign import ccall unsafe "fcntl" + c_fcntl_flock :: Fd -> CInt -> Ptr CFLock -> IO CInt + +allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a +allocaLock (lockreq, mode, start, len) io = + allocaBytes (#const sizeof(struct flock)) $ \p -> do + (#poke struct flock, l_type) p (lockReqToInt lockreq :: CShort) + (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort) + (#poke struct flock, l_start) p start + (#poke struct flock, l_len) p len + io p + +lockReqToInt :: LockRequest -> CShort +lockReqToInt ReadLock = (#const F_RDLCK) +lockReqToInt WriteLock = (#const F_WRLCK) +lockReqToInt Unlock = (#const F_UNLCK) + +bytes2ProcessIDAndLock :: Ptr CFLock -> IO (ProcessID, FileLock) +bytes2ProcessIDAndLock p = do + req <- (#peek struct flock, l_type) p + mode <- (#peek struct flock, l_whence) p + start <- (#peek struct flock, l_start) p + len <- (#peek struct flock, l_len) p + pid <- (#peek struct flock, l_pid) p + return (pid, (int2req req, int2mode mode, start, len)) + where + int2req :: CShort -> LockRequest + int2req (#const F_RDLCK) = ReadLock + int2req (#const F_WRLCK) = WriteLock + int2req (#const F_UNLCK) = Unlock + int2req _ = throw (mkIOError illegalOperationErrorType "int2req" + Nothing Nothing) + + int2mode :: CShort -> SeekMode + int2mode (#const SEEK_SET) = AbsoluteSeek + int2mode (#const SEEK_CUR) = RelativeSeek + int2mode (#const SEEK_END) = SeekFromEnd + int2mode _ = throw (mkIOError illegalOperationErrorType "int2mode" + Nothing Nothing) + +setLock :: Fd -> FileLock -> IO () +setLock fd lock = do + allocaLock lock $ \p_flock -> + throwErrnoIfMinus1_ "setLock" (c_fcntl_flock fd (#const F_SETLK) p_flock) + +waitToSetLock :: Fd -> FileLock -> IO () +waitToSetLock fd lock = do + allocaLock lock $ \p_flock -> + throwErrnoIfMinus1_ "waitToSetLock" + (c_fcntl_flock fd (#const F_SETLKW) p_flock) diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc new file mode 100644 index 0000000..dfa9e9a --- /dev/null +++ b/System/Posix/Process.hsc @@ -0,0 +1,351 @@ +{-# 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, 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, + +-- ToDo: +-- getEnvVar, +-- getEnvironment, + ) where + +#include "HsUnix.h" +#include <sys/times.h> + +import Foreign +import Foreign.C +import System.IO +import System.IO.Error +import System.Exit +import System.Posix.Types +import System.Posix.Signals + +-- ----------------------------------------------------------------------------- +-- 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 = throwErrnoIfMinus1_ "nice" (c_nice (fromIntegral prio)) + +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 :: IO (Maybe ProcessID) +forkProcess = 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 args $ \cstrs -> + withArray0 nullPtr cstrs $ \arr -> + 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 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 -> + if search then + throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr) + else + throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr) + +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 <- throwErrnoIfMinus1 "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 <- throwErrnoIfMinus1 "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 () + +-- ----------------------------------------------------------------------------- diff --git a/System/Posix/Unistd.hsc b/System/Posix/Unistd.hsc index a7fae7e..bdcbc34 100644 --- a/System/Posix/Unistd.hsc +++ b/System/Posix/Unistd.hsc @@ -29,52 +29,45 @@ module System.Posix.Unistd ( setUserID, setGroupID, - -- * Process environment - -- ** Querying the process environment - getProcessID, - getParentProcessID, - getProcessGroupID, - - -- ** Process groups - createProcessGroup, - joinProcessGroup, - setProcessGroupID, - - -- ** Sessions - createSession, - - -- ** Process times - ProcessTimes(elapsedTime, systemTime, userTime, - childSystemTime, childUserTime), - getProcessTimes, - -- * System environment SystemID(..), getSystemID, + SysVar(..), + getSysVar, + + -- * Sleeping + sleep, usleep, + {- ToDo from unistd.h: - confstr - dup, dup2, exec*, exit, fork, fpathconf, fsync, ftruncate, - gethostid, gethostname, getlogin, getopt, isatty, lockf, - lseek, nice, pathconf, pipe, pread, pwrite, read, readlink, - sleep, symlink, sysconf, tcgetpgrp, tcsetpgrp, truncate, - ttyname(_r), ualarm, usleep, vfork, write + confstr, + lots of sysconf variables - SysVar(..), - getSysVar, + -- use Network.BSD + gethostid, gethostname -- should be in System.Posix.Files? + pathconf, fpathconf, queryTerminal, getTerminalName, #if !defined(cygwin32_TARGET_OS) getControllingTerminalName, #endif + -- System.Posix.Signals + ualarm, + + -- System.Posix.Terminal + isatty, tcgetpgrp, tcsetpgrp, ttyname(_r), + + -- System.Posix.IO + read, write, + -- should be in System.Posix.Time? epochTime, - -- should be in System.Posix.Pwd? + -- should be in System.Posix.User? getEffectiveUserName, -} ) where @@ -85,7 +78,6 @@ import System.Posix.Types import GHC.Posix #include <unistd.h> -#include <sys/times.h> #include <sys/utsname.h> -- ----------------------------------------------------------------------------- @@ -152,77 +144,6 @@ foreign import ccall unsafe "setgid" c_setgid :: CGid -> IO CInt -- ----------------------------------------------------------------------------- --- Process environment - -getProcessID :: IO ProcessID -getProcessID = c_getpid - -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 - }) - -foreign import ccall unsafe "times" - c_times :: Ptr CTms -> IO CClock - --- ----------------------------------------------------------------------------- -- System environment (uname()) data SystemID = @@ -249,7 +170,26 @@ getSystemID = do machine = mach }) -{- +-- ----------------------------------------------------------------------------- +-- sleeping + +sleep :: Int -> IO Int +sleep 0 = return 0 +sleep secs = do r <- c_sleep (fromIntegral secs); return (fromIntegral r) + +foreign import ccall unsafe "sleep" + c_sleep :: CUInt -> IO CUInt + +usleep :: Int -> IO () +usleep 0 = return () +usleep usecs = throwErrnoIfMinus1_ "usleep" (c_usleep (fromIntegral usecs)) + +foreign import ccall unsafe "usleep" + c_usleep :: CUInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- System variables + data SysVar = ArgumentLimit | ChildLimit | ClockTick @@ -258,27 +198,24 @@ data SysVar = ArgumentLimit | PosixVersion | HasSavedIDs | HasJobControl + -- ToDo: lots more -getSysVar :: SysVar -> IO Limit +getSysVar :: SysVar -> IO Integer getSysVar v = case v of - ArgumentLimit -> sysconf ``_SC_ARG_MAX'' - ChildLimit -> sysconf ``_SC_CHILD_MAX'' - ClockTick -> sysconf ``_SC_CLK_TCK'' - GroupLimit -> sysconf ``_SC_NGROUPS_MAX'' - OpenFileLimit -> sysconf ``_SC_OPEN_MAX'' - PosixVersion -> sysconf ``_SC_VERSION'' - HasSavedIDs -> sysconf ``_SC_SAVED_IDS'' - HasJobControl -> sysconf ``_SC_JOB_CONTROL'' --- where - -sysconf :: Int -> IO Limit -sysconf n = do - rc <- _ccall_ sysconf n - if rc /= (-1::Int) - then return rc - else ioException (IOError Nothing NoSuchThing - "getSysVar" - "no such system limit or option" - Nothing) --} + ArgumentLimit -> sysconf (#const _SC_ARG_MAX) + ChildLimit -> sysconf (#const _SC_CHILD_MAX) + ClockTick -> sysconf (#const _SC_CLK_TCK) + GroupLimit -> sysconf (#const _SC_NGROUPS_MAX) + OpenFileLimit -> sysconf (#const _SC_OPEN_MAX) + PosixVersion -> sysconf (#const _SC_VERSION) + HasSavedIDs -> sysconf (#const _SC_SAVED_IDS) + HasJobControl -> sysconf (#const _SC_JOB_CONTROL) + +sysconf :: CInt -> IO Integer +sysconf n = do + r <- throwErrnoIfMinus1 "getSysVar" (c_sysconf n) + return (fromIntegral r) + +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> IO CLong |