commander-s/scheme/afs.scm

;; We are assuming that the vos and fs commands follow the OpenAFS
;; syntax.

(define *afs-volumes-cs* (make-empty-completion-set))

(define (read-volume-names)
  (port-fold
   (run/port ("vos" "listvldb"))
   read-line
   (lambda (line s)
     (if-match
      (regexp-search
       (rx (submatch (: bos (+ alphanumeric) (* (| punctuation alphanumeric)))))
       line)
      (whole match)
      (cons match s)
      s))
   '()))

(spawn
 (lambda ()
   (set! *afs-volumes-cs* (make-completion-set (read-volume-names)))))

(define fs-command-cs
  (make-completion-set
   '("apropos" "checkservers" "checkvolumes" "cleanacl"
     "copyacl" "diskfree" "examine" "exportafs"
     "flush" "flushmount" "flushvolume"
     "getcacheparms" "getcellstatus"
     "getclientaddrs" "getcrypt" "getserverprefs"
     "help" "listacl" "listaliases" "listcells"
     "listquota" "lsmount" "messages" "mkmount"
     "newalias" "newcell" "quota" "rmmount"
     "rxstatpeer" "rxstatproc" "setacl"
     "setcachesize" "setcell" "setclientaddrs"
     "setcrypt" "setquota" "setserverprefs"
     "setvol" "storebehind" "sysname"
     "whereis" "whichcell" "wscell")))

(define vos-command-cs
  (make-completion-set
   '("addsite" "apropos" "backup" "backupsys"
     "changeaddr" "changeloc" "create" "delentry"
     "dump" "examine" "help" "listaddrs" "listpart"
     "listvldb" "listvol" "lock" "move" "partinfo"
     "release" "remove" "remsite" "rename" "restore"
     "setfields" "status" "syncserv" "syncvldb"
     "unlock" "unlockvldb" "zap")))

;; FIXME: Not all vos commands expect a volume argument
(define (vos-command-completer command prefix args arg-pos)
  (if (= 1 arg-pos)
      (completions-for vos-command-cs prefix)
      (completions-for *afs-volumes-cs* prefix)))

;; FIXME: Not all fs commands expect a volume argument
(define (fs-command-completer command prefix args arg-pos)
  (if (= 1 arg-pos)
      (completions-for fs-command-cs prefix)
      (completions-for *afs-volumes-cs* prefix)))

(define-record-type acl :acl
  (make-acl dir afs-perms)
  acl?
  (dir acl-dir)
  (afs-perms acl-afs-perms))

(define key-d 100)
(define delete-key key-d)

(define (make-header width dir)
  (list
   (string-append "Access list for " dir " is")))

(define (layout-afs-perm width p)
  (cut-to-size 
   width
   (string-append
    (fill-up-string 20 (car p))
    " "
    (afs-permissions->string (cdr p)))))

(define (make-afs-perms-select-list num-cols num-lines afs-perms)
  (make-select-list
   (map 
    (lambda (p)
      (make-unmarked-element p #t (layout-afs-perm num-cols p)))
    afs-perms)
   num-lines))


(define (make-acl-viewer acl buffer)
  (let* ((dir (acl-dir acl))
         (afs-perms (acl-afs-perms acl))
         (num-cols (result-buffer-num-cols buffer))
         (num-lines (result-buffer-num-lines buffer))
         (header (make-header num-cols dir))
         (select-list
          (make-afs-perms-select-list
           num-cols
           (- num-lines (length header))
           afs-perms)))

    (define (delete-selected-entry!)
      (let ((uid.afs-perms (select-list-selected-entry select-list)))
        (set! afs-perms (delete uid.afs-perms afs-perms eq?))
        (set! select-list
              (make-afs-perms-select-list num-lines
                                          (- num-lines (length header))
                                          afs-perms))
        (set-acl! dir afs-perms)))

    (lambda (message)
      (case message

       ((paint)
	(lambda (self win buffer have-focus?)
          (let ((hdr-len (length header)))
            (for-each (lambda (text y)
                        (mvwaddstr win y 0 text))
                      header
                      (iota hdr-len))
            (paint-selection-list-at 
             select-list 0 hdr-len win buffer have-focus?))))

       ((key-press)
	(lambda (self key control-x-pressed?)
          (cond
           ((= key delete-key)
            (delete-selected-entry!))
           (else
            (set! select-list
                  (select-list-handle-key-press select-list key))))
          self))

;       ((get-selection) get-selection)	

;       ((get-focus-object) get-focus-object)
       
       (else 
	(error "acl viewer unknown message" message))))))

(register-plugin!
 (make-command-plugin 
  "fs"
  fs-command-completer
  (lambda (command args)
    (cond
     ((or (string=? (car args) "la")
	  (string=? (car args) "listacl"))
      (let ((dir (if (null? (cdr args)) (cwd) (cadr args))))
	(make-acl dir (get-acl dir))))
     (else
      (display "unsupported fs command" (car args)))))))

(register-plugin!
 (make-view-plugin make-acl-viewer acl?))

(register-plugin!
 (make-command-plugin
  "vos"
  vos-command-completer
  (lambda (command args)
    (run/fg (,command ,@args)))))