;;; -*- Mode: Scheme; scheme48-package: network-database -*-

;;; This code is written by Brian Templeton and placed in the Public
;;; Domain. All warranties are disclaimed.

(define (make-file-parser file line-parser)
  (lambda ()
    (call-with-input-file file
      (lambda (port)
        (let loop ((objects '()))
          (let* ((line (read-line port))
                 (object (and line (line-parser line))))
            (cond
             ((and line object) (loop (cons object objects)))
             (line (loop objects))
             (else objects))))))))

(define (make-file-reloader file thunk)
  (let ((lock (make-lock))
        (previous-lm #f))
    (lambda ()
      (dynamic-wind
        (lambda () (obtain-lock lock))
        (lambda ()
          (let ((current-lm (file-info-last-modification
                             (get-file-info file))))
            (if (or (not previous-lm)
                    (time>? current-lm previous-lm))
                (begin
                  (thunk)
                  (set! previous-lm current-lm)))))
        (lambda () (release-lock lock))))))

(define (read-line port)
  (let ((char1 (read-char port)))
    (cond
     ((eof-object? char1) #f)
     ((char=? char1 #\newline) "")
     (else
      (let loop ((chars (list char1)))
        (let ((char (read-char port)))
          (cond
           ((or (eof-object? char) (char=? char #\newline))
            (reverse-list->string chars))
           (else
            (loop (cons char chars))))))))))

(define (read-lines port)
  (let loop ((lines '()))
    (let ((line (read-line port)))
      (if line
          (loop (cons line lines))
          lines))))

(define (strip-comment str)
  (let ((pos (string-index str #\#)))
    (if pos (substring str 0 pos) str)))

(define (string-split str . delimiters)
  (let ((len (string-length str)))
    (let loop ((start 0) (end 0))
      (cond
       ((= end len) (list (substring str start end)))
       ((any (lambda (x) x)
             (map (lambda (d) (char=? (string-ref str end) d))
                  delimiters))
        (if (= start end)
            (loop (+ end 1) (+ end 1))
            (cons (substring str start end)
                  (loop (+ end 1) (+ end 1)))))
       (else (loop start (+ end 1)))))))

(define (split-line str)
  (string-split (string-trim-both (strip-comment str))
                (ascii->char 32) (ascii->char 9) ; space and tab, resp.
                ))

;;; SERVICE-INFO

(define-record-type service-info :service-info
  (make-service-info name aliases port protocol)
  service-info?
  (name service-info:name)
  (aliases service-info:aliases)
  (port service-info:port)
  (protocol service-info:protocol))

(define-record-discloser :service-info
  (lambda (si)
    `(service-info ,(service-info:name si) ,(service-info:aliases si)
                   ,(service-info:port si) ,(service-info:protocol si))))

(define *services* '())

(define (parse-service-line line)
  (let ((fields (split-line line)))
    (if (< (length fields) 2)
        #f
        (destructure (((name port+proto . aliases) fields))
          (destructure (((portstring . proto)
                         (string-split port+proto #\/)))
            (let ((port (string->number portstring))
                  (proto (if (null? proto) #f (car proto))))
              (make-service-info name aliases port proto)))))))

(define parse-services-file
  (make-file-parser "/etc/services" parse-service-line))

(define maybe-reload-services-file
  (make-file-reloader "/etc/services"
                      (lambda ()
                        (set! *services* (parse-services-file)))))

(define (service-info name-or-port . opt)
  (let ((proto (if (null? opt) #f (car opt))))
    (if (or (number? name-or-port) (string? name-or-port))
        (let* ((match-name-or-port?
                (cond
                 ((number? name-or-port)
                  (lambda (si)
                    (= (service-info:port si) name-or-port)))
                 ((string? name-or-port)
                  (lambda (si)
                    (string=? (service-info:name si) name-or-port)))))
               (match-proto?
                (if (not proto)
                    (lambda (si)
                      #t)
                    (lambda (si)
                      (string=? (service-info:protocol si) proto))))
               (match?
                (lambda (si)
                  (and (match-name-or-port? si) (match-proto? si)))))
          (maybe-reload-services-file)
          (find match? *services*))
        (call-error "invalid argument" name-or-port))))

;;; PROTOCOL-INFO

(define-record-type protocol-info :protocol-info
  (make-protocol-info name aliases number)
  protocol-info?
  (name protocol-info:name)
  (aliases protocol-info:aliases)
  (number protocol-info:number))

(define-record-discloser :protocol-info
  (lambda (pi)
    `(protocol-info ,(protocol-info:name pi)
                    ,(protocol-info:aliases pi)
                    ,(protocol-info:number pi))))

(define *protocols* '())

(define (parse-protocol-line line)
  (let ((fields (split-line line)))
    (if (< (length fields) 2)
        #f
        (destructure (((name numberstring . aliases) fields))
          (let ((number (string->number numberstring)))
            (make-protocol-info name aliases number))))))

(define parse-protocols-file
  (make-file-parser "/etc/protocols" parse-protocol-line))

(define maybe-reload-protocols-file
  (make-file-reloader "/etc/protocols"
                      (lambda ()
                        (set! *protocols* (parse-protocols-file)))))

(define (protocol-info name-or-number)
  (if (or (number? name-or-number) (string? name-or-number))
      (let ((match?
             (cond
              ((number? name-or-number)
               (lambda (pi)
                 (= (protocol-info:number pi) name-or-number)))
              ((string? name-or-number)
               (lambda (pi)
                 (string=? (protocol-info:name pi) name-or-number))))))
        (maybe-reload-protocols-file)
        (find match? *protocols*))
      (call-error "invalid argument" name-or-number)))