Replace `__hsunix_getpw{nam,uid_r}` wrappers with CApiFFI
[packages/unix.git] / System / Posix / User.hsc
1 {-# LANGUAGE Trustworthy, CApiFFI #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module      :  System.Posix.User
5 -- Copyright   :  (c) The University of Glasgow 2002
6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
7 --
8 -- Maintainer  :  libraries@haskell.org
9 -- Stability   :  provisional
10 -- Portability :  non-portable (requires POSIX)
11 --
12 -- POSIX user\/group support
13 --
14 -----------------------------------------------------------------------------
15
16 module System.Posix.User (
17     -- * User environment
18     -- ** Querying the user environment
19     getRealUserID,
20     getRealGroupID,
21     getEffectiveUserID,
22     getEffectiveGroupID,
23     getGroups,
24     getLoginName,
25     getEffectiveUserName,
26
27     -- *** The group database
28     GroupEntry(..),
29     getGroupEntryForID,
30     getGroupEntryForName,
31     getAllGroupEntries,
32
33     -- *** The user database
34     UserEntry(..),
35     getUserEntryForID,
36     getUserEntryForName,
37     getAllUserEntries,
38
39     -- ** Modifying the user environment
40     setUserID,
41     setGroupID,
42     setEffectiveUserID,
43     setEffectiveGroupID,
44     setGroups
45
46   ) where
47
48 #include "HsUnix.h"
49
50 import System.Posix.Types
51 import System.IO.Unsafe (unsafePerformIO)
52 import Foreign.C
53 import Foreign.Ptr
54 import Foreign.Marshal
55 import Foreign.Storable
56
57 #if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT)
58 import Control.Concurrent.MVar  ( MVar, newMVar, withMVar )
59 #endif
60 #ifdef HAVE_GETPWENT
61 import Control.Exception
62 #endif
63 import Control.Monad
64 import System.IO.Error
65
66 -- internal types
67 data {-# CTYPE "struct passwd" #-} CPasswd
68 data {-# CTYPE "struct group"  #-} CGroup
69
70 -- -----------------------------------------------------------------------------
71 -- user environemnt
72
73 -- | @getRealUserID@ calls @getuid@ to obtain the real @UserID@
74 --   associated with the current process.
75 getRealUserID :: IO UserID
76 getRealUserID = c_getuid
77
78 foreign import ccall unsafe "getuid"
79   c_getuid :: IO CUid
80
81 -- | @getRealGroupID@ calls @getgid@ to obtain the real @GroupID@
82 --   associated with the current process.
83 getRealGroupID :: IO GroupID
84 getRealGroupID = c_getgid
85
86 foreign import ccall unsafe "getgid"
87   c_getgid :: IO CGid
88
89 -- | @getEffectiveUserID@ calls @geteuid@ to obtain the effective
90 --   @UserID@ associated with the current process.
91 getEffectiveUserID :: IO UserID
92 getEffectiveUserID = c_geteuid
93
94 foreign import ccall unsafe "geteuid"
95   c_geteuid :: IO CUid
96
97 -- | @getEffectiveGroupID@ calls @getegid@ to obtain the effective
98 --   @GroupID@ associated with the current process.
99 getEffectiveGroupID :: IO GroupID
100 getEffectiveGroupID = c_getegid
101
102 foreign import ccall unsafe "getegid"
103   c_getegid :: IO CGid
104
105 -- | @getGroups@ calls @getgroups@ to obtain the list of
106 --   supplementary @GroupID@s associated with the current process.
107 getGroups :: IO [GroupID]
108 getGroups = do
109     ngroups <- c_getgroups 0 nullPtr
110     allocaArray (fromIntegral ngroups) $ \arr -> do
111        throwErrnoIfMinus1_ "getGroups" (c_getgroups ngroups arr)
112        groups <- peekArray (fromIntegral ngroups) arr
113        return groups
114
115 foreign import ccall unsafe "getgroups"
116   c_getgroups :: CInt -> Ptr CGid -> IO CInt
117
118
119 -- | @setGroups@ calls @setgroups@ to set the list of
120 --   supplementary @GroupID@s associated with the current process.
121 setGroups :: [GroupID] -> IO ()
122 setGroups groups = do
123     withArrayLen groups $ \ ngroups arr ->
124        throwErrnoIfMinus1_ "setGroups" (c_setgroups (fromIntegral ngroups) arr)
125
126 foreign import ccall unsafe "setgroups"
127   c_setgroups :: CInt -> Ptr CGid -> IO CInt
128
129
130
131 -- | @getLoginName@ calls @getlogin@ to obtain the login name
132 --   associated with the current process.
133 getLoginName :: IO String
134 getLoginName =  do
135     -- ToDo: use getlogin_r
136     str <- throwErrnoIfNull "getLoginName" c_getlogin
137     peekCAString str
138
139 foreign import ccall unsafe "getlogin"
140   c_getlogin :: IO CString
141
142 -- | @setUserID uid@ calls @setuid@ to set the real, effective, and
143 --   saved set-user-id associated with the current process to @uid@.
144 setUserID :: UserID -> IO ()
145 setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid)
146
147 foreign import ccall unsafe "setuid"
148   c_setuid :: CUid -> IO CInt
149
150 -- | @setEffectiveUserID uid@ calls @seteuid@ to set the effective
151 --   user-id associated with the current process to @uid@. This
152 --   does not update the real user-id or set-user-id.
153 setEffectiveUserID :: UserID -> IO ()
154 setEffectiveUserID uid = throwErrnoIfMinus1_ "setEffectiveUserID" (c_seteuid uid)
155
156 foreign import ccall unsafe "seteuid"
157   c_seteuid :: CUid -> IO CInt
158
159 -- | @setGroupID gid@ calls @setgid@ to set the real, effective, and
160 --   saved set-group-id associated with the current process to @gid@.
161 setGroupID :: GroupID -> IO ()
162 setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid)
163
164 foreign import ccall unsafe "setgid"
165   c_setgid :: CGid -> IO CInt
166
167 -- | @setEffectiveGroupID uid@ calls @setegid@ to set the effective
168 --   group-id associated with the current process to @gid@. This
169 --   does not update the real group-id or set-group-id.
170 setEffectiveGroupID :: GroupID -> IO ()
171 setEffectiveGroupID gid =
172   throwErrnoIfMinus1_ "setEffectiveGroupID" (c_setegid gid)
173
174
175 foreign import ccall unsafe "setegid"
176   c_setegid :: CGid -> IO CInt
177
178 -- -----------------------------------------------------------------------------
179 -- User names
180
181 -- | @getEffectiveUserName@ gets the name
182 --   associated with the effective @UserID@ of the process.
183 getEffectiveUserName :: IO String
184 getEffectiveUserName = do
185     euid <- getEffectiveUserID
186     pw <- getUserEntryForID euid
187     return (userName pw)
188
189 -- -----------------------------------------------------------------------------
190 -- The group database (grp.h)
191
192 data GroupEntry =
193  GroupEntry {
194   groupName    :: String,       -- ^ The name of this group (gr_name)
195   groupPassword :: String,      -- ^ The password for this group (gr_passwd)
196   groupID      :: GroupID,      -- ^ The unique numeric ID for this group (gr_gid)
197   groupMembers :: [String]      -- ^ A list of zero or more usernames that are members (gr_mem)
198  } deriving (Show, Read, Eq)
199
200 -- | @getGroupEntryForID gid@ calls @getgrgid_r@ to obtain
201 --   the @GroupEntry@ information associated with @GroupID@
202 --   @gid@. This operation may fail with 'isDoesNotExistError'
203 --   if no such group exists.
204 getGroupEntryForID :: GroupID -> IO GroupEntry
205 #ifdef HAVE_GETGRGID_R
206 getGroupEntryForID gid =
207   allocaBytes (#const sizeof(struct group)) $ \pgr ->
208    doubleAllocWhileERANGE "getGroupEntryForID" "group" grBufSize unpackGroupEntry $
209      c_getgrgid_r gid pgr
210
211 foreign import capi unsafe "HsUnix.h getgrgid_r"
212   c_getgrgid_r :: CGid -> Ptr CGroup -> CString
213                  -> CSize -> Ptr (Ptr CGroup) -> IO CInt
214 #else
215 getGroupEntryForID = error "System.Posix.User.getGroupEntryForID: not supported"
216 #endif
217
218 -- | @getGroupEntryForName name@ calls @getgrnam_r@ to obtain
219 --   the @GroupEntry@ information associated with the group called
220 --   @name@. This operation may fail with 'isDoesNotExistError'
221 --   if no such group exists.
222 getGroupEntryForName :: String -> IO GroupEntry
223 #ifdef HAVE_GETGRNAM_R
224 getGroupEntryForName name =
225   allocaBytes (#const sizeof(struct group)) $ \pgr ->
226     withCAString name $ \ pstr ->
227       doubleAllocWhileERANGE "getGroupEntryForName" "group" grBufSize unpackGroupEntry $
228         c_getgrnam_r pstr pgr
229
230 foreign import capi unsafe "HsUnix.h getgrnam_r"
231   c_getgrnam_r :: CString -> Ptr CGroup -> CString
232                  -> CSize -> Ptr (Ptr CGroup) -> IO CInt
233 #else
234 getGroupEntryForName = error "System.Posix.User.getGroupEntryForName: not supported"
235 #endif
236
237 -- | @getAllGroupEntries@ returns all group entries on the system by
238 --   repeatedly calling @getgrent@
239
240 --
241 -- getAllGroupEntries may fail with isDoesNotExistError on Linux due to
242 -- this bug in glibc:
243 --   http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=466647
244 --
245 getAllGroupEntries :: IO [GroupEntry]
246 #ifdef HAVE_GETGRENT
247 getAllGroupEntries =
248     withMVar lock $ \_ -> bracket_ c_setgrent c_endgrent $ worker []
249     where worker accum =
250               do resetErrno
251                  ppw <- throwErrnoIfNullAndError "getAllGroupEntries" $
252                         c_getgrent
253                  if ppw == nullPtr
254                      then return (reverse accum)
255                      else do thisentry <- unpackGroupEntry ppw
256                              worker (thisentry : accum)
257
258 foreign import ccall unsafe "getgrent"
259   c_getgrent :: IO (Ptr CGroup)
260 foreign import ccall unsafe "setgrent"
261   c_setgrent :: IO ()
262 foreign import ccall unsafe "endgrent"
263   c_endgrent :: IO ()
264 #else
265 getAllGroupEntries = error "System.Posix.User.getAllGroupEntries: not supported"
266 #endif
267
268 #if defined(HAVE_GETGRGID_R) || defined(HAVE_GETGRNAM_R)
269 grBufSize :: Int
270 #if defined(HAVE_SYSCONF) && defined(HAVE_SC_GETGR_R_SIZE_MAX)
271 grBufSize = sysconfWithDefault 1024 (#const _SC_GETGR_R_SIZE_MAX)
272 #else
273 grBufSize = 1024
274 #endif
275 #endif
276
277 unpackGroupEntry :: Ptr CGroup -> IO GroupEntry
278 unpackGroupEntry ptr = do
279    name    <- (#peek struct group, gr_name) ptr >>= peekCAString
280    passwd  <- (#peek struct group, gr_passwd) ptr >>= peekCAString
281    gid     <- (#peek struct group, gr_gid) ptr
282    mem     <- (#peek struct group, gr_mem) ptr
283    members <- peekArray0 nullPtr mem >>= mapM peekCAString
284    return (GroupEntry name passwd gid members)
285
286 -- -----------------------------------------------------------------------------
287 -- The user database (pwd.h)
288
289 data UserEntry =
290  UserEntry {
291    userName      :: String,     -- ^ Textual name of this user (pw_name)
292    userPassword  :: String,     -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd)
293    userID        :: UserID,     -- ^ Numeric ID for this user (pw_uid)
294    userGroupID   :: GroupID,    -- ^ Primary group ID (pw_gid)
295    userGecos     :: String,     -- ^ Usually the real name for the user (pw_gecos)
296    homeDirectory :: String,     -- ^ Home directory (pw_dir)
297    userShell     :: String      -- ^ Default shell (pw_shell)
298  } deriving (Show, Read, Eq)
299
300 --
301 -- getpwuid and getpwnam leave results in a static object. Subsequent
302 -- calls modify the same object, which isn't threadsafe. We attempt to
303 -- mitigate this issue, on platforms that don't provide the safe _r versions
304 --
305 -- Also, getpwent/setpwent require a global lock since they maintain
306 -- an internal file position pointer.
307 #if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT)
308 lock :: MVar ()
309 lock = unsafePerformIO $ newMVar ()
310 {-# NOINLINE lock #-}
311 #endif
312
313 -- | @getUserEntryForID gid@ calls @getpwuid_r@ to obtain
314 --   the @UserEntry@ information associated with @UserID@
315 --   @uid@. This operation may fail with 'isDoesNotExistError'
316 --   if no such user exists.
317 getUserEntryForID :: UserID -> IO UserEntry
318 #ifdef HAVE_GETPWUID_R
319 getUserEntryForID uid =
320   allocaBytes (#const sizeof(struct passwd)) $ \ppw ->
321     doubleAllocWhileERANGE "getUserEntryForID" "user" pwBufSize unpackUserEntry $
322       c_getpwuid_r uid ppw
323
324 foreign import capi unsafe "HsUnix.h getpwuid_r"
325   c_getpwuid_r :: CUid -> Ptr CPasswd ->
326                         CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt
327 #elif HAVE_GETPWUID
328 getUserEntryForID uid = do
329   withMVar lock $ \_ -> do
330     ppw <- throwErrnoIfNull "getUserEntryForID" $ c_getpwuid uid
331     unpackUserEntry ppw
332
333 foreign import ccall unsafe "getpwuid"
334   c_getpwuid :: CUid -> IO (Ptr CPasswd)
335 #else
336 getUserEntryForID = error "System.Posix.User.getUserEntryForID: not supported"
337 #endif
338
339 -- | @getUserEntryForName name@ calls @getpwnam_r@ to obtain
340 --   the @UserEntry@ information associated with the user login
341 --   @name@. This operation may fail with 'isDoesNotExistError'
342 --   if no such user exists.
343 getUserEntryForName :: String -> IO UserEntry
344 #if HAVE_GETPWNAM_R
345 getUserEntryForName name =
346   allocaBytes (#const sizeof(struct passwd)) $ \ppw ->
347     withCAString name $ \ pstr ->
348       doubleAllocWhileERANGE "getUserEntryForName" "user" pwBufSize unpackUserEntry $
349         c_getpwnam_r pstr ppw
350
351 foreign import capi unsafe "HsUnix.h getpwnam_r"
352   c_getpwnam_r :: CString -> Ptr CPasswd
353                -> CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt
354 #elif HAVE_GETPWNAM
355 getUserEntryForName name = do
356   withCAString name $ \ pstr -> do
357     withMVar lock $ \_ -> do
358       ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr
359       unpackUserEntry ppw
360
361 foreign import ccall unsafe "getpwnam"
362   c_getpwnam :: CString -> IO (Ptr CPasswd)
363 #else
364 getUserEntryForName = error "System.Posix.User.getUserEntryForName: not supported"
365 #endif
366
367 -- | @getAllUserEntries@ returns all user entries on the system by
368 --   repeatedly calling @getpwent@
369 getAllUserEntries :: IO [UserEntry]
370 #ifdef HAVE_GETPWENT
371 getAllUserEntries =
372     withMVar lock $ \_ -> bracket_ c_setpwent c_endpwent $ worker []
373     where worker accum =
374               do resetErrno
375                  ppw <- throwErrnoIfNullAndError "getAllUserEntries" $
376                         c_getpwent
377                  if ppw == nullPtr
378                      then return (reverse accum)
379                      else do thisentry <- unpackUserEntry ppw
380                              worker (thisentry : accum)
381
382 foreign import capi unsafe "HsUnix.h getpwent"
383   c_getpwent :: IO (Ptr CPasswd)
384 foreign import capi unsafe "HsUnix.h setpwent"
385   c_setpwent :: IO ()
386 foreign import capi unsafe "HsUnix.h endpwent"
387   c_endpwent :: IO ()
388 #else
389 getAllUserEntries = error "System.Posix.User.getAllUserEntries: not supported"
390 #endif
391
392 #if defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWNAM_R)
393 pwBufSize :: Int
394 #if  defined(HAVE_SYSCONF) && defined(HAVE_SC_GETPW_R_SIZE_MAX)
395 pwBufSize = sysconfWithDefault 1024 (#const _SC_GETPW_R_SIZE_MAX)
396 #else
397 pwBufSize = 1024
398 #endif
399 #endif
400
401 #ifdef HAVE_SYSCONF
402 foreign import ccall unsafe "sysconf"
403   c_sysconf :: CInt -> IO CLong
404
405 -- We need a default value since sysconf can fail and return -1
406 -- even when the parameter name is defined in unistd.h.
407 -- One example of this is _SC_GETPW_R_SIZE_MAX under
408 -- Mac OS X 10.4.9 on i386.
409 sysconfWithDefault :: Int -> CInt -> Int
410 sysconfWithDefault def sc =
411     unsafePerformIO $ do v <- fmap fromIntegral $ c_sysconf sc
412                          return $ if v == (-1) then def else v
413 #endif
414
415 -- The following function is used by the getgr*_r, c_getpw*_r
416 -- families of functions. These functions return their result
417 -- in a struct that contains strings and they need a buffer
418 -- that they can use to store those strings. We have to be
419 -- careful to unpack the struct containing the result before
420 -- the buffer is deallocated.
421 doubleAllocWhileERANGE
422   :: String
423   -> String -- entry type: "user" or "group"
424   -> Int
425   -> (Ptr r -> IO a)
426   -> (Ptr b -> CSize -> Ptr (Ptr r) -> IO CInt)
427   -> IO a
428 doubleAllocWhileERANGE loc enttype initlen unpack action =
429   alloca $ go initlen
430  where
431   go len res = do
432     r <- allocaBytes len $ \buf -> do
433            rc <- action buf (fromIntegral len) res
434            if rc /= 0
435              then return (Left rc)
436              else do p <- peek res
437                      when (p == nullPtr) $ notFoundErr
438                      fmap Right (unpack p)
439     case r of
440       Right x -> return x
441       Left rc | Errno rc == eRANGE ->
442         -- ERANGE means this is not an error
443         -- we just have to try again with a larger buffer
444         go (2 * len) res
445       Left rc ->
446         ioError (errnoToIOError loc (Errno rc) Nothing Nothing)
447   notFoundErr =
448     ioError $ flip ioeSetErrorString ("no such " ++ enttype)
449             $ mkIOError doesNotExistErrorType loc Nothing Nothing
450
451 unpackUserEntry :: Ptr CPasswd -> IO UserEntry
452 unpackUserEntry ptr = do
453    name   <- (#peek struct passwd, pw_name)   ptr >>= peekCAString
454    passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCAString
455    uid    <- (#peek struct passwd, pw_uid)    ptr
456    gid    <- (#peek struct passwd, pw_gid)    ptr
457 #ifdef HAVE_NO_PASSWD_PW_GECOS
458    gecos  <- return ""  -- pw_gecos does not exist on android
459 #else
460    gecos  <- (#peek struct passwd, pw_gecos)  ptr >>= peekCAString
461 #endif
462    dir    <- (#peek struct passwd, pw_dir)    ptr >>= peekCAString
463    shell  <- (#peek struct passwd, pw_shell)  ptr >>= peekCAString
464    return (UserEntry name passwd uid gid gecos dir shell)
465
466 -- Used when a function returns NULL to indicate either an error or
467 -- EOF, depending on whether the global errno is nonzero.
468 throwErrnoIfNullAndError :: String -> IO (Ptr a) -> IO (Ptr a)
469 throwErrnoIfNullAndError loc act = do
470     rc <- act
471     errno <- getErrno
472     if rc == nullPtr && errno /= eOK
473        then throwErrno loc
474        else return rc