#! %GUILE_GTK% -s
-*-scheme-*-
!#

;;
;; A AFS ACL/PTS manager
;;

;;
;; $Id: afsaclmgr.in,v 1.3 1999/10/23 17:49:56 lha Exp $
;;

(use-modules (gtk gtk))
(use-modules (ice-9 popen))

;;
;;
;;

(define name-window #f)

(define (acl-new-name path main-window)
  (if name-window
      (gtk-widget-destroy name-window))
  (set! name-window (gtk-window-new 'dialog))
  (let ((main-panel (gtk-vbox-new #f 3))
	(text-box (gtk-entry-new-with-max-length 40))
	(ok-button (gtk-button-new-with-label "Ok"))
	(cancel-button (gtk-button-new-with-label "Cancel")))
    (define (name-close-window)
      (gtk-widget-destroy name-window)
      (set! name-window #f))

    (gtk-window-set-title name-window "New Name")
    (gtk-container-add name-window main-panel)

    (gtk-signal-connect cancel-button
			"clicked"
			name-close-window)

    (gtk-signal-connect ok-button
			"clicked"
			(lambda ()
			  (let ((user (gtk-entry-get-text text-box)))
			    (name-close-window)
			    (display path) (newline)
			    (display user) (newline)
			    (acl-magic-window path user "rl" main-window))))

    (gtk-box-pack-start main-panel text-box #t #t 0)
    (gtk-box-pack-start main-panel ok-button #f #f 0)
    (gtk-box-pack-end main-panel cancel-button #f #f 0)
    
    (gtk-widget-show-all name-window)))

;; 
;;
;;

(define acl-titles  #("Name" "R" "L" "I" "D" "W" "K" "A"))

(define acl-window #f)

(define (acl-magic-window path user rights main-window)
  (if acl-window
      (gtk-widget-destroy acl-window))
  (set! acl-window (gtk-window-new 'dialog))
  (let ((main-panel (gtk-vbox-new #f 3))
	(button-panel (gtk-hbox-new #f 2))
	(status-bar (gtk-statusbar-new))
	(acl-foo (gtk-clist-new-with-titles acl-titles))
	(ok-button (gtk-button-new-with-label "Ok"))
	(cancel-button (gtk-button-new-with-label "Cancel")))
    (define (clicked-func row col event)
      (let ((user '(#f))
	    (ace '(#f)))
	(gtk-clist-get-text acl-foo row 0 user)
	(gtk-clist-get-text acl-foo row col ace)
	(cond ((eq? col 0) '())
	      ((string=? (car ace) "X") (set! ace (list " ")))
	      ((string=? (car ace) " ") (set! ace (list "X")))
	      (else (die-in-horror)))
	(gtk-clist-set-text acl-foo row col (car ace))))
    (define (map-acl-to-X user clist acl)
      (gtk-clist-append 
       acl-foo
       (cons user
	     (map 
	      (lambda (x)
		(if (member x (string->list acl))
		    "X"
		    " "))
	      (string->list "rlidwka")))))
    (define (acl-close-window)
      (gtk-widget-destroy acl-window)
      (set! acl-window #f))

    (gtk-window-set-title acl-window "ACL")
    (gtk-container-add acl-window main-panel)

    (for-each
     (lambda (col size)
       (gtk-clist-set-column-width acl-foo col size))
     '(0 1 2 3 4 5 6 7)
     '(200 10 10 10 10 10 10 10))


    (map-acl-to-X user acl-foo rights)

    (gtk-signal-connect 
     acl-foo
     "unselect-row"
     clicked-func)

    (gtk-signal-connect acl-foo "select-row" clicked-func)
       
    (gtk-box-pack-start button-panel ok-button #t #t 0)
    (gtk-box-pack-end button-panel cancel-button #t #t 0)

    (gtk-signal-connect 
     ok-button "clicked"
     (lambda ()
       (define (get-text col text)
	 (let ((dummy '(#f)))
	   (gtk-clist-get-text acl-foo 0 col dummy)
	   (if (and (car dummy)
		     (string=? (car dummy) "X"))
	       text
		"")))
       (begin
	 (acl-set 
	  path
	  user
	  (let ((ace (apply string
			    (map get-text 
				 '(1 2 3 4 5 6 7)
				 '("r" "l" "i" "d" "w" "k" "a")))))
	    (if (string=? ace "")
		"none"
		ace))))
       (acl-update-clist path main-window)
       (acl-close-window)))

    (gtk-signal-connect cancel-button
			"clicked"
			acl-close-window)


    (gtk-box-pack-start main-panel acl-foo #t #t 0)
    (gtk-box-pack-start main-panel button-panel #t #t 0)
    (gtk-box-pack-end main-panel status-bar #f #f 0)

    (gtk-widget-show-all acl-window)))


(define acl-error-rx (make-regexp "^fs: Invalid argument; it is possible"))
(define acl-split-rx (make-regexp "^ +([^ ]+) +([rlidwka]+)"))

;;
;; Get acl for given path.
;;
;; If path not in afs, #f is returned
;;

(define (read-to-char port ch)
  (let ((next (read-char port)))
    (cond ((eof-object? next) next)
	  ((equal? next ch) "")
	  (else (string next (read-to-char port ch))))))

(define (acl-list path)
  (define (parse-output pipe)
    (let ((first (read-to-char pipe #\newline)))
      (if (or (eof-object? first)
	      (regexp-exec acl-error-rx first))
	  #f
	  (let ((second (read-to-char pipe #\newline)))
	    (if (not (eof-object? first))
		(let foo ((str (read-to-char pipe #\newline)))
		  (if (eof-object? str)
		      '()
		      (let* ((acl (regexp-exec acl-split-rx str))
			     (arg1 (vector-ref acl 2))
			     (arg2 (vector-ref acl 3))
			     (bar1 (substring str (car arg1) (cdr arg1)))
			     (bar2 (substring str (car arg2) (cdr arg2))))
			(cons (list bar1 bar2)
			      (foo (read-to-char pipe #\newline)))))))))))
  (let* ((pipe (open-input-pipe 
		(string "/usr/afsws/bin/fs la " path " 2>&1")))
	 (ret (parse-output pipe)))
    (close-port pipe)
    ret))

;;
;; Set `acl´ for `name´ on `path´.
;;

(define (acl-set path name acl)
  (define (parse-output pipe)
    (let ((first (read-to-char pipe #\newline)))
      (not (or (eof-object? first)
	       (regexp-exec acl-error-rx first)))))
  (let* ((pipe (open-input-pipe 
		(string "/usr/afsws/bin/fs sa " path " " 
			name " " acl " 2>&1")))
	 (ret (parse-output pipe)))
    (close-port pipe)
    ret))
  
;;
;; Update the `clist' for to reflect `path'
;;

(define (acl-update-clist path clist)
  (let ((acl (acl-list path)))
    (if acl
	(begin
	  (gtk-clist-clear clist)
	  (for-each 
	   (lambda (x)
	     (gtk-clist-append 
	      clist
	      (vector (car x) (cadr x))))
	   acl)))))

;;
;; Main
;;

(define user-selected #f)
(define acl-selected #f)

(define main-titles #("user" "acl"))

(let ((window (gtk-window-new 'toplevel))
      (main-panel (gtk-vbox-new #f 2))
      (button-panel (gtk-hbox-new #f 5))
      (scrolled-window (gtk-scrolled-window-new))
      (clist (gtk-clist-new-with-titles main-titles))
      (add-button (gtk-button-new-with-label "Add"))
      (modify-button (gtk-button-new-with-label "Modify"))
      (refresh-button (gtk-button-new-with-label "Refresh"))
      (delete-button (gtk-button-new-with-label "Delete"))
      (quit-button (gtk-button-new-with-label "Quit")))

  (define (reset-selection)
    (set! user-selected #f)
    (set! acl-selected #f))
    

  (gtk-window-set-title window "AFS ACLManager")

  (gtk-widget-set-usize clist 400 200)
  (gtk-clist-set-column-width clist 0 200)

  (acl-update-clist "." clist)

  (gtk-container-add window main-panel)

  (gtk-box-pack-start main-panel scrolled-window #t #t 0)
  (gtk-box-pack-end main-panel button-panel #f #f 0)

  (gtk-box-pack-start button-panel add-button #t #t 0)
  (gtk-box-pack-start button-panel modify-button #t #t 0)
  (gtk-box-pack-start button-panel refresh-button #t #t 0)
  (gtk-box-pack-start button-panel delete-button #t #t 0)
  (gtk-box-pack-end   button-panel quit-button #t #t 0)

  (gtk-container-add scrolled-window clist)

  (gtk-signal-connect delete-button "clicked"
		      (lambda ()
			(if user-selected
			    (begin
			      (acl-set "." user-selected "none")
			      (reset-selection)
			      (acl-update-clist "." clist)))))
  
  (gtk-signal-connect refresh-button "clicked"
		      (lambda ()
			(acl-update-clist "." clist)))

  (gtk-signal-connect clist "select-row"
		      (lambda (row col event)
			(let ((dummy '(#f)))
			  (gtk-clist-get-text clist row 0 dummy)
			  (set! user-selected (car dummy))
			  (gtk-clist-get-text clist row 1 dummy)
			  (set! acl-selected (car dummy)))))

  (gtk-signal-connect add-button "clicked"
		      (lambda ()
			(acl-new-name "." clist)))

  (gtk-signal-connect modify-button "clicked"
		      (lambda ()
			(if user-selected
			    (begin
			      (acl-magic-window 
			       "." user-selected acl-selected
			       clist)
			      (reset-selection)
			      (acl-update-clist "." clist)))))

  (gtk-signal-connect quit-button "clicked"
		      (lambda () 
			(gtk-widget-destroy window)
			(quit)))
     
  (gtk-widget-show-all window)
  (gtk-standalone-main window))

(quit)
