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     str <- _ccall_ cuserid (``NULL''::Addr)
 115     if str == ``NULL''
 116        then syserr "getEffectiveUserName"
 117        else strcpy str
 118
 119 getProcessGroupID :: IO ProcessGroupID
 120 getProcessGroupID = _ccall_ getpgrp
 121
 122 createProcessGroup :: ProcessID -> IO ProcessGroupID
 123 createProcessGroup pid = do
 124     pgid <- _ccall_ setpgid pid 0
 125     if pgid == 0
 126        then return pgid
 127        else syserr "createProcessGroup"
 128
 129 joinProcessGroup :: ProcessGroupID -> IO ()
 130 joinProcessGroup pgid =
 131     nonzero_error (_ccall_ setpgid 0 pgid) "joinProcessGroupID"
 132
 133 setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
 134 setProcessGroupID pid pgid =
 135     nonzero_error (_ccall_ setpgid pid pgid) "setProcessGroupID"
 136
 137 createSession :: IO ProcessGroupID
 138 createSession = do
 139     pgid <- _ccall_ setsid
 140     if pgid /= -1
 141        then return pgid
 142        else syserr "createSession"
 143
 144 type SystemID = ByteArray ()
 145
 146 systemName :: SystemID -> String
 147 systemName sid =  unsafePerformIO $ do
 148     str <-_casm_ ``%r = ((struct utsname *)%0)->sysname;'' sid
 149     strcpy str
 150
 151 nodeName :: SystemID -> String
 152 nodeName sid =  unsafePerformIO $ do
 153     str <- _casm_ ``%r = ((struct utsname *)%0)->nodename;'' sid
 154     strcpy str
 155
 156 release :: SystemID -> String
 157 release sid =  unsafePerformIO $ do
 158     str <- _casm_ ``%r = ((struct utsname *)%0)->release;'' sid
 159     strcpy str
 160
 161 version :: SystemID -> String
 162 version sid =  unsafePerformIO $ do
 163     str <- _casm_ ``%r = ((struct utsname *)%0)->version;'' sid
 164     strcpy str
 165
 166 machine :: SystemID -> String
 167 machine sid = unsafePerformIO $ do
 168     str <- _casm_ ``%r = ((struct utsname *)%0)->machine;'' sid
 169     strcpy str
 170
 171 getSystemID :: IO SystemID
 172 getSystemID = do
 173     bytes <- allocChars (``sizeof(struct utsname)''::Int)
 174     rc    <- _casm_ ``%r = uname((struct utsname *)%0);'' bytes
 175     if rc /= -1
 176        then freeze bytes
 177        else syserr "getSystemID"
 178
 179 epochTime :: IO EpochTime
 180 epochTime = do
 181     secs <- _ccall_ time (``NULL''::Addr)
 182     if secs /= -1
 183        then return secs
 184        else syserr "epochTime"
 185
 186 -- All times in clock ticks (see getClockTick)
 187
 188 type ProcessTimes = (ClockTick, ByteArray ())
 189
 190 elapsedTime :: ProcessTimes -> ClockTick
 191 elapsedTime (realtime, _) = realtime
 192
 193 userTime :: ProcessTimes -> ClockTick
 194 userTime (_, times) = unsafePerformIO $
 195     _casm_ ``%r = ((struct tms *)%0)->tms_utime;'' times
 196
 197 systemTime :: ProcessTimes -> ClockTick
 198 systemTime (_, times) = unsafePerformIO $
 199     _casm_ ``%r = ((struct tms *)%0)->tms_stime;'' times
 200
 201 childUserTime :: ProcessTimes -> ClockTick
 202 childUserTime (_, times) = unsafePerformIO $
 203     _casm_ ``%r = ((struct tms *)%0)->tms_cutime;'' times
 204
 205 childSystemTime :: ProcessTimes -> ClockTick
 206 childSystemTime (_, times) = unsafePerformIO $
 207     _casm_ ``%r = ((struct tms *)%0)->tms_cstime;'' times
 208
 209 getProcessTimes :: IO ProcessTimes
 210 getProcessTimes = do
 211     bytes <- allocChars (``sizeof(struct tms)''::Int)
 212     elapsed <- _casm_ ``%r = times((struct tms *)%0);'' bytes
 213     if elapsed /= -1
 214        then do
 215             times <- freeze bytes
 216             return (elapsed, times)
 217        else
 218             syserr "getProcessTimes"
 219
 220 #if !defined(cygwin32_TARGET_OS)
 221 getControllingTerminalName :: IO FilePath
 222 getControllingTerminalName = do
 223     str <- _ccall_ ctermid (``NULL''::Addr)
 224     if str == ``NULL''
 225        then fail (IOError Nothing NoSuchThing "getControllingTerminalName: no controlling terminal")
 226        else strcpy str
 227 #endif
 228
 229 getTerminalName :: Fd -> IO FilePath
 230 getTerminalName fd = do
 231     str <- _ccall_ ttyname fd
 232     if str == ``NULL''
 233        then do
 234         err <- try (queryTerminal fd)
 235         either (\err -> syserr "getTerminalName")
 236                (\succ -> if succ then fail (IOError Nothing NoSuchThing
 237                                             "getTerminalName: no name")
 238                          else fail (IOError Nothing InappropriateType
 239                                             "getTerminalName: not a terminal"))
 240            err
 241        else strcpy str
 242
 243 queryTerminal :: Fd -> IO Bool
 244 queryTerminal (FD# fd) = do
 245     rc <- _ccall_ isatty fd
 246     case rc of
 247       -1 -> syserr "queryTerminal"
 248       0  -> return False
 249       1  -> return True
 250
 251 data SysVar = ArgumentLimit
 252             | ChildLimit
 253             | ClockTick
 254             | GroupLimit
 255             | OpenFileLimit
 256             | PosixVersion
 257             | HasSavedIDs
 258             | HasJobControl
 259
 260 getSysVar :: SysVar -> IO Limit
 261 getSysVar v =
 262     case v of
 263       ArgumentLimit -> sysconf ``_SC_ARG_MAX''
 264       ChildLimit    -> sysconf ``_SC_CHILD_MAX''
 265       ClockTick     -> sysconf ``_SC_CLK_TCK''
 266       GroupLimit    -> sysconf ``_SC_NGROUPS_MAX''
 267       OpenFileLimit -> sysconf ``_SC_OPEN_MAX''
 268       PosixVersion  -> sysconf ``_SC_VERSION''
 269       HasSavedIDs   -> sysconf ``_SC_SAVED_IDS''
 270       HasJobControl -> sysconf ``_SC_JOB_CONTROL''
 271 --  where
 272
 273 sysconf :: Int -> IO Limit
 274 sysconf n = do
 275  rc <- _ccall_ sysconf n
 276  if rc /= -1
 277     then return rc
 278     else fail (IOError Nothing NoSuchThing
 279                        "getSysVar: no such system limit or option")
 280
 281 \end{code}