ghc/lib/haskell-1.3/LibPosixProcEnv.lhs

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