Added interface to the fs command from AFS

This commit is contained in:
Martin Gasbichler 2003-01-28 13:49:49 +00:00
parent 55ad3044ef
commit 6268cc4f49
3 changed files with 116 additions and 0 deletions

101
scsh/afs/afs-fs.scm Normal file
View File

@ -0,0 +1,101 @@
;;; This file is part of the Scheme Untergrund Library.
;;; Copyright (c) 2002-2003 by Martin Gasbichler.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define-enumerated-type afs-permission :afs-permission
afs-permission?
the-afs-permissions
afs-permission-name
afs-permission-index
(read
list
insert
delete
write
lock
administer))
(define-enum-set-type afs-permissions :afs-permissions
afs-permissions?
make-afs-permissions
afs-permission afs-permission? the-afs-permissions afs-permission-index)
(define (char->afs-permission c)
(case c
((#\r) (afs-permission read))
((#\l) (afs-permission list))
((#\i) (afs-permission insert))
((#\d) (afs-permission delete))
((#\w) (afs-permission write))
((#\k) (afs-permission lock))
((#\a) (afs-permission administer))
(else (error "wrong char in char->afs-permission" c))))
(define (afs-permission->char afs-perm)
(cond ((eq? afs-perm (afs-permission read)) #\r)
((eq? afs-perm (afs-permission list)) #\l)
((eq? afs-perm (afs-permission insert)) #\i)
((eq? afs-perm (afs-permission delete)) #\d)
((eq? afs-perm (afs-permission write)) #\w)
((eq? afs-perm (afs-permission lock)) #\k)
((eq? afs-perm (afs-permission administer)) #\a)
(else (error "unknown permission" afs-perm))))
(define (string->afs-permissions s)
(string-fold (lambda (e accu)
(enum-set-union accu (make-afs-permissions (list (char->afs-permission e)))))
(make-afs-permissions '())
s))
(define (afs-permissions->string afs-perms)
(fold (lambda (perm s)
(if (enum-set-member? afs-perms perm)
(string-append s (string (afs-permission->char perm)))
s))
""
(vector->list the-afs-permissions)))
(define all-afs-permissions
(make-afs-permissions (map char->afs-permission (string->list "rlidwka"))))
;; access control lists: lists of pairs of user name and
;; afs-permissions
(define (get-acl dir)
(let* ((output (run/strings (,fs la ,dir))))
(map (lambda (s)
(apply (lambda (user al)
(cons user (string->afs-permissions al)))
((field-splitter) s)))
(cddr output)))) ; TODO add sanity check
(define (acl-users acl)
(map car acl))
(define (acl->strings acl)
(apply append
(map (lambda (user.afs-perms)
(list (car user.afs-perms)
(afs-permissions->string (cdr user.afs-perms))))
acl)))
(define (arla-set-access-control-list-for-user! dir user afs-perms)
(run (,fs sa ,dir ,user ,(afs-permissions->string afs-perms))))
(define (arla-set-access-control-list! dir acl)
(for-each (lambda (user.afs-perms)
(arla-set-access-control-list-for-user! dir (car user.afs-perms) (cdr user.afs-perms)))
acl))
(define (set-acl! dir acl)
(run (,fs setacl ,dir -acl ,@(acl->strings acl) -clear)))
(define (add-acl! dir acl)
(run (,fs setacl ,dir -acl ,@(acl->strings acl))))
(define fs "fs")
(define (set-fs-command! the-fs)
(set! fs the-fs))

8
scsh/afs/interfaces.scm Normal file
View File

@ -0,0 +1,8 @@
(define-interface afs-fs-interface
(export
((afs-permission afs-permissions) :syntax)
all-afs-permissions
get-acl
set-acl!
add-acl!
set-fs-command!))

7
scsh/afs/packages.scm Normal file
View File

@ -0,0 +1,7 @@
(define-structure afs-fs afs-fs-interface
(open scheme-with-scsh
enum-sets
finite-types
srfi-1
srfi-13)
(files afs-fs))