166 lines
4.7 KiB
Scheme
166 lines
4.7 KiB
Scheme
;; 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 (result-buffer-num-cols 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)))))
|