basis/unix/users/users.factor

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