src/sockets/namedb/protocols.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; protocols.lisp --- Protocol lookup.
   4 ;;;
   5
   6 (in-package :iolib.sockets)
   7
   8 (defvar *protocols-file* "/etc/protocols")
   9
  10 (defclass protocol ()
  11   ((name :initarg :name :reader protocol-name
  12          :documentation "The protocol's primary name.")
  13    (aliases :initarg :aliases :reader protocol-aliases
  14             :documentation "A list of aliases for this protocol.")
  15    (number :initarg :number :reader protocol-number
  16            :documentation "The protocol number."))
  17   (:documentation "Class representing a protocol."))
  18
  19 (defun make-protocol (name number &optional aliases)
  20   "Constructor for PROTOCOL objects."
  21   (let ((number (cond ((numberp number) number)
  22                       ((string  number) (parse-integer number)))))
  23     (make-instance 'protocol :name name :number number :aliases aliases)))
  24
  25 (defmethod print-object ((protocol protocol) stream)
  26   (print-unreadable-object (protocol stream :type t :identity nil)
  27     (with-slots (name aliases number) protocol
  28       (format stream "Name: ~S Number: ~A Aliases: ~:[None~;~:*~{~S~^, ~}~]"
  29               name number aliases))))
  30
  31 (defun find-protocol-in-parsed-lines (tokens predicate)
  32   (when (< (length tokens) 2) (error 'parse-error))
  33   (destructuring-bind (name value &rest aliases) tokens
  34     (let ((value (parse-integer value)))
  35       (when (funcall predicate name value aliases)
  36         (make-protocol name value aliases)))))
  37
  38 (defun lookup-protocol-on-disk-by-name (file protocol)
  39   (flet ((good-proto-p (name value aliases)
  40            (declare (ignore value))
  41            (or (string= protocol name)
  42                (member protocol aliases :test #'string=))))
  43     (map-etc-file (lambda (tokens)
  44                     (ignore-errors
  45                       (let ((proto (find-protocol-in-parsed-lines tokens #'good-proto-p)))
  46                         (when proto (return* proto)))))
  47                   file)))
  48
  49 (defun lookup-protocol-on-disk-by-number (file protocol)
  50   (flet ((good-proto-p (name value aliases)
  51            (declare (ignore name aliases))
  52            (= protocol value)))
  53     (map-etc-file (lambda (tokens)
  54                     (ignore-errors
  55                       (let ((proto (find-protocol-in-parsed-lines tokens #'good-proto-p)))
  56                         (when proto (return* proto)))))
  57                   file)))
  58
  59 (define-condition unknown-protocol ()
  60   ((datum :initarg :datum :initform nil :reader unknown-protocol-datum))
  61   (:report (lambda (condition stream)
  62              (format stream "Unknown protocol: ~S" (unknown-protocol-datum condition))))
  63   (:documentation "Condition raised when a network protocol is not found."))
  64 (setf (documentation 'unknown-protocol-datum 'function)
  65       "Return the datum that caused the signalling of an UNKNOWN-PROTOCOL condition.")
  66
  67 (defvar *protocol-cache-by-name*   (make-hash-table :test #'equal))
  68 (defvar *protocol-cache-by-number* (make-hash-table :test #'eql))
  69 (defvar *protocol-cache-lock* (bt:make-lock "/etc/protocols cache lock"))
  70
  71 (defun find-protocol (thing cache-fn disk-fn)
  72   (or (funcall cache-fn thing)
  73       (let ((protocol (funcall disk-fn *protocols-file* thing)))
  74         (when protocol
  75           (setf (gethash (protocol-name protocol) *protocol-cache-by-name*) protocol)
  76           (dolist (alias (protocol-aliases protocol))
  77             (setf (gethash alias *protocol-cache-by-name*) protocol))
  78           (setf (gethash (protocol-number protocol) *protocol-cache-by-number*) protocol)
  79           (values protocol)))))
  80
  81 (defun lookup-protocol-by-name (proto)
  82   (bt:with-lock-held (*protocol-cache-lock*)
  83     (find-protocol proto
  84                    (lambda (p) (gethash p *protocol-cache-by-name*))
  85                    #'lookup-protocol-on-disk-by-name)))
  86
  87 (defun lookup-protocol-by-number (proto)
  88   (bt:with-lock-held (*protocol-cache-lock*)
  89     (find-protocol proto
  90                    (lambda (p) (gethash p *protocol-cache-by-number*))
  91                    #'lookup-protocol-on-disk-by-number)))
  92
  93 (defun purge-protocol-cache (&optional file)
  94   (declare (ignore file))
  95   (clrhash *protocol-cache-by-name*)
  96   (clrhash *protocol-cache-by-number*))
  97
  98 (defvar *protocols-monitor*
  99   (make-instance 'file-monitor
 100                  :file *protocols-file*
 101                  :update-fn 'purge-protocol-cache
 102                  :lock *protocol-cache-lock*))
 103
 104 (deftype inet-protocol ()
 105   '(unsigned-byte 16))
 106
 107 (defun lookup-protocol (protocol)
 108   "Lookup a protocol by name or number.  Signals an
 109 UNKNOWN-PROTOCOL error if no protocol is found."
 110   (check-type protocol (or unsigned-byte string symbol) "non-negative integer, a string or a symbol")
 111   (update-monitor *protocols-monitor*)
 112   (let* ((parsed (ensure-string-or-unsigned-byte protocol :type 'inet-protocol :errorp t))
 113          (proto (typecase parsed
 114                   (inet-protocol (lookup-protocol-by-number parsed))
 115                   (string        (lookup-protocol-by-name parsed)))))
 116     (if proto
 117         (values (protocol-number proto)
 118                 (protocol-name proto)
 119                 (protocol-aliases proto))
 120         (error 'unknown-protocol :datum protocol))))