;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              Finger                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *finger-port* 79)

(define (finger who)
  (let ((who (regexp-match "^([^@]+)@([^@]+)$" who)))
    (and who
         (let-values (((i o)
                       (with-handlers ((void (lambda (_)
                                               (values #f #f))))
                         (tcp-connect (caddr who) *finger-port*))))
           (if (and i o)
             (begin
               (fprintf o "~a~%" (cadr who))
               (let loop ((line (read-line i)))
                 (if (eof-object? line)
                   '()
                   (cons line (loop (read-line i))))))
             'no-connection)))))

(define (cornell-finger netid)
  (define cornell-lines
    '("Information from Cornell's Network Identity Directory..."
      "--------------------------------------------------------"
      ""
      "Your query returned   1 match  :"
      ""))
  (define (match-lines lines to-match)
    (cond ((null? to-match) lines)
          ((null? lines) #f)
          ((equal? (car lines) (car to-match))
           (match-lines (cdr lines) (cdr to-match)))
          (else #f)))
  (define (matchings lines to-match)
    (if (or (null? lines) (null? to-match))
      '()
      (let* ((rest (matchings (cdr lines) (cdr to-match)))
             (strings (if (list? (car to-match))
                        (car to-match)
                        (list (car to-match))))
             (symbols (map (lambda (m)
                             (string->symbol
                              (list->string
                               (map char-downcase
                                    (string->list
                                     (regexp-replace* " " m "-"))))))
                           strings))
             (regexp (string-append
                      "^ *"
                      (apply string-append
                             (map (lambda (s)
                                    (format "~a: *(.*[^ ])? *" s))
                                  strings))
                      "$"))
             (match (regexp-match regexp (car lines))))
        (append (if match (map list symbols (cdr match))
                    '())
                rest))))
  (and (regexp-match "^[a-z][a-z]+[0-9]+$" netid)
       (let ((lines (finger (string-append netid "@cornell.edu"))))
         (if (or (not lines) (eq? lines 'no-connection))
           '()
           (let ((lines (match-lines lines cornell-lines)))
             (and lines
                  (matchings lines
                             '(("Name" "Nickname") "Send Email To"
                               "Campus Phone" "Campus Address"
                               "Local Phone" "Local Address"
                               "Project"))))))))