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