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