basis/unix/users/users.factor

   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.backend.unix kernel math sequences splitting strings
   5 combinators.short-circuit grouping byte-arrays combinators
   6 accessors math.parser fry assocs namespaces continuations
   7 vocabs.loader system classes.struct unix ;
   8 IN: unix.users
   9 QUALIFIED: unix.ffi
  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     [ unix.ffi:endpwent ] [ ] cleanup ; inline
  35
  36 PRIVATE>
  37
  38 : all-users ( -- seq )
  39     [
  40         [ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
  41     ] with-pwent ;
  42
  43 SYMBOL: user-cache
  44
  45 : <user-cache> ( -- assoc )
  46     all-users [ [ uid>> ] keep ] H{ } map>assoc ;
  47
  48 : with-user-cache ( quot -- )
  49     [ <user-cache> user-cache ] dip with-variable ; inline
  50
  51 GENERIC: user-passwd ( obj -- passwd/f )
  52
  53 M: integer user-passwd ( id -- passwd/f )
  54     user-cache get
  55     [ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
  56
  57 M: string user-passwd ( string -- passwd/f )
  58     unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
  59
  60 : user-name ( id -- string )
  61     dup user-passwd
  62     [ nip user-name>> ] [ number>string ] if* ;
  63
  64 : user-id ( string -- id/f )
  65     user-passwd dup [ uid>> ] when ;
  66
  67 : real-user-id ( -- id )
  68     unix.ffi:getuid ; inline
  69
  70 : real-user-name ( -- string )
  71     real-user-id user-name ; inline
  72
  73 : effective-user-id ( -- id )
  74     unix.ffi:geteuid ; inline
  75
  76 : effective-user-name ( -- string )
  77     effective-user-id user-name ; inline
  78
  79 GENERIC: set-real-user ( string/id -- )
  80
  81 GENERIC: set-effective-user ( string/id -- )
  82
  83 : with-real-user ( string/id quot -- )
  84     '[ _ set-real-user @ ]
  85     real-user-id '[ _ set-real-user ]
  86     [ ] cleanup ; inline
  87
  88 : with-effective-user ( string/id quot -- )
  89     '[ _ set-effective-user @ ]
  90     effective-user-id '[ _ set-effective-user ]
  91     [ ] cleanup ; inline
  92
  93 <PRIVATE
  94
  95 : (set-real-user) ( id -- )
  96     [ unix.ffi:setuid ] unix-system-call drop ; inline
  97
  98 : (set-effective-user) ( id -- )
  99     [ unix.ffi:seteuid ] unix-system-call drop ; inline
 100
 101 PRIVATE>
 102
 103 M: string set-real-user ( string -- )
 104     user-id (set-real-user) ;
 105
 106 M: integer set-real-user ( id -- )
 107     (set-real-user) ;
 108
 109 M: integer set-effective-user ( id -- )
 110     (set-effective-user) ;
 111
 112 M: string set-effective-user ( string -- )
 113     user-id (set-effective-user) ;
 114
 115 os {
 116     { [ dup bsd? ] [ drop "unix.users.bsd" require ] }
 117     { [ dup linux? ] [ drop ] }
 118 } cond