{-# OPTIONS_GHC -optc-D__HUGS__ #-}
{-# INCLUDE "HsUnix.h" #-}
{-# LINE 1 "User.hsc" #-}
{-# OPTIONS -fffi #-}
{-# LINE 2 "User.hsc" #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  System.Posix.User
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires POSIX)
--
-- POSIX user\/group support
--
-----------------------------------------------------------------------------

module System.Posix.User (
    -- * User environment
    -- ** Querying the user environment
    getRealUserID,
    getRealGroupID,
    getEffectiveUserID,
    getEffectiveGroupID,
    getGroups,
    getLoginName,
    getEffectiveUserName,

    -- *** The group database
    GroupEntry(..),
    getGroupEntryForID,
    getGroupEntryForName,

    -- *** The user database
    UserEntry(..),
    getUserEntryForID,
    getUserEntryForName,

    -- ** Modifying the user environment
    setUserID,
    setGroupID,

  ) where

{-# LINE 44 "User.hsc" #-}

import System.Posix.Types
import Foreign
import Foreign.C
import System.Posix.Internals	( CGroup, CPasswd )

{-# LINE 51 "User.hsc" #-}
import Control.Concurrent.MVar  ( newMVar, withMVar )

{-# LINE 53 "User.hsc" #-}

-- -----------------------------------------------------------------------------
-- user environemnt

getRealUserID :: IO UserID
getRealUserID = c_getuid

foreign import ccall unsafe "getuid"
  c_getuid :: IO CUid

getRealGroupID :: IO GroupID
getRealGroupID = c_getgid

foreign import ccall unsafe "getgid"
  c_getgid :: IO CGid

getEffectiveUserID :: IO UserID
getEffectiveUserID = c_geteuid

foreign import ccall unsafe "geteuid"
  c_geteuid :: IO CUid

getEffectiveGroupID :: IO GroupID
getEffectiveGroupID = c_getegid

foreign import ccall unsafe "getegid"
  c_getegid :: IO CGid

getGroups :: IO [GroupID]
getGroups = do
    ngroups <- c_getgroups 0 nullPtr
    allocaArray (fromIntegral ngroups) $ \arr -> do
       throwErrnoIfMinus1_ "getGroups" (c_getgroups ngroups arr)
       groups <- peekArray (fromIntegral ngroups) arr
       return groups

foreign import ccall unsafe "getgroups"
  c_getgroups :: CInt -> Ptr CGid -> IO CInt

-- ToDo: use getlogin_r
getLoginName :: IO String
getLoginName =  do
    str <- throwErrnoIfNull "getLoginName" c_getlogin
    peekCString str

foreign import ccall unsafe "getlogin"
  c_getlogin :: IO CString

setUserID :: UserID -> IO ()
setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid)

foreign import ccall unsafe "setuid"
  c_setuid :: CUid -> IO CInt

setGroupID :: GroupID -> IO ()
setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid)

foreign import ccall unsafe "setgid"
  c_setgid :: CGid -> IO CInt

-- -----------------------------------------------------------------------------
-- User names

getEffectiveUserName :: IO String
getEffectiveUserName = do
    euid <- getEffectiveUserID
    pw <- getUserEntryForID euid
    return (userName pw)

-- -----------------------------------------------------------------------------
-- The group database (grp.h)

data GroupEntry =
 GroupEntry {
  groupName    :: String,
  groupID      :: GroupID,
  groupMembers :: [String]
 }

getGroupEntryForID :: GroupID -> IO GroupEntry

{-# LINE 134 "User.hsc" #-}
getGroupEntryForID gid = do
  allocaBytes (32) $ \pgr ->
{-# LINE 136 "User.hsc" #-}
    allocaBytes grBufSize $ \pbuf ->
      alloca $ \ ppgr -> do
        throwErrorIfNonZero_ "getGroupEntryForID" $
	     c_getgrgid_r gid pgr pbuf (fromIntegral grBufSize) ppgr
	throwErrnoIfNull "getGroupEntryForID" $
	     peekElemOff ppgr 0
	unpackGroupEntry pgr

foreign import ccall unsafe "getgrgid_r"
  c_getgrgid_r :: CGid -> Ptr CGroup -> CString
		 -> CSize -> Ptr (Ptr CGroup) -> IO CInt

{-# LINE 151 "User.hsc" #-}

getGroupEntryForName :: String -> IO GroupEntry

{-# LINE 155 "User.hsc" #-}
getGroupEntryForName name = do
  allocaBytes (32) $ \pgr ->
{-# LINE 157 "User.hsc" #-}
    allocaBytes grBufSize $ \pbuf ->
      alloca $ \ ppgr -> 
	withCString name $ \ pstr -> do
          throwErrorIfNonZero_ "getGroupEntryForName" $
	     c_getgrnam_r pstr pgr pbuf (fromIntegral grBufSize) ppgr
	  throwErrnoIfNull "getGroupEntryForName" $
	     peekElemOff ppgr 0
	  unpackGroupEntry pgr

foreign import ccall unsafe "getgrnam_r"
  c_getgrnam_r :: CString -> Ptr CGroup -> CString
		 -> CSize -> Ptr (Ptr CGroup) -> IO CInt

{-# LINE 172 "User.hsc" #-}

{-# LINE 174 "User.hsc" #-}
grBufSize :: Int

{-# LINE 179 "User.hsc" #-}
grBufSize = 2048	-- just assume some value (1024 is too small on OpenBSD)

{-# LINE 181 "User.hsc" #-}

{-# LINE 182 "User.hsc" #-}

unpackGroupEntry :: Ptr CGroup -> IO GroupEntry
unpackGroupEntry ptr = do
   name    <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr >>= peekCString
{-# LINE 186 "User.hsc" #-}
   gid     <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
{-# LINE 187 "User.hsc" #-}
   mem     <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
{-# LINE 188 "User.hsc" #-}
   members <- peekArray0 nullPtr mem >>= mapM peekCString
   return (GroupEntry name gid members)

-- -----------------------------------------------------------------------------
-- The user database (pwd.h)

data UserEntry =
 UserEntry {
   userName      :: String,
   userID        :: UserID,
   userGroupID   :: GroupID,
   homeDirectory :: String,
   userShell     :: String
 }

--
-- getpwuid and getpwnam leave results in a static object. Subsequent
-- calls modify the same object, which isn't threadsafe. We attempt to
-- mitigate this issue, on platforms that don't provide the safe _r versions
--

{-# LINE 209 "User.hsc" #-}
lock = unsafePerformIO $ newMVar ()
{-# NOINLINE lock #-}

{-# LINE 212 "User.hsc" #-}

getUserEntryForID :: UserID -> IO UserEntry

{-# LINE 229 "User.hsc" #-}
getUserEntryForID uid = do
  withMVar lock $ \_ -> do
    ppw <- throwErrnoIfNull "getUserEntryForID" $ c_getpwuid uid
    unpackUserEntry ppw

foreign import ccall unsafe "getpwuid" 
  c_getpwuid :: CUid -> IO (Ptr CPasswd)

{-# LINE 239 "User.hsc" #-}

getUserEntryForName :: String -> IO UserEntry

{-# LINE 257 "User.hsc" #-}
getUserEntryForName name = do
  withCString name $ \ pstr -> do
    withMVar lock $ \_ -> do
      ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr
      unpackUserEntry ppw

foreign import ccall unsafe "getpwnam" 
  c_getpwnam :: CString -> IO (Ptr CPasswd)

{-# LINE 268 "User.hsc" #-}

{-# LINE 278 "User.hsc" #-}

{-# LINE 283 "User.hsc" #-}

unpackUserEntry :: Ptr CPasswd -> IO UserEntry
unpackUserEntry ptr = do
   name   <- ((\hsc_ptr -> peekByteOff hsc_ptr 0))  ptr >>= peekCString
{-# LINE 287 "User.hsc" #-}
   uid    <- ((\hsc_ptr -> peekByteOff hsc_ptr 16))   ptr
{-# LINE 288 "User.hsc" #-}
   gid    <- ((\hsc_ptr -> peekByteOff hsc_ptr 20))   ptr
{-# LINE 289 "User.hsc" #-}
   dir    <- ((\hsc_ptr -> peekByteOff hsc_ptr 48))   ptr >>= peekCString
{-# LINE 290 "User.hsc" #-}
   shell  <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) ptr >>= peekCString
{-# LINE 291 "User.hsc" #-}
   return (UserEntry name uid gid dir shell)

-- Used when calling re-entrant system calls that signal their 'errno' 
-- directly through the return value.
throwErrorIfNonZero_ :: String -> IO CInt -> IO ()
throwErrorIfNonZero_ loc act = do
    rc <- act
    if (rc == 0) 
     then return ()
     else ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)

