1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.strings assocs
4 byte-arrays classes.struct combinators combinators.short-circuit
5 continuations fry grouping io.encodings.utf8 kernel math
6 math.parser namespaces sequences splitting strings system unix
11 TUPLE: passwd user-name password uid gid gecos dir shell ;
13 HOOK: new-passwd os ( -- passwd )
14 HOOK: passwd>new-passwd os ( passwd -- new-passwd )
18 M: unix new-passwd ( -- passwd )
21 M: unix passwd>new-passwd ( passwd -- seq )
24 [ pw_name>> >>user-name ]
25 [ pw_passwd>> >>password ]
28 [ pw_gecos>> >>gecos ]
30 [ pw_shell>> >>shell ]
33 : with-pwent ( quot -- )
35 [ unix.ffi:endpwent ] [ ] cleanup ; inline
39 : all-users ( -- seq )
41 [ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
44 : all-user-names ( -- seq )
45 all-users [ user-name>> ] map ;
49 : <user-cache> ( -- assoc )
50 all-users [ [ uid>> ] keep ] H{ } map>assoc ;
52 : with-user-cache ( quot -- )
53 [ <user-cache> user-cache ] dip with-variable ; inline
55 GENERIC: user-passwd ( obj -- passwd/f )
57 M: integer user-passwd ( id -- passwd/f )
59 [ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
61 M: string user-passwd ( string -- passwd/f )
62 unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
64 : user-name ( id -- string )
66 [ nip user-name>> ] [ number>string ] if* ;
68 : user-id ( string -- id/f )
69 user-passwd dup [ uid>> ] when ;
71 ERROR: no-user string ;
73 : ?user-id ( string -- id/f )
74 dup user-passwd [ nip uid>> ] [ throw-no-user ] if* ;
76 : real-user-id ( -- id )
77 unix.ffi:getuid ; inline
79 : real-user-name ( -- string )
80 real-user-id user-name ; inline
82 : effective-user-id ( -- id )
83 unix.ffi:geteuid ; inline
85 : effective-user-name ( -- string )
86 effective-user-id user-name ; inline
88 : user-exists? ( name/id -- ? ) user-id >boolean ;
90 GENERIC: set-real-user ( string/id -- )
92 GENERIC: set-effective-user ( string/id -- )
94 : (with-real-user) ( string/id quot -- )
95 '[ _ set-real-user @ ]
96 real-user-id '[ _ set-real-user ]
99 : with-real-user ( string/id/f quot -- )
100 over [ (with-real-user) ] [ nip call ] if ; inline
102 : (with-effective-user) ( string/id quot -- )
103 '[ _ set-effective-user @ ]
104 effective-user-id '[ _ set-effective-user ]
107 : with-effective-user ( string/id/f quot -- )
108 over [ (with-effective-user) ] [ nip call ] if ; inline
112 : (set-real-user) ( id -- )
113 [ unix.ffi:setuid ] unix-system-call drop ; inline
115 : (set-effective-user) ( id -- )
116 [ unix.ffi:seteuid ] unix-system-call drop ; inline
120 M: integer set-real-user ( id -- )
123 M: string set-real-user ( string -- )
124 ?user-id (set-real-user) ;
126 M: integer set-effective-user ( id -- )
127 (set-effective-user) ;
129 M: string set-effective-user ( string -- )
130 ?user-id (set-effective-user) ;
132 ERROR: no-such-user obj ;
134 : user-home ( name/uid -- path )
135 dup user-passwd [ nip dir>> ] [ throw-no-such-user ] if* ;
137 os macosx? [ "unix.users.macosx" require ] when