basis/unix/users/users.factor

   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
   7 unix.ffi vocabs ;
   8 QUALIFIED: unix.ffi
   9 IN: unix.users
  10
  11 TUPLE: passwd user-name password uid gid gecos dir shell ;
  12
  13 HOOK: new-passwd os ( -- passwd )
  14 HOOK: passwd>new-passwd os ( passwd -- new-passwd )
  15
  16 <PRIVATE
  17
  18 M: unix new-passwd ( -- passwd )
  19     passwd new ;
  20
  21 M: unix passwd>new-passwd ( passwd -- seq )
  22     [ new-passwd ] dip
  23     {
  24         [ pw_name>> >>user-name ]
  25         [ pw_passwd>> >>password ]
  26         [ pw_uid>> >>uid ]
  27         [ pw_gid>> >>gid ]
  28         [ pw_gecos>> >>gecos ]
  29         [ pw_dir>> >>dir ]
  30         [ pw_shell>> >>shell ]
  31     } cleave ;
  32
  33 : with-pwent ( quot -- )
  34     setpwent
  35     [ unix.ffi:endpwent ] [ ] cleanup ; inline
  36
  37 PRIVATE>
  38
  39 : all-users ( -- seq )
  40     [
  41         [ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
  42     ] with-pwent ;
  43
  44 : all-user-names ( -- seq )
  45     all-users [ user-name>> ] map ;
  46
  47 SYMBOL: user-cache
  48
  49 : <user-cache> ( -- assoc )
  50     all-users [ [ uid>> ] keep ] H{ } map>assoc ;
  51
  52 : with-user-cache ( quot -- )
  53     [ <user-cache> user-cache ] dip with-variable ; inline
  54
  55 GENERIC: user-passwd ( obj -- passwd/f )
  56
  57 M: integer user-passwd ( id -- passwd/f )
  58     user-cache get
  59     [ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
  60
  61 M: string user-passwd ( string -- passwd/f )
  62     unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
  63
  64 : user-name ( id -- string )
  65     dup user-passwd
  66     [ nip user-name>> ] [ number>string ] if* ;
  67
  68 : user-id ( string -- id/f )
  69     user-passwd dup [ uid>> ] when ;
  70
  71 ERROR: no-user string ;
  72
  73 : ?user-id ( string -- id/f )
  74     dup user-passwd [ nip uid>> ] [ no-user ] if* ;
  75
  76 : real-user-id ( -- id )
  77     unix.ffi:getuid ; inline
  78
  79 : real-user-name ( -- string )
  80     real-user-id user-name ; inline
  81
  82 : effective-user-id ( -- id )
  83     unix.ffi:geteuid ; inline
  84
  85 : effective-user-name ( -- string )
  86     effective-user-id user-name ; inline
  87
  88 : user-exists? ( name/id -- ? ) user-id >boolean ;
  89
  90 GENERIC: set-real-user ( string/id -- )
  91
  92 GENERIC: set-effective-user ( string/id -- )
  93
  94 : (with-real-user) ( string/id quot -- )
  95     '[ _ set-real-user @ ]
  96     real-user-id '[ _ set-real-user ]
  97     [ ] cleanup ; inline
  98
  99 : with-real-user ( string/id/f quot -- )
 100     over [ (with-real-user) ] [ nip call ] if ; inline
 101
 102 : (with-effective-user) ( string/id quot -- )
 103     '[ _ set-effective-user @ ]
 104     effective-user-id '[ _ set-effective-user ]
 105     [ ] cleanup ; inline
 106
 107 : with-effective-user ( string/id/f quot -- )
 108     over [ (with-effective-user) ] [ nip call ] if ; inline
 109
 110 <PRIVATE
 111
 112 : (set-real-user) ( id -- )
 113     [ unix.ffi:setuid ] unix-system-call drop ; inline
 114
 115 : (set-effective-user) ( id -- )
 116     [ unix.ffi:seteuid ] unix-system-call drop ; inline
 117
 118 PRIVATE>
 119
 120 M: integer set-real-user ( id -- )
 121     (set-real-user) ;
 122
 123 M: string set-real-user ( string -- )
 124     ?user-id (set-real-user) ;
 125
 126 M: integer set-effective-user ( id -- )
 127     (set-effective-user) ;
 128
 129 M: string set-effective-user ( string -- )
 130     ?user-id (set-effective-user) ;
 131
 132 ERROR: no-such-user obj ;
 133
 134 : user-home ( name/uid -- path )
 135     dup user-passwd [ nip dir>> ] [ no-such-user ] if* ;
 136
 137 os macosx? [ "unix.users.macosx" require ] when