1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.strings io.encodings.utf8
4 io.unix.backend kernel math sequences splitting unix strings
5 combinators.short-circuit grouping byte-arrays combinators
6 accessors math.parser fry assocs namespaces continuations
10 TUPLE: passwd username password uid gid gecos dir shell ;
12 HOOK: new-passwd os ( -- passwd )
13 HOOK: passwd>new-passwd os ( passwd -- new-passwd )
17 M: unix new-passwd ( -- passwd )
20 M: unix passwd>new-passwd ( passwd -- seq )
23 [ passwd-pw_name >>username ]
24 [ passwd-pw_passwd >>password ]
25 [ passwd-pw_uid >>uid ]
26 [ passwd-pw_gid >>gid ]
27 [ passwd-pw_gecos >>gecos ]
28 [ passwd-pw_dir >>dir ]
29 [ passwd-pw_shell >>shell ]
32 : with-pwent ( quot -- )
33 [ endpwent ] [ ] cleanup ; inline
37 : all-users ( -- seq )
39 [ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
44 : <user-cache> ( -- assoc )
45 all-users [ [ uid>> ] keep ] H{ } map>assoc ;
47 : with-user-cache ( quot -- )
48 [ <user-cache> user-cache ] dip with-variable ; inline
50 GENERIC: user-passwd ( obj -- passwd )
52 M: integer user-passwd ( id -- passwd/f )
54 [ at ] [ getpwuid passwd>new-passwd ] if* ;
56 M: string user-passwd ( string -- passwd/f )
57 getpwnam dup [ passwd>new-passwd ] when ;
59 : username ( id -- string )
60 user-passwd username>> ;
62 : user-id ( string -- id )
65 : real-user-id ( -- id )
68 : real-username ( -- string )
69 real-user-id username ; inline
71 : effective-user-id ( -- id )
74 : effective-username ( -- string )
75 effective-user-id username ; inline
77 GENERIC: set-real-user ( string/id -- )
79 GENERIC: set-effective-user ( string/id -- )
81 : with-real-user ( string/id quot -- )
82 '[ _ set-real-user @ ]
83 real-user-id '[ _ set-real-user ]
86 : with-effective-user ( string/id quot -- )
87 '[ _ set-effective-user @ ]
88 effective-user-id '[ _ set-effective-user ]
93 : (set-real-user) ( id -- )
94 setuid io-error ; inline
96 : (set-effective-user) ( id -- )
97 seteuid io-error ; inline
101 M: string set-real-user ( string -- )
102 user-id (set-real-user) ;
104 M: integer set-real-user ( id -- )
107 M: integer set-effective-user ( id -- )
108 (set-effective-user) ;
110 M: string set-effective-user ( string -- )
111 user-id (set-effective-user) ;
114 { [ dup bsd? ] [ drop "unix.users.bsd" require ] }
115 { [ dup linux? ] [ drop ] }