commander-s/scheme/user-group-info.scm

(define key-return 10)

(define-record-type id-output :id-output
  (make-id-output uid name gid group groups)
  id-output?
  (uid id-output-uid)
  (name id-output-name)
  (gid id-output-gid)
  (group id-output-group)
  (groups id-output-groups))

(define id-regexp
  (rx
   (: "uid=" (submatch (+ digit))
      "(" (submatch (+ alphabetic))
      ") gid=" (submatch (+ digit))
      "(" (submatch (+ alphabetic))
      ") groups=" (submatch (* any)))))                        
                                  
(define (parse-group-list s)
  (let ((gid-or-gid/name 
         (rx (| (submatch (+ digit))
                (: (submatch (+ digit))
                   "("
                   (submatch (+ alphabetic))
                   ")")))))
    (regexp-fold 
     gid-or-gid/name
     (lambda (start match l)
       (cond ((match:substring match 1)
              => (lambda (gid)
                   (cons gid l)))
             (else
              (cons (cons (match:substring match 2)
                          (match:substring match 3))
                    l))))
     '() s)))

(define (id command args)
  ;; TODO parse command line arguments
  (let* ((maybe-username (if (null? args)
                             '()
                             args))
         (out (run/string (id ,@ maybe-username)))
         (match (regexp-search id-regexp out)))
    (if match
        (make-id-output
         (match:substring match 1)
         (match:substring match 2)
         (match:substring match 3)
         (match:substring match 4)
         (parse-group-list (match:substring match 5)))
        'cannot-parse)))

(register-plugin!
 (make-command-plugin
  "id"
  #f
  id))

(define (make-id-output-select-list ido num-lines)
  (make-select-list
   `(,(make-unmarked-element 
       (cons 'user 
             (string->number
              (id-output-uid ido)))
       #t
       (string-append "UID: " (id-output-uid ido)))
     ,(make-unmarked-element 
       (cons 'user (id-output-name ido))
       #t
       (string-append "Name: " (id-output-name ido)))
     ,(make-unmarked-element 
       (cons 'group 
             (string->number
              (id-output-gid ido)))
       #t
       (string-append "GID: " (id-output-gid ido)))
     ,(make-unmarked-element 
       (cons 'group 
             (id-output-group ido))
       #t
       (string-append "GID: " (id-output-group ido)))
     ,(make-unmarked-element 
       'text
       #f
       "Groups:")
     ,@(map (lambda (group)
              (let ((gid (if (pair? group)
                             (car group)
                             group))
                    (gname (if (pair? group)
                               (cdr group)
                               "")))
                (make-unmarked-element 
                 (cons 'group (string->number gid))
                 #t
                 (string-append "  " gid " " gname))))
            (id-output-groups ido)))
   num-lines))

(define (make-id-output-browser ido buffer)
  (let ((ido ido)
        (buffer buffer)
        (selection-list
         (make-id-output-select-list 
          ido
          (result-buffer-num-lines buffer))))
    (lambda (message)
      (case message
        ((paint)
         (lambda (self . args)
           (apply paint-selection-list
                  selection-list args)))
        ((key-press)
         (lambda (self key control-x-pressed?)
           (cond
            ((= key key-return)
             (let ((selected 
                    (select-list-selected-entry selection-list)))
               (cond
                ((and (pair? selected)
                      (eq? (car selected) 'user))
                 (make-user-info-browser 
                  (user-info (cdr selected)) buffer))
                ((and (pair? selected)
                      (eq? (car selected) 'group))
                 (make-group-info-browser 
                  (group-info (cdr selected)) buffer))
                (else self))))
            (else
             (set! selection-list
                   (select-list-handle-key-press
                    selection-list key))
             self))))
        (else
         (error "unknown message in make-id-output-browser" 
                message))))))

(register-plugin!
 (make-view-plugin make-id-output-browser id-output?))

(define (make-gi-select-list gi num-lines)
  (make-select-list
   `(,(make-unmarked-element 'name
                             #t
                             (string-append "Name: " (group-info:name gi)))
     ,(make-unmarked-element 'gid
                             #t
                             (string-append "GID: " (number->string (group-info:gid gi))))
     ,(make-unmarked-element 'text
                             #f
                             "Members:")
     ,@(map (lambda (user)
              (make-unmarked-element (cons 'member user)
                                     #t
                                     (string-append "   " user)))
            (group-info:members gi)))
   num-lines))

(define (make-ui-select-list ui num-lines)
  (make-select-list
   (list (make-unmarked-element (user-info:name ui)
                                #t
                                (string-append "Name: " (user-info:name ui)))
         (make-unmarked-element 'uid
                                #t
                                (string-append "UID: " 
                                               (number->string (user-info:uid ui))))
         (make-unmarked-element 'gid
                                #t
                                (string-append "GID: "
                                               (number->string (user-info:gid ui))))
         (make-unmarked-element 'home-dir
                                #t
                                (string-append "Home: "
                                               (user-info:home-dir ui)))
         (make-unmarked-element 'shell
                                #t
                                (string-append "Shell: "
                                               (user-info:shell ui))))
   num-lines))

(define (make-group-info-browser gi buffer)
  (let ((gi gi)
        (buffer buffer)
        (selection-list
         (make-gi-select-list gi (result-buffer-num-lines buffer))))
    (lambda (message)
      (case message
        ((paint)
         (lambda (self . args)
           (apply paint-selection-list
                  selection-list args)))
        ((key-press)
         (lambda (self key control-x-pressed?)
           (cond
            ((= key key-return)
             (let ((selected (select-list-selected-entry selection-list)))
               (cond
                ((and (pair? selected)
                      (eq? (car selected) 'member))
                 (make-user-info-browser (user-info (cdr selected)) buffer))
                (else self))))
            (else
             (set! selection-list
                   (select-list-handle-key-press
                    selection-list key))
             self))))
        (else
         (error "unknown message in make-group-info-browser" message))))))
         

(define (make-user-info-browser ui buffer)
  (let ((ui ui)
        (buffer buffer)
        (selection-list 
         (make-ui-select-list ui (result-buffer-num-lines buffer))))
    (lambda (message)
      (case message
        ((paint)
         (lambda (self . args)
           (apply paint-selection-list
                  selection-list args)))
        ((key-press)
         (lambda (self key control-x-pressed?)
           (cond
            ((= key key-return)
             (let ((selected (select-list-selected-entry selection-list)))
               (case selected
                 ((gid)
                  (make-group-info-browser (group-info (user-info:gid ui)) buffer))
                 ((home-dir)
                  (make-browser-for-dir (user-info:home-dir ui) buffer))
                 ((shell)
                  (make-fsobjects-viewer 
                   (list (file-name->fs-object (user-info:shell ui)))
                   buffer))
                 (else self))))
            (else
             (set! selection-list
                   (select-list-handle-key-press
                    selection-list key))
             self))))
        (else
         (error "unknown message in make-user-info-browser" message))))))


;; scsh fails to export user-info? and group-info?...
(define user-info-type (record-ref (user-info 0) 0))
(define (user-info? x)
  (and (record? x)
       (eq? (record-ref x 0) user-info-type)))

(define group-info-type (record-ref (group-info 0) 0))
(define (group-info? x)
  (and (record? x)
       (eq? (record-ref x 0) group-info-type)))

(register-plugin!
 (make-view-plugin make-user-info-browser user-info?))

(register-plugin!
 (make-view-plugin make-group-info-browser group-info?))