1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators continuations kernel math
4 math.parser namespaces sequences strings system unix unix.ffi
5 vocabs vocabs.platforms ;
9 TUPLE: passwd user-name password uid gid gecos dir shell ;
11 HOOK: new-passwd os ( -- passwd )
12 HOOK: passwd>new-passwd os ( passwd -- new-passwd )
19 M: unix passwd>new-passwd
22 [ pw_name>> >>user-name ]
23 [ pw_passwd>> >>password ]
26 [ pw_gecos>> >>gecos ]
28 [ pw_shell>> >>shell ]
31 : with-pwent ( quot -- )
33 [ unix.ffi:endpwent ] finally ; inline
37 : all-users ( -- seq )
39 [ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
42 : all-user-names ( -- seq )
43 all-users [ user-name>> ] map ;
47 : <user-cache> ( -- assoc )
48 all-users [ [ uid>> ] keep ] H{ } map>assoc ;
50 : with-user-cache ( quot -- )
51 [ <user-cache> user-cache ] dip with-variable ; inline
53 GENERIC: user-passwd ( obj -- passwd/f )
55 M: integer user-passwd
57 [ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
60 unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
62 : user-name ( id -- string )
64 [ nip user-name>> ] [ number>string ] if* ;
66 : user-id ( string -- id/f )
67 user-passwd dup [ uid>> ] when ;
69 ERROR: no-user string ;
71 : ?user-id ( string -- id/f )
72 dup user-passwd [ nip uid>> ] [ no-user ] if* ;
74 : real-user-id ( -- id )
75 unix.ffi:getuid ; inline
77 : real-user-name ( -- string )
78 real-user-id user-name ; inline
80 : effective-user-id ( -- id )
81 unix.ffi:geteuid ; inline
83 : effective-user-name ( -- string )
84 effective-user-id user-name ; inline
86 : user-exists? ( name/id -- ? ) user-id >boolean ;
88 GENERIC: set-real-user ( string/id -- )
90 GENERIC: set-effective-user ( string/id -- )
92 : (with-real-user) ( string/id quot -- )
93 '[ _ set-real-user @ ]
94 real-user-id '[ _ set-real-user ]
97 : with-real-user ( string/id/f quot -- )
98 over [ (with-real-user) ] [ nip call ] if ; inline
100 : (with-effective-user) ( string/id quot -- )
101 '[ _ set-effective-user @ ]
102 effective-user-id '[ _ set-effective-user ]
105 : with-effective-user ( string/id/f quot -- )
106 over [ (with-effective-user) ] [ nip call ] if ; inline
110 : (set-real-user) ( id -- )
111 [ unix.ffi:setuid ] unix-system-call drop ; inline
113 : (set-effective-user) ( id -- )
114 [ unix.ffi:seteuid ] unix-system-call drop ; inline
118 M: integer set-real-user
121 M: string set-real-user
122 ?user-id (set-real-user) ;
124 M: integer set-effective-user
125 (set-effective-user) ;
127 M: string set-effective-user
128 ?user-id (set-effective-user) ;
130 ERROR: no-such-user obj ;
132 : user-home ( name/uid -- path )
133 dup user-passwd [ nip dir>> ] [ no-such-user ] if* ;
135 USE-MACOSX: unix.users.macosx