Use ByteString for GroupEntry/UserEntry

No PosixString instance for now. Not sure
if it's interesting.

System/Posix/User.hsc

-{-# LANGUAGE Trustworthy, CApiFFI #-}
+{-# LANGUAGE Trustworthy, CApiFFI, PatternSynonyms, ViewPatterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Posix.User
@@ -25,13 +25,25 @@ module System.Posix.User (
     getEffectiveUserName,
 
     -- *** The group database
-    GroupEntry(..),
+    groupName,
+    groupPassword,
+    groupID,
+    groupMembers,
+    pattern GroupEntry,
     getGroupEntryForID,
     getGroupEntryForName,
     getAllGroupEntries,
 
     -- *** The user database
-    UserEntry(..),
+    userName,
+    userPassword,
+    userID,
+    userGroupID,
+    userGecos,
+    homeDirectory,
+    userShell,
+    pattern UserEntry,
+
     getUserEntryForID,
     getUserEntryForName,
     getAllUserEntries,
@@ -53,6 +65,12 @@ import Foreign.C
 import Foreign.Ptr
 import Foreign.Marshal
 import Foreign.Storable
+import System.Posix.User.Common ( UserEntry, GroupEntry
+#if defined(HAVE_PWD_H)
+      , unpackUserEntry, unpackGroupEntry, LKUPTYPE(..), CPasswd, CGroup
+#endif
+  )
+import qualified System.Posix.User.Common as User
 
 #if defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT)
 #if defined(freebsd_HOST_OS)
@@ -63,19 +81,13 @@ import Control.Exception
 #endif
 import Control.Monad
 import System.IO.Error
+import qualified Data.ByteString.Char8 as C8
 
 #if !defined(HAVE_PWD_H)
 import System.IO.Error ( ioeSetLocation )
 import GHC.IO.Exception ( unsupportedOperation )
 #endif
 
-#if defined(HAVE_PWD_H)
-
--- internal types
-data {-# CTYPE "struct passwd" #-} CPasswd
-data {-# CTYPE "struct group"  #-} CGroup
-
-#endif // HAVE_PWD_H
 
 #if !defined(HAVE_PWD_H)
 
@@ -204,7 +216,6 @@ getEffectiveUserName = ioError (ioeSetLocation unsupportedOperation "getEffectiv
 -- lot of complexity by deprecating the "get all" functions and simply
 -- always returning an empty list.
 --
-data LKUPTYPE = GETONE | GETALL
 
 #if defined(HAVE_GETPWENT)
 pwlock :: MVar ()
@@ -371,13 +382,28 @@ getEffectiveUserName = do
 -- -----------------------------------------------------------------------------
 -- The group database (grp.h)
 
-data GroupEntry =
- GroupEntry {
-  groupName    :: String,       -- ^ The name of this group (gr_name)
-  groupPassword :: String,      -- ^ The password for this group (gr_passwd)
-  groupID      :: GroupID,      -- ^ The unique numeric ID for this group (gr_gid)
-  groupMembers :: [String]      -- ^ A list of zero or more usernames that are members (gr_mem)
- } deriving (Show, Read, Eq)
+groupName :: GroupEntry -> String
+groupName (GroupEntry gn _ _ _) = gn
+
+groupPassword :: GroupEntry -> String
+groupPassword (GroupEntry _ gp _ _) = gp
+
+groupID :: GroupEntry -> GroupID
+groupID (GroupEntry _ _ id' _) = id'
+
+groupMembers :: GroupEntry -> [String]
+groupMembers (GroupEntry _ _ _ gm) = gm
+
+-- | Manually constructing 'GroupEntry' in String modules is discouraged. It will truncate
+-- Chars to 8bit. Use 'System.Posix.User.ByteString' instead.
+pattern GroupEntry :: String          -- ^ The name of this group (gr_name)
+                   -> String          -- ^ The password for this group (gr_passwd)
+                   -> GroupID         -- ^ The unique numeric ID for this group (gr_gid)
+                   -> [String]        -- ^ A list of zero or more usernames that are members (gr_mem)
+                   -> GroupEntry
+pattern GroupEntry gn gp gi gm <- User.GroupEntry (C8.unpack -> gn) (C8.unpack -> gp) gi (fmap C8.unpack -> gm) where
+  GroupEntry gn gp gi gm = User.GroupEntry (C8.pack gn) (C8.pack gp) gi (C8.pack <$> gm)
+{-# COMPLETE GroupEntry #-}
 
 #if !defined(HAVE_PWD_H)
 
@@ -474,30 +500,57 @@ grBufSize = 1024
 #endif
 #endif
 
-unpackGroupEntry :: Ptr CGroup -> IO GroupEntry
-unpackGroupEntry ptr = do
-   name    <- (#peek struct group, gr_name) ptr >>= peekCAString
-   passwd  <- (#peek struct group, gr_passwd) ptr >>= peekCAString
-   gid     <- (#peek struct group, gr_gid) ptr
-   mem     <- (#peek struct group, gr_mem) ptr
-   members <- peekArray0 nullPtr mem >>= mapM peekCAString
-   return (GroupEntry name passwd gid members)
-
 #endif // HAVE_PWD_H
 
 -- -----------------------------------------------------------------------------
 -- The user database (pwd.h)
 
-data UserEntry =
- UserEntry {
-   userName      :: String,     -- ^ Textual name of this user (pw_name)
-   userPassword  :: String,     -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd)
-   userID        :: UserID,     -- ^ Numeric ID for this user (pw_uid)
-   userGroupID   :: GroupID,    -- ^ Primary group ID (pw_gid)
-   userGecos     :: String,     -- ^ Usually the real name for the user (pw_gecos)
-   homeDirectory :: String,     -- ^ Home directory (pw_dir)
-   userShell     :: String      -- ^ Default shell (pw_shell)
- } deriving (Show, Read, Eq)
+userName :: UserEntry -> String
+userName (UserEntry n _ _ _ _ _ _) = n
+
+userPassword :: UserEntry -> String
+userPassword (UserEntry _ p _ _ _ _ _) = p
+
+userID :: UserEntry -> UserID
+userID (UserEntry _ _ id' _ _ _ _) = id'
+
+userGroupID :: UserEntry -> GroupID
+userGroupID (UserEntry _ _ _ gid _ _ _) = gid
+
+userGecos :: UserEntry -> String
+userGecos (UserEntry _ _ _ _ ge _ _) = ge
+
+homeDirectory :: UserEntry -> String
+homeDirectory (UserEntry _ _ _ _ _ hd _) = hd
+
+userShell :: UserEntry -> String
+userShell (UserEntry _ _ _ _ _ _ us) = us
+
+-- | Manually constructing 'UserEntry' in String modules is discouraged. It will truncate
+-- Chars to 8bit. Use 'System.Posix.User.ByteString' instead.
+pattern UserEntry :: String         -- ^ Textual name of this user (pw_name)
+                  -> String         -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd)
+                  -> UserID         -- ^ Numeric ID for this user (pw_uid)
+                  -> GroupID        -- ^ Primary group ID (pw_gid)
+                  -> String         -- ^ Usually the real name for the user (pw_gecos)
+                  -> String         -- ^ Home directory (pw_dir)
+                  -> String         -- ^ Default shell (pw_shell)
+                  -> UserEntry
+pattern UserEntry un up ui ugi ug hd us <- User.UserEntry (C8.unpack -> un)
+                                                       (C8.unpack -> up)
+                                                       ui
+                                                       ugi
+                                                       (C8.unpack -> ug)
+                                                       (C8.unpack -> hd)
+                                                       (C8.unpack -> us) where
+  UserEntry un up ui ugi ug hd us = User.UserEntry (C8.pack un)
+                                                (C8.pack up)
+                                                ui
+                                                ugi
+                                                (C8.pack ug)
+                                                (C8.pack hd)
+                                                (C8.pack us)
+{-# COMPLETE UserEntry #-}
 
 -- | @getUserEntryForID uid@ calls @getpwuid_r@ to obtain
 --   the @UserEntry@ information associated with @UserID@
@@ -621,20 +674,6 @@ doubleAllocWhileERANGE loc enttype initlen unpack action =
     ioError $ flip ioeSetErrorString ("no such " ++ enttype)
             $ mkIOError doesNotExistErrorType loc Nothing Nothing
 
-unpackUserEntry :: Ptr CPasswd -> IO UserEntry
-unpackUserEntry ptr = do
-   name   <- (#peek struct passwd, pw_name)   ptr >>= peekCAString
-   passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCAString
-   uid    <- (#peek struct passwd, pw_uid)    ptr
-   gid    <- (#peek struct passwd, pw_gid)    ptr
-#ifdef HAVE_NO_PASSWD_PW_GECOS
-   gecos  <- return ""  -- pw_gecos does not exist on android
-#else
-   gecos  <- (#peek struct passwd, pw_gecos)  ptr >>= peekCAString
-#endif
-   dir    <- (#peek struct passwd, pw_dir)    ptr >>= peekCAString
-   shell  <- (#peek struct passwd, pw_shell)  ptr >>= peekCAString
-   return (UserEntry name passwd uid gid gecos dir shell)
 
 -- Used when a function returns NULL to indicate either an error or
 -- EOF, depending on whether the global errno is nonzero.

System/Posix/User/ByteString.hsc

+{-# LANGUAGE Trustworthy, CApiFFI, PatternSynonyms, ViewPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.User.ByteString
+-- 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.ByteString (
+    -- * User environment
+    -- ** Querying the user environment
+    getRealUserID,
+    getRealGroupID,
+    getEffectiveUserID,
+    getEffectiveGroupID,
+    getGroups,
+    getLoginName,
+    getEffectiveUserName,
+
+    -- *** The group database
+    GroupEntry(..),
+
+    getGroupEntryForID,
+    getGroupEntryForName,
+    getAllGroupEntries,
+
+    -- *** The user database
+    UserEntry(..),
+
+    getUserEntryForID,
+    getUserEntryForName,
+    getAllUserEntries,
+
+    -- ** Modifying the user environment
+    setUserID,
+    setGroupID,
+    setEffectiveUserID,
+    setEffectiveGroupID,
+    setGroups
+
+  ) where
+
+#include "HsUnix.h"
+
+import System.Posix.Types
+import System.IO.Unsafe (unsafePerformIO)
+import Foreign.C ( CSize(..), CInt(..), CString, CLong(..), getErrno, throwErrno, eOK, throwErrnoIfMinus1_, throwErrnoIfNull, resetErrno, Errno(..), eRANGE, errnoToIOError )
+import Foreign.Ptr
+import Foreign.Marshal
+import Foreign.Storable
+
+import System.Posix.User.Common
+#if defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT)
+#if defined(freebsd_HOST_OS)
+import Control.Concurrent (runInBoundThread, rtsSupportsBoundThreads)
+#endif
+import Control.Concurrent.MVar ( MVar, newMVar, withMVar )
+import Control.Exception
+#endif
+import Control.Monad
+import System.IO.Error
+import Data.ByteString ( ByteString, packCString, useAsCString )
+
+#if !defined(HAVE_PWD_H)
+import System.IO.Error ( ioeSetLocation )
+import GHC.IO.Exception ( unsupportedOperation )
+#endif
+
+
+#if !defined(HAVE_PWD_H)
+
+getRealUserID :: IO UserID
+{-# WARNING getRealUserID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getRealUserID = ioError (ioeSetLocation unsupportedOperation "getRealUserID")
+
+getRealGroupID :: IO GroupID
+{-# WARNING getRealGroupID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getRealGroupID = ioError (ioeSetLocation unsupportedOperation "getRealGroupID")
+
+getEffectiveUserID :: IO UserID
+{-# WARNING getEffectiveUserID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getEffectiveUserID = ioError (ioeSetLocation unsupportedOperation "getEffectiveUserID")
+
+getEffectiveGroupID :: IO GroupID
+{-# WARNING getEffectiveGroupID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getEffectiveGroupID = ioError (ioeSetLocation unsupportedOperation "getEffectiveGroupID")
+
+getGroups :: IO [GroupID]
+{-# WARNING getGroups
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getGroups = ioError (ioeSetLocation unsupportedOperation "getGroups")
+
+setGroups :: [GroupID] -> IO ()
+{-# WARNING setGroups
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+setGroups _ = ioError (ioeSetLocation unsupportedOperation "setGroups")
+
+getLoginName :: IO ByteString
+{-# WARNING getLoginName
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getLoginName = ioError (ioeSetLocation unsupportedOperation "getLoginName")
+
+setUserID :: UserID -> IO ()
+{-# WARNING setUserID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+setUserID _ = ioError (ioeSetLocation unsupportedOperation "setUserID")
+
+setEffectiveUserID :: UserID -> IO ()
+{-# WARNING setEffectiveUserID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+setEffectiveUserID _ = ioError (ioeSetLocation unsupportedOperation "setEffectiveUserID")
+
+setGroupID :: GroupID -> IO ()
+{-# WARNING setGroupID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+setGroupID _ = ioError (ioeSetLocation unsupportedOperation "setGroupID")
+
+setEffectiveGroupID :: GroupID -> IO ()
+{-# WARNING setEffectiveGroupID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+setEffectiveGroupID _ = ioError (ioeSetLocation unsupportedOperation "setEffectiveGroupID")
+
+getEffectiveUserName :: IO ByteString
+{-# WARNING getEffectiveUserName
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getEffectiveUserName = ioError (ioeSetLocation unsupportedOperation "getEffectiveUserName")
+
+#else
+-- -----------------------------------------------------------------------------
+-- Thread safety of passwd/group database access APIs:
+--
+-- All supported unix platforms have @get(pw|gr)(nam|[ug]id)_r(3)@, which
+-- store the result in a caller provided buffer, which solves the most
+-- immediate thread-safety issues.
+--
+-- Things are more complicated for getpwent(3) and getgrent(3).
+--
+-- * On Linux systems, these read a global open file, opened via
+--   setpwent(3) and closed via endpwent(3).  Only one thread at
+--   a time can safely iterate through the file.
+--
+-- * On macOS (through Catalina 10.15), there is no getpwent_r(3) or
+--   getgrent_r(3), so a lock is also required for safe buffer sharing.
+--
+-- * On FreeBSD, in the default configuration with passwd lookups configured
+--   in nsswitch.conf to use "compat" rather than "files", the getpwnam_r(3)
+--   and getpwuid_r(3) functions reset the iterator index used by getpwent(3).
+--   A bug [report](https://bugs.freebsd.org/bugzilla/show_bug.cgi?id=252094)
+--   has been filed to track this long-standing issue.  A similar issue affects
+--   getgrent(3), this time regardless of the nsswitch.conf setting.  This too
+--   should be fixed at some point in the future.  The state in question is
+--   thread-specific, so both issues only affect overlapping use of the @*ent@
+--   and @*(nam|[ug]id)_r(3)@ functions in the /same/ thread.
+--
+-- * Despite rather similar manpages for getpwent(3) and getpwnam(3), ... as
+--   on FreeBSD, the above issue is not seen on NetBSD or macOS.
+--
+--   This is not an issue with 1-to-1 thread models, where the code executing
+--   @get(pw|gr)ent@ has exclusive use of its thread, but it is a real issue
+--   for Haskell with its many-to-1 green threads, because multiple `forkIO`
+--   threads may take turns using the same underlying OS thread, breaking the
+--   thread-safety of the @*_r@ functions, which mutate the file-offset of the
+--   open file shared with any overlapping execution of @*ent(3)@ in the same
+--   thread.
+--
+-- Consequently, correct portable support for @get(pw|gr)ent(3)@ is rather
+-- non-trivial.  In the threaded runtime, we can run these functions in a
+-- /bound thread/ (via 'forkOS'), thereby avoiding the FreeBSD issues.  We
+-- still need a lock to serialise multiple threads calling these functions
+-- on at least macOS for lack of @_r@ equivalents.  While on FreeBSD we could
+-- use @getpwent_r(3)@ and @getgrent_r(3)@ in a bound thread without any
+-- locks, implementing this special case is likely not worthwhile.
+--
+-- In the non-threaded runtime, `forkOS` is not available, and so on FreeBSD
+-- systems we have to also lock the @*(nam|[ug]id)_r(3)@ functions to avoid
+-- concurrent use with @*ent(3)@.
+--
+-- FWIW, the below Perl one-liners will quickly show whether interleaved calls
+-- of getpwuid() or getgrgid() disturb iteration through all the entries. If
+-- each line of output is distinct, there is likely no issue.  If the same
+-- passwd or group entry repeats multiple times, the system is affected.
+--
+-- > for ($i=0;$i<3;++$i) {getpwuid(0); print join(":",getpwent()),"\n"}
+-- > for ($i=0;$i<3;++$i) {getgrgid(0); print join(":",getgrent()),"\n"}
+--
+-- XXX: It has been suggested, not without some merit, that attempts to
+-- enumerate /all/ users or /all/ groups are fundamentally flawed.  Modern
+-- unix systems have a variety nsswitch backends, some of which instantiate
+-- users on demand or may enumerate slowly or not at all.  We could shed a
+-- lot of complexity by deprecating the "get all" functions and simply
+-- always returning an empty list.
+--
+
+#if defined(HAVE_GETPWENT)
+pwlock :: MVar ()
+pwlock = unsafePerformIO $ newMVar ()
+{-# NOINLINE pwlock #-}
+
+lockpw :: LKUPTYPE -> IO a -> IO a
+#if defined(freebsd_HOST_OS)
+lockpw GETONE
+    | rtsSupportsBoundThreads = id
+    | otherwise = withMVar pwlock . const
+lockpw GETALL
+    | rtsSupportsBoundThreads = runInBoundThread . withMVar pwlock . const
+    | otherwise = withMVar pwlock . const
+#else
+lockpw GETONE = id
+lockpw GETALL = withMVar pwlock . const
+#endif
+#else
+lockpw _ = id
+#endif
+
+#if defined(HAVE_GETGRENT)
+grlock :: MVar ()
+grlock = unsafePerformIO $ newMVar ()
+{-# NOINLINE grlock #-}
+
+lockgr :: LKUPTYPE -> IO a -> IO a
+#if defined(freebsd_HOST_OS)
+lockgr GETONE
+    | rtsSupportsBoundThreads = id
+    | otherwise = withMVar grlock . const
+lockgr GETALL
+    | rtsSupportsBoundThreads = runInBoundThread . withMVar grlock . const
+    | otherwise = withMVar grlock . const
+#else
+lockgr GETONE = id
+lockgr GETALL = withMVar grlock . const
+#endif
+#else
+lockgr _ = id
+#endif
+
+-- -----------------------------------------------------------------------------
+-- user environment
+
+-- | @getRealUserID@ calls @getuid@ to obtain the real @UserID@
+--   associated with the current process.
+getRealUserID :: IO UserID
+getRealUserID = c_getuid
+
+foreign import ccall unsafe "getuid"
+  c_getuid :: IO CUid
+
+-- | @getRealGroupID@ calls @getgid@ to obtain the real @GroupID@
+--   associated with the current process.
+getRealGroupID :: IO GroupID
+getRealGroupID = c_getgid
+
+foreign import ccall unsafe "getgid"
+  c_getgid :: IO CGid
+
+-- | @getEffectiveUserID@ calls @geteuid@ to obtain the effective
+--   @UserID@ associated with the current process.
+getEffectiveUserID :: IO UserID
+getEffectiveUserID = c_geteuid
+
+foreign import ccall unsafe "geteuid"
+  c_geteuid :: IO CUid
+
+-- | @getEffectiveGroupID@ calls @getegid@ to obtain the effective
+--   @GroupID@ associated with the current process.
+getEffectiveGroupID :: IO GroupID
+getEffectiveGroupID = c_getegid
+
+foreign import ccall unsafe "getegid"
+  c_getegid :: IO CGid
+
+-- | @getGroups@ calls @getgroups@ to obtain the list of
+--   supplementary @GroupID@s associated with the current process.
+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
+
+
+-- | @setGroups@ calls @setgroups@ to set the list of
+--   supplementary @GroupID@s associated with the current process.
+setGroups :: [GroupID] -> IO ()
+setGroups groups = do
+    withArrayLen groups $ \ ngroups arr ->
+       throwErrnoIfMinus1_ "setGroups" (c_setgroups (fromIntegral ngroups) arr)
+
+foreign import ccall unsafe "setgroups"
+  c_setgroups :: CInt -> Ptr CGid -> IO CInt
+
+
+-- | @getLoginName@ calls @getlogin@ to obtain the login name
+--   associated with the current process.
+getLoginName :: IO ByteString
+getLoginName =  do
+    -- ToDo: use getlogin_r
+    str <- throwErrnoIfNull "getLoginName" c_getlogin
+    packCString str
+
+foreign import ccall unsafe "getlogin"
+  c_getlogin :: IO CString
+
+-- | @setUserID uid@ calls @setuid@ to set the real, effective, and
+--   saved set-user-id associated with the current process to @uid@.
+setUserID :: UserID -> IO ()
+setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid)
+
+foreign import ccall unsafe "setuid"
+  c_setuid :: CUid -> IO CInt
+
+-- | @setEffectiveUserID uid@ calls @seteuid@ to set the effective
+--   user-id associated with the current process to @uid@. This
+--   does not update the real user-id or set-user-id.
+setEffectiveUserID :: UserID -> IO ()
+setEffectiveUserID uid = throwErrnoIfMinus1_ "setEffectiveUserID" (c_seteuid uid)
+
+foreign import ccall unsafe "seteuid"
+  c_seteuid :: CUid -> IO CInt
+
+-- | @setGroupID gid@ calls @setgid@ to set the real, effective, and
+--   saved set-group-id associated with the current process to @gid@.
+setGroupID :: GroupID -> IO ()
+setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid)
+
+foreign import ccall unsafe "setgid"
+  c_setgid :: CGid -> IO CInt
+
+-- | @setEffectiveGroupID uid@ calls @setegid@ to set the effective
+--   group-id associated with the current process to @gid@. This
+--   does not update the real group-id or set-group-id.
+setEffectiveGroupID :: GroupID -> IO ()
+setEffectiveGroupID gid =
+  throwErrnoIfMinus1_ "setEffectiveGroupID" (c_setegid gid)
+
+
+foreign import ccall unsafe "setegid"
+  c_setegid :: CGid -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- User names
+
+-- | @getEffectiveUserName@ gets the name
+--   associated with the effective @UserID@ of the process.
+getEffectiveUserName :: IO ByteString
+getEffectiveUserName = do
+    euid <- getEffectiveUserID
+    pw <- getUserEntryForID euid
+    return (userName pw)
+
+#endif // HAVE_PWD_H
+
+-- -----------------------------------------------------------------------------
+-- The group database (grp.h)
+
+
+#if !defined(HAVE_PWD_H)
+
+getGroupEntryForID :: GroupID -> IO GroupEntry
+{-# WARNING getGroupEntryForID
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getGroupEntryForID _ = ioError (ioeSetLocation unsupportedOperation "getGroupEntryForID")
+
+getGroupEntryForName :: ByteString -> IO GroupEntry
+{-# WARNING getGroupEntryForName
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getGroupEntryForName _ = ioError (ioeSetLocation unsupportedOperation "getGroupEntryForName")
+
+getAllGroupEntries :: IO [GroupEntry]
+{-# WARNING getAllGroupEntries
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_PWD_H@)" #-}
+getAllGroupEntries = ioError (ioeSetLocation unsupportedOperation "getAllGroupEntries")
+
+#else
+
+-- | @getGroupEntryForID gid@ calls @getgrgid_r@ to obtain
+--   the @GroupEntry@ information associated with @GroupID@
+--   @gid@. This operation may fail with 'isDoesNotExistError'
+--   if no such group exists.
+getGroupEntryForID :: GroupID -> IO GroupEntry
+#ifdef HAVE_GETGRGID_R
+getGroupEntryForID gid = lockgr GETONE $
+    allocaBytes (#const sizeof(struct group)) $ \pgr ->
+        doubleAllocWhileERANGE "getGroupEntryForID" "group"
+            grBufSize unpackGroupEntry $ c_getgrgid_r gid pgr
+
+foreign import capi safe "HsUnix.h getgrgid_r"
+  c_getgrgid_r :: CGid -> Ptr CGroup -> CString
+                 -> CSize -> Ptr (Ptr CGroup) -> IO CInt
+#else
+{-# WARNING getGroupEntryForID "System.Posix.User.getGroupEntryForID: not supported" #-}
+getGroupEntryForID = error "System.Posix.User.getGroupEntryForID: not supported"
+#endif
+
+-- | @getGroupEntryForName name@ calls @getgrnam_r@ to obtain
+--   the @GroupEntry@ information associated with the group called
+--   @name@. This operation may fail with 'isDoesNotExistError'
+--   if no such group exists.
+getGroupEntryForName :: ByteString -> IO GroupEntry
+#ifdef HAVE_GETGRNAM_R
+getGroupEntryForName name = lockgr GETONE $
+    allocaBytes (#const sizeof(struct group)) $ \pgr ->
+        useAsCString name $ \ pstr ->
+            doubleAllocWhileERANGE "getGroupEntryForName" "group"
+                grBufSize unpackGroupEntry $ c_getgrnam_r pstr pgr
+
+foreign import capi safe "HsUnix.h getgrnam_r"
+  c_getgrnam_r :: CString -> Ptr CGroup -> CString
+                 -> CSize -> Ptr (Ptr CGroup) -> IO CInt
+#else
+{-# WARNING getGroupEntryForName "System.Posix.User.getGroupEntryForName: not supported" #-}
+getGroupEntryForName = error "System.Posix.User.getGroupEntryForName: not supported"
+#endif
+
+-- | @getAllGroupEntries@ returns all group entries on the system by
+--   repeatedly calling @getgrent@
+
+--
+-- getAllGroupEntries may fail with isDoesNotExistError on Linux due to
+-- this bug in glibc:
+--   http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=466647
+--
+getAllGroupEntries :: IO [GroupEntry]
+#ifdef HAVE_GETGRENT
+getAllGroupEntries = lockgr GETALL $ bracket_ c_setgrent c_endgrent $ worker []
+  where
+    worker accum = do
+        resetErrno
+        ppw <- throwErrnoIfNullAndError "getAllGroupEntries" $ c_getgrent
+        if ppw == nullPtr
+            then return (reverse accum)
+            else do thisentry <- unpackGroupEntry ppw
+                    worker (thisentry : accum)
+
+foreign import ccall safe "getgrent" c_getgrent :: IO (Ptr CGroup)
+foreign import ccall safe "setgrent" c_setgrent :: IO ()
+foreign import ccall safe "endgrent" c_endgrent :: IO ()
+#else
+{-# WARNING getAllGroupEntries "System.Posix.User.getAllGroupEntries: not supported" #-}
+getAllGroupEntries = error "System.Posix.User.getAllGroupEntries: not supported"
+#endif
+
+#if defined(HAVE_GETGRGID_R) || defined(HAVE_GETGRNAM_R)
+grBufSize :: Int
+#if defined(HAVE_SYSCONF) && defined(HAVE_SC_GETGR_R_SIZE_MAX)
+grBufSize = sysconfWithDefault 1024 (#const _SC_GETGR_R_SIZE_MAX)
+#else
+grBufSize = 1024
+#endif
+#endif
+
+#endif // HAVE_PWD_H
+
+-- -----------------------------------------------------------------------------
+-- The user database (pwd.h)
+
+
+-- | @getUserEntryForID uid@ calls @getpwuid_r@ to obtain
+--   the @UserEntry@ information associated with @UserID@
+--   @uid@. This operation may fail with 'isDoesNotExistError'
+--   if no such user exists.
+getUserEntryForID :: UserID -> IO UserEntry
+#ifdef HAVE_GETPWUID_R
+getUserEntryForID uid = lockpw GETONE $
+    allocaBytes (#const sizeof(struct passwd)) $ \ppw ->
+        doubleAllocWhileERANGE "getUserEntryForID" "user"
+            pwBufSize unpackUserEntry $ c_getpwuid_r uid ppw
+
+foreign import capi safe "HsUnix.h getpwuid_r"
+  c_getpwuid_r :: CUid -> Ptr CPasswd ->
+                        CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt
+#else
+{-# WARNING getUserEntryForID "System.Posix.User.getUserEntryForID: not supported" #-}
+getUserEntryForID = error "System.Posix.User.getUserEntryForID: not supported"
+#endif
+
+-- | @getUserEntryForName name@ calls @getpwnam_r@ to obtain
+--   the @UserEntry@ information associated with the user login
+--   @name@. This operation may fail with 'isDoesNotExistError'
+--   if no such user exists.
+getUserEntryForName :: ByteString -> IO UserEntry
+#if HAVE_GETPWNAM_R
+getUserEntryForName name = lockpw GETONE $
+    allocaBytes (#const sizeof(struct passwd)) $ \ppw ->
+        useAsCString name $ \ pstr ->
+            doubleAllocWhileERANGE "getUserEntryForName" "user"
+                pwBufSize unpackUserEntry $ c_getpwnam_r pstr ppw
+
+foreign import capi safe "HsUnix.h getpwnam_r"
+  c_getpwnam_r :: CString -> Ptr CPasswd
+               -> CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt
+#else
+{-# WARNING getUserEntryForName "System.Posix.User.getUserEntryForName: not supported" #-}
+getUserEntryForName = error "System.Posix.User.getUserEntryForName: not supported"
+#endif
+
+-- | @getAllUserEntries@ returns all user entries on the system by
+--   repeatedly calling @getpwent@
+getAllUserEntries :: IO [UserEntry]
+#ifdef HAVE_GETPWENT
+getAllUserEntries = lockpw GETALL $ bracket_ c_setpwent c_endpwent $ worker []
+  where
+    worker accum = do
+        resetErrno
+        ppw <- throwErrnoIfNullAndError "getAllUserEntries" $ c_getpwent
+        if ppw == nullPtr
+            then return (reverse accum)
+            else do thisentry <- unpackUserEntry ppw
+                    worker (thisentry : accum)
+
+foreign import ccall safe "getpwent" c_getpwent :: IO (Ptr CPasswd)
+foreign import ccall safe "setpwent" c_setpwent :: IO ()
+foreign import ccall safe "endpwent" c_endpwent :: IO ()
+#else
+{-# WARNING getAllUserEntries "System.Posix.User.getAllUserEntries: not supported" #-}
+getAllUserEntries = error "System.Posix.User.getAllUserEntries: not supported"
+#endif
+
+#if defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWNAM_R)
+pwBufSize :: Int
+#if  defined(HAVE_SYSCONF) && defined(HAVE_SC_GETPW_R_SIZE_MAX)
+pwBufSize = sysconfWithDefault 1024 (#const _SC_GETPW_R_SIZE_MAX)
+#else
+pwBufSize = 1024
+#endif
+#endif
+
+#if defined(HAVE_SYSCONF) && defined(HAVE_PWD_H)
+foreign import ccall unsafe "sysconf"
+  c_sysconf :: CInt -> IO CLong
+
+-- We need a default value since sysconf can fail and return -1
+-- even when the parameter name is defined in unistd.h.
+-- One example of this is _SC_GETPW_R_SIZE_MAX under
+-- Mac OS X 10.4.9 on i386.
+sysconfWithDefault :: Int -> CInt -> Int
+sysconfWithDefault def sc =
+    unsafePerformIO $ do v <- fmap fromIntegral $ c_sysconf sc
+                         return $ if v == (-1) then def else v
+#endif
+
+#if defined(HAVE_PWD_H)
+
+-- The following function is used by the getgr*_r, c_getpw*_r
+-- families of functions. These functions return their result
+-- in a struct that contains strings and they need a buffer
+-- that they can use to store those strings. We have to be
+-- careful to unpack the struct containing the result before
+-- the buffer is deallocated.
+doubleAllocWhileERANGE
+  :: String
+  -> String -- entry type: "user" or "group"
+  -> Int
+  -> (Ptr r -> IO a)
+  -> (Ptr b -> CSize -> Ptr (Ptr r) -> IO CInt)
+  -> IO a
+doubleAllocWhileERANGE loc enttype initlen unpack action =
+  alloca $ go initlen
+ where
+  go len res = do
+    r <- allocaBytes len $ \buf -> do
+           rc <- action buf (fromIntegral len) res
+           if rc /= 0
+             then return (Left rc)
+             else do p <- peek res
+                     when (p == nullPtr) $ notFoundErr
+                     fmap Right (unpack p)
+    case r of
+      Right x -> return x
+      Left rc | Errno rc == eRANGE ->
+        -- ERANGE means this is not an error
+        -- we just have to try again with a larger buffer
+        go (2 * len) res
+      Left rc ->
+        ioError (errnoToIOError loc (Errno rc) Nothing Nothing)
+  notFoundErr =
+    ioError $ flip ioeSetErrorString ("no such " ++ enttype)
+            $ mkIOError doesNotExistErrorType loc Nothing Nothing
+
+-- Used when a function returns NULL to indicate either an error or
+-- EOF, depending on whether the global errno is nonzero.
+throwErrnoIfNullAndError :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNullAndError loc act = do
+    rc <- act
+    errno <- getErrno
+    if rc == nullPtr && errno /= eOK
+       then throwErrno loc
+       else return rc
+
+#endif // HAVE_PWD_H

System/Posix/User/Common.hsc

+{-# LANGUAGE Safe #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.User.Common
+-- 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.Common where
+
+import Data.ByteString ( ByteString )
+import System.Posix.Types
+
+#include "HsUnix.h"
+
+
+#if defined(HAVE_PWD_H)
+import Foreign.Ptr
+import Foreign.Marshal
+import Foreign.Storable
+import Data.ByteString ( packCString )
+
+-- internal types
+data {-# CTYPE "struct passwd" #-} CPasswd
+data {-# CTYPE "struct group"  #-} CGroup
+
+data LKUPTYPE = GETONE | GETALL
+
+unpackGroupEntry :: Ptr CGroup -> IO GroupEntry
+unpackGroupEntry ptr = do
+   name    <- (#peek struct group, gr_name) ptr >>= packCString
+   passwd  <- (#peek struct group, gr_passwd) ptr >>= packCString
+   gid     <- (#peek struct group, gr_gid) ptr
+   mem     <- (#peek struct group, gr_mem) ptr
+   members <- peekArray0 nullPtr mem >>= mapM packCString
+   return (GroupEntry name passwd gid members)
+
+unpackUserEntry :: Ptr CPasswd -> IO UserEntry
+unpackUserEntry ptr = do
+   name   <- (#peek struct passwd, pw_name)   ptr >>= packCString
+   passwd <- (#peek struct passwd, pw_passwd) ptr >>= packCString
+   uid    <- (#peek struct passwd, pw_uid)    ptr
+   gid    <- (#peek struct passwd, pw_gid)    ptr
+#ifdef HAVE_NO_PASSWD_PW_GECOS
+   gecos  <- return ""  -- pw_gecos does not exist on android
+#else
+   gecos  <- (#peek struct passwd, pw_gecos)  ptr >>= packCString
+#endif
+   dir    <- (#peek struct passwd, pw_dir)    ptr >>= packCString
+   shell  <- (#peek struct passwd, pw_shell)  ptr >>= packCString
+   return (UserEntry name passwd uid gid gecos dir shell)
+
+#endif // HAVE_PWD_H
+
+data UserEntry =
+ UserEntry {
+   userName      :: ByteString,     -- ^ Textual name of this user (pw_name)
+   userPassword  :: ByteString,     -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd)
+   userID        :: UserID,         -- ^ Numeric ID for this user (pw_uid)
+   userGroupID   :: GroupID,        -- ^ Primary group ID (pw_gid)
+   userGecos     :: ByteString,     -- ^ Usually the real name for the user (pw_gecos)
+   homeDirectory :: ByteString,     -- ^ Home directory (pw_dir)
+   userShell     :: ByteString      -- ^ Default shell (pw_shell)
+ } deriving (Show, Read, Eq)
+
+data GroupEntry =
+ GroupEntry {
+  groupName     :: ByteString,   -- ^ The name of this group (gr_name)
+  groupPassword :: ByteString,   -- ^ The password for this group (gr_passwd)
+  groupID       :: GroupID,      -- ^ The unique numeric ID for this group (gr_gid)
+  groupMembers  :: [ByteString]  -- ^ A list of zero or more usernames that are members (gr_mem)
+ } deriving (Show, Read, Eq)

unix.cabal

@@ -82,12 +82,14 @@ library
         System.Posix.Resource
         System.Posix.Time
         System.Posix.Unistd
-        System.Posix.User
         System.Posix.Signals
         System.Posix.Signals.Exts
         System.Posix.Semaphore
         System.Posix.SharedMem
 
+        System.Posix.User
+        System.Posix.User.ByteString
+
         System.Posix.ByteString.FilePath
         System.Posix.PosixPath.FilePath
 
@@ -137,6 +139,7 @@ library
         System.Posix.IO.Common
         System.Posix.Process.Common
         System.Posix.Terminal.Common
+        System.Posix.User.Common
 
     ghc-options: -Wall