basis/unix/groups/groups.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors alien.c-types alien.data alien.utilities assocs
   5 byte-arrays classes.struct combinators continuations grouping
   6 io.encodings.utf8 kernel math math.parser namespaces sequences
   7 strings unix unix.ffi unix.users ;
   8
   9 IN: unix.groups
  10
  11 TUPLE: group id name passwd members ;
  12
  13 SYMBOL: group-cache
  14
  15 GENERIC: group-struct ( obj -- group/f )
  16
  17 <PRIVATE
  18
  19 : group-members ( group-struct -- seq )
  20     gr_mem>> utf8 alien>strings ;
  21
  22 : (group-struct) ( id -- group-struct id group-struct byte-array length void* )
  23     [ unix.ffi:group new ] dip over 4096
  24     [ <byte-array> ] keep f void* <ref> ;
  25
  26 : check-group-struct ( group-struct ptr -- group-struct/f )
  27     void* deref [ drop f ] unless ;
  28
  29 M: integer group-struct
  30     (group-struct)
  31     [ [ unix.ffi:getgrgid_r ] unix-system-call drop ] keep
  32     check-group-struct ;
  33
  34 M: string group-struct
  35     (group-struct)
  36     [ [ unix.ffi:getgrnam_r ] unix-system-call drop ] keep
  37     check-group-struct ;
  38
  39 : group-struct>group ( group-struct -- group )
  40     [ \ group new ] dip
  41     {
  42         [ gr_name>> >>name ]
  43         [ gr_passwd>> >>passwd ]
  44         [ gr_gid>> >>id ]
  45         [ group-members >>members ]
  46     } cleave ;
  47
  48 PRIVATE>
  49
  50 : group-name ( id -- string )
  51     dup group-cache get [
  52         ?at [ name>> ] [ number>string ] if
  53     ] [
  54         group-struct [ gr_name>> ] [ f ] if*
  55     ] if*
  56     [ ] [ number>string ] ?if ;
  57
  58 : group-id ( string -- id/f )
  59     group-struct dup [ gr_gid>> ] when ;
  60
  61 ERROR: no-group string ;
  62
  63 : ?group-id ( string -- id )
  64     dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
  65
  66 <PRIVATE
  67
  68 : >groups ( byte-array n -- groups )
  69     [ 4 grouping:group ] dip head-slice [ uint deref group-name ] map ;
  70
  71 : (user-groups) ( string -- seq )
  72     dup user-passwd [
  73         gid>> 64 [ 4 * <byte-array> ] keep
  74         int <ref> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
  75         int deref >groups
  76     ] [
  77         drop { }
  78     ] if* ;
  79
  80 PRIVATE>
  81
  82 GENERIC: user-groups ( string/id -- seq )
  83
  84 M: string user-groups
  85     (user-groups) ;
  86
  87 M: integer user-groups
  88     user-name (user-groups) ;
  89
  90 : all-groups ( -- seq )
  91     [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
  92     endgrent ;
  93
  94 : all-group-names ( -- seq )
  95     all-groups [ name>> ] map ;
  96
  97 : <group-cache> ( -- assoc )
  98     all-groups [ [ id>> ] keep ] H{ } map>assoc ;
  99
 100 : with-group-cache ( quot -- )
 101     [ <group-cache> group-cache ] dip with-variable ; inline
 102
 103 : real-group-id ( -- id ) unix.ffi:getgid ; inline
 104
 105 : real-group-name ( -- string ) real-group-id group-name ; inline
 106
 107 : effective-group-id ( -- string ) unix.ffi:getegid ; inline
 108
 109 : effective-group-name ( -- string )
 110     effective-group-id group-name ; inline
 111
 112 : group-exists? ( name/id -- ? ) group-id >boolean ;
 113
 114 GENERIC: set-real-group ( obj -- )
 115
 116 GENERIC: set-effective-group ( obj -- )
 117
 118 : (with-real-group) ( string/id quot -- )
 119     '[ _ set-real-group @ ]
 120     real-group-id '[ _ set-real-group ] finally ; inline
 121
 122 : with-real-group ( string/id/f quot -- )
 123     over [ (with-real-group) ] [ nip call ] if ; inline
 124
 125 : (with-effective-group) ( string/id quot -- )
 126     '[ _ set-effective-group @ ]
 127     effective-group-id '[ _ set-effective-group ] finally ; inline
 128
 129 : with-effective-group ( string/id/f quot -- )
 130     over [ (with-effective-group) ] [ nip call ] if ; inline
 131
 132 <PRIVATE
 133
 134 : (set-real-group) ( id -- )
 135     [ unix.ffi:setgid ] unix-system-call drop ; inline
 136
 137 : (set-effective-group) ( id -- )
 138     [ unix.ffi:setegid ] unix-system-call drop ; inline
 139
 140 PRIVATE>
 141
 142 M: integer set-real-group
 143     (set-real-group) ;
 144
 145 M: string set-real-group
 146     ?group-id (set-real-group) ;
 147
 148 M: integer set-effective-group
 149     (set-effective-group) ;
 150
 151 M: string set-effective-group
 152     ?group-id (set-effective-group) ;