Added interface to the fs command from AFS

scsh/afs/afs-fs.scm

@@ -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))

scsh/afs/interfaces.scm

@@ -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!))

scsh/afs/packages.scm

@@ -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))