ghc/lib/posix/PosixProcEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
   3 %
   4 \section[PosixProcEnv]{Haskell 1.3 POSIX Process Environment}
   5
   6 \begin{code}
   7
   8 #include "config.h"
   9
  10 module PosixProcEnv (
  11     ProcessTimes,
  12     SysVar(..),
  13     SystemID,
  14     childSystemTime,
  15     childUserTime,
  16     createProcessGroup,
  17     createSession,
  18     elapsedTime,
  19     epochTime,
  20 #if !defined(cygwin32_TARGET_OS)
  21     getControllingTerminalName,
  22 #endif
  23     getEffectiveGroupID,
  24     getEffectiveUserID,
  25     getEffectiveUserName,
  26 #if !defined(cygwin32_TARGET_OS)
  27     getGroups,
  28 #endif
  29     getLoginName,
  30     getParentProcessID,
  31     getProcessGroupID,
  32     getProcessID,
  33     getProcessTimes,
  34     getRealGroupID,
  35     getRealUserID,
  36     getSysVar,
  37     getSystemID,
  38     getTerminalName,
  39     joinProcessGroup,
  40     machine,
  41     nodeName,
  42     queryTerminal,
  43     release,
  44     setGroupID,
  45     setProcessGroupID,
  46     setUserID,
  47     systemName,
  48     systemTime,
  49     userTime,
  50     version
  51     ) where
  52
  53 import GlaExts
  54 import PrelArr (ByteArray(..)) -- see internals
  55 import PrelIOBase
  56 import IO
  57 import Addr     ( nullAddr )
  58
  59 import PosixErr
  60 import PosixUtil
  61 import CString   ( strcpy, allocWords, freeze, allocChars )
  62
  63 \end{code}
  64
  65 \begin{code}
  66 getProcessID :: IO ProcessID
  67 getProcessID = _ccall_ getpid
  68
  69 getParentProcessID :: IO ProcessID
  70 getParentProcessID = _ccall_ getppid
  71
  72 getRealUserID :: IO UserID
  73 getRealUserID = _ccall_ getuid
  74
  75 getEffectiveUserID :: IO UserID
  76 getEffectiveUserID = _ccall_ geteuid
  77
  78 setUserID :: UserID -> IO ()
  79 setUserID uid = nonzero_error (_ccall_ setuid uid) "setUserID"
  80
  81 getLoginName :: IO String
  82 getLoginName =  do
  83     str <- _ccall_ getlogin
  84     if str == nullAddr
  85        then syserr "getLoginName"
  86        else strcpy str
  87
  88 getRealGroupID :: IO GroupID
  89 getRealGroupID = _ccall_ getgid
  90
  91 getEffectiveGroupID :: IO GroupID
  92 getEffectiveGroupID = _ccall_ getegid
  93
  94 setGroupID :: GroupID -> IO ()
  95 setGroupID gid = nonzero_error (_ccall_ setgid gid) "setGroupID"
  96
  97 -- getgroups() is not supported in beta18 of
  98 -- cygwin32
  99 #if !defined(cygwin32_TARGET_OS)
 100 getGroups :: IO [GroupID]
 101 getGroups = do
 102     ngroups <- _ccall_ getgroups (0::Int) nullAddr
 103     words   <- allocWords ngroups
 104     ngroups <- _casm_ ``%r = getgroups(%0,(gid_t *)%1);'' ngroups words
 105     if ngroups /= ((-1)::Int)
 106        then do
 107          arr <- freeze words
 108          return (map (extract arr) [0..(ngroups-1)])
 109        else
 110          syserr "getGroups"
 111   where
 112     extract (ByteArray _ barr#) (I# n#) =
 113         case indexIntArray# barr# n# of
 114           r# -> (I# r#)
 115 #endif
 116
 117 getEffectiveUserName :: IO String
 118 getEffectiveUserName = do
 119  {- cuserid() is deprecated, using getpwuid() instead. -}
 120     euid <- getEffectiveUserID
 121     ptr  <- _ccall_ getpwuid euid
 122     str  <- _casm_ ``%r = ((struct passwd *)%0)->pw_name;'' (ptr::Addr)
 123     strcpy str
 124
 125 {- OLD:
 126     str <- _ccall_ cuserid nullAddr
 127     if str == nullAddr
 128        then syserr "getEffectiveUserName"
 129        else strcpy str
 130 -}
 131
 132 getProcessGroupID :: IO ProcessGroupID
 133 getProcessGroupID = _ccall_ getpgrp
 134
 135 createProcessGroup :: ProcessID -> IO ProcessGroupID
 136 createProcessGroup pid = do
 137     pgid <- _ccall_ setpgid pid (0::Int)
 138     if pgid == (0::Int)
 139        then return pgid
 140        else syserr "createProcessGroup"
 141
 142 joinProcessGroup :: ProcessGroupID -> IO ()
 143 joinProcessGroup pgid =
 144     nonzero_error (_ccall_ setpgid (0::Int) pgid) "joinProcessGroupID"
 145
 146 setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
 147 setProcessGroupID pid pgid =
 148     nonzero_error (_ccall_ setpgid pid pgid) "setProcessGroupID"
 149
 150 createSession :: IO ProcessGroupID
 151 createSession = do
 152     pgid <- _ccall_ setsid
 153     if pgid /= ((-1)::Int)
 154        then return pgid
 155        else syserr "createSession"
 156
 157 type SystemID = ByteArray Int
 158
 159 systemName :: SystemID -> String
 160 systemName sid =  unsafePerformIO $ do
 161     str <-_casm_ ``%r = ((struct utsname *)%0)->sysname;'' sid
 162     strcpy str
 163
 164 nodeName :: SystemID -> String
 165 nodeName sid =  unsafePerformIO $ do
 166     str <- _casm_ ``%r = ((struct utsname *)%0)->nodename;'' sid
 167     strcpy str
 168
 169 release :: SystemID -> String
 170 release sid =  unsafePerformIO $ do
 171     str <- _casm_ ``%r = ((struct utsname *)%0)->release;'' sid
 172     strcpy str
 173
 174 version :: SystemID -> String
 175 version sid =  unsafePerformIO $ do
 176     str <- _casm_ ``%r = ((struct utsname *)%0)->version;'' sid
 177     strcpy str
 178
 179 machine :: SystemID -> String
 180 machine sid = unsafePerformIO $ do
 181     str <- _casm_ ``%r = ((struct utsname *)%0)->machine;'' sid
 182     strcpy str
 183
 184 getSystemID :: IO SystemID
 185 getSystemID = do
 186     bytes <- allocChars (``sizeof(struct utsname)''::Int)
 187     rc    <- _casm_ ``%r = uname((struct utsname *)%0);'' bytes
 188     if rc /= ((-1)::Int)
 189        then freeze bytes
 190        else syserr "getSystemID"
 191
 192 epochTime :: IO EpochTime
 193 epochTime = do
 194     secs <- _ccall_ time nullAddr
 195     if secs /= ((-1)::Int)
 196        then return secs
 197        else syserr "epochTime"
 198
 199 -- All times in clock ticks (see getClockTick)
 200
 201 type ProcessTimes = (ClockTick, ByteArray Int)
 202
 203 elapsedTime :: ProcessTimes -> ClockTick
 204 elapsedTime (realtime, _) = realtime
 205
 206 userTime :: ProcessTimes -> ClockTick
 207 userTime (_, times) = unsafePerformIO $
 208     _casm_ ``%r = ((struct tms *)%0)->tms_utime;'' times
 209
 210 systemTime :: ProcessTimes -> ClockTick
 211 systemTime (_, times) = unsafePerformIO $
 212     _casm_ ``%r = ((struct tms *)%0)->tms_stime;'' times
 213
 214 childUserTime :: ProcessTimes -> ClockTick
 215 childUserTime (_, times) = unsafePerformIO $
 216     _casm_ ``%r = ((struct tms *)%0)->tms_cutime;'' times
 217
 218 childSystemTime :: ProcessTimes -> ClockTick
 219 childSystemTime (_, times) = unsafePerformIO $
 220     _casm_ ``%r = ((struct tms *)%0)->tms_cstime;'' times
 221
 222 getProcessTimes :: IO ProcessTimes
 223 getProcessTimes = do
 224     bytes <- allocChars (``sizeof(struct tms)''::Int)
 225     elapsed <- _casm_ ``%r = times((struct tms *)%0);'' bytes
 226     if elapsed /= ((-1)::Int)
 227        then do
 228             times <- freeze bytes
 229             return (elapsed, times)
 230        else
 231             syserr "getProcessTimes"
 232
 233 #if !defined(cygwin32_TARGET_OS)
 234 getControllingTerminalName :: IO FilePath
 235 getControllingTerminalName = do
 236     str <- _ccall_ ctermid nullAddr
 237     if str == nullAddr
 238        then ioError (IOError Nothing NoSuchThing "getControllingTerminalName" "no controlling terminal")
 239        else strcpy str
 240 #endif
 241
 242 getTerminalName :: Fd -> IO FilePath
 243 getTerminalName fd = do
 244     str <- _ccall_ ttyname fd
 245     if str == nullAddr
 246        then do
 247         err <- try (queryTerminal fd)
 248         either (\ _err -> syserr "getTerminalName")
 249                (\ succ -> if succ then ioError (IOError Nothing NoSuchThing
 250                                                 "getTerminalName" "no name")
 251                           else ioError (IOError Nothing InappropriateType
 252                                                 "getTerminalName" "not a terminal"))
 253            err
 254        else strcpy str
 255
 256 queryTerminal :: Fd -> IO Bool
 257 queryTerminal (FD# fd) = do
 258     rc <- _ccall_ isatty fd
 259     case (rc::Int) of
 260       -1 -> syserr "queryTerminal"
 261       0  -> return False
 262       1  -> return True
 263
 264 data SysVar = ArgumentLimit
 265             | ChildLimit
 266             | ClockTick
 267             | GroupLimit
 268             | OpenFileLimit
 269             | PosixVersion
 270             | HasSavedIDs
 271             | HasJobControl
 272
 273 getSysVar :: SysVar -> IO Limit
 274 getSysVar v =
 275     case v of
 276       ArgumentLimit -> sysconf ``_SC_ARG_MAX''
 277       ChildLimit    -> sysconf ``_SC_CHILD_MAX''
 278       ClockTick     -> sysconf ``_SC_CLK_TCK''
 279       GroupLimit    -> sysconf ``_SC_NGROUPS_MAX''
 280       OpenFileLimit -> sysconf ``_SC_OPEN_MAX''
 281       PosixVersion  -> sysconf ``_SC_VERSION''
 282       HasSavedIDs   -> sysconf ``_SC_SAVED_IDS''
 283       HasJobControl -> sysconf ``_SC_JOB_CONTROL''
 284 --  where
 285
 286 sysconf :: Int -> IO Limit
 287 sysconf n = do
 288  rc <- _ccall_ sysconf n
 289  if rc /= (-1::Int)
 290     then return rc
 291     else ioError (IOError Nothing NoSuchThing
 292                           "getSysVar"
 293                           "no such system limit or option")
 294
 295 \end{code}