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