extra/io/files/acls/macosx/macosx.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types alien.data alien.destructors alien.syntax
   4 classes.struct combinators destructors io.backend io.files
   5 io.files.acls.macosx.ffi kernel libc literals locals math.order
   6 prettyprint sequences unix unix.ffi unix.groups unix.types
   7 unix.users ;
   8 QUALIFIED: io
   9 IN: io.files.acls.macosx
  10
  11 <PRIVATE
  12
  13 : unix-id>string ( byte-array id-type -- string )
  14     {
  15         { ID_TYPE_UID [ user-name "user:" prepend ] }
  16         { ID_TYPE_GID [ group-name "group:" prepend ] }
  17         ! [ uuid_string_t <struct> [ mbr_uuid_to_string io-error ] keep ]
  18     } case ;
  19
  20 : acl-error ( n -- ) -1 = [ throw-errno ] when ; inline
  21
  22 :: file-acl ( path -- acl_t/f )
  23     path
  24     normalize-path
  25     clear-errno
  26     ACL_TYPE_EXTENDED acl_get_file dup [
  27         errno ENOENT = [
  28             [ path file-exists? ] preserve-errno
  29             [ drop f ] [ throw-errno ] if
  30         ] [
  31             throw-errno
  32         ] if
  33     ] unless ;
  34
  35 : free-acl ( acl -- ) acl_free acl-error ;
  36
  37 DESTRUCTOR: free-acl
  38
  39 : get-acl-entry ( acl_t n -- acl_entry_t )
  40     f acl_entry_t <ref> [ acl_get_entry ] keep swap -1 = [ drop f ] when ;
  41
  42 : first-acl-entry ( acl_t -- acl_entry_t ) ACL_FIRST_ENTRY get-acl-entry ;
  43 : next-acl-entry ( acl_t -- acl_entry_t ) ACL_NEXT_ENTRY get-acl-entry ;
  44 : last-acl-entry ( acl_t -- acl_entry_t ) ACL_LAST_ENTRY get-acl-entry ;
  45
  46 PRIVATE>
  47
  48 : acl>text ( acl_t -- string ) f acl_to_text ;
  49
  50 :: acl-entry-each ( path quot -- )
  51     [
  52         path file-acl &free-acl :> acl
  53         f :> acl-entry!
  54         acl [
  55             acl first-acl-entry void* deref quot call
  56             [ acl next-acl-entry dup acl-entry! ]
  57             [ acl-entry void* deref quot call ] while
  58         ] when
  59     ] with-destructors ; inline
  60
  61 :: acl-each ( path quot -- )
  62     [
  63         path file-acl &free-acl :> acl
  64         acl [
  65             acl first-acl-entry drop
  66             acl quot call
  67             [ acl next-acl-entry ] [ acl quot call ] while
  68         ] when
  69     ] with-destructors ; inline
  70
  71 : acl-entry-map ( path quot -- seq )
  72     collector [ acl-entry-each ] dip ; inline
  73
  74 : acl-map ( path quot -- seq )
  75     collector [ acl-each ] dip ; inline
  76
  77 ERROR: acl-init-failed n ;
  78
  79 :: n>new-acl ( n -- acl )
  80     n acl_init dup [ n acl-init-failed ] unless ;
  81
  82 : new-acl ( -- acl ) 1 n>new-acl ; inline
  83
  84 : acl-valid? ( acl -- ? ) acl_valid [ acl-error ] keep 0 = ;
  85
  86 ERROR: add-permission-failed permission-set permission ;
  87
  88 : add-permission ( acl_permset permission -- )
  89     acl_add_perm acl-error ;
  90
  91 : acl-entry>permset ( acl_entry_t -- acl_permset )
  92     f acl_permset_t <ref> [ acl_get_permset acl-error ] keep ;
  93
  94 : filter-strings ( obj strings -- string )
  95    [ [ 1 = ] dip f ? ] 2map sift "," join ;
  96
  97 : permset>strings ( acl_permset -- strings )
  98     acl-perms [ acl_get_perm_np dup acl-error ] with map
  99     acl-perm-names filter-strings ;
 100
 101 : acl-entry>perm-strings ( acl_entry_t -- strings )
 102     acl-entry>permset permset>strings ;
 103
 104 : with-new-acl ( quot -- )
 105    [ [ new-acl &free-acl ] dip call ] with-destructors ; inline
 106
 107 : acls. ( path -- )
 108     [ acl>text io:write ] acl-each ;
 109
 110 : acl-entry>owner-name ( acl-entry -- string )
 111     [
 112         acl_get_qualifier dup acl-error &free-acl
 113         0 uid_t <ref> -1 int <ref> [ mbr_uuid_to_id io-error ] 2keep
 114         [ uint deref ] bi@ unix-id>string
 115     ] with-destructors ;
 116
 117 : acl-entry>tag-name ( acl-entry -- string )
 118     f acl_tag_t <ref> [ acl_get_tag_type acl-error ] keep
 119     uint deref acl_tag_t>string ;
 120
 121 : flagset>strings ( flagset -- strings )
 122     acl-flags [ acl_get_flag_np dup acl-error ] with map
 123     acl-flag-names filter-strings ;
 124
 125 : acl-entry>flagset ( acl-entry -- flagset )
 126     f acl_flagset_t <ref> [ acl_get_flagset_np acl-error ] keep ;
 127
 128 : acl-entry>flag-names ( acl-entry -- strings )
 129     acl-entry>flagset flagset>strings ;
 130
 131
 132 ! Acl, acl entry, principal, group,
 133 ! acl_get_qualifier, acl_get_tag_type, acl_get_flagset_np,
 134 ! acl_get_permset
 135
 136 ! http://www.google.com/codesearch/p?hl=en#pFm0LxzAWvs/darwinsource/tarballs/apsl/file_cmds-116.10.tar.gz%7CFam4LGNxuqg/file_cmds-116.10/ls/print.c&q=acl_get_permset&d=6