sockets/namedb/protocols.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; protocols.lisp --- Protocol lookup.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 (defvar *protocols-file* "/etc/protocols")
  27
  28 (defclass protocol ()
  29   ((name :initarg :name :reader protocol-name
  30          :documentation "The protocol's primary name.")
  31    (aliases :initarg :aliases :reader protocol-aliases
  32             :documentation "A list of aliases for this protocol.")
  33    (number :initarg :number :reader protocol-number
  34            :documentation "The protocol number."))
  35   (:documentation "Class representing a protocol."))
  36
  37 (defun make-protocol (name number &optional aliases)
  38   "Constructor for PROTOCOL objects."
  39   (let ((number (cond ((numberp number) number)
  40                       ((string  number) (parse-integer number)))))
  41     (make-instance 'protocol :name name :number number :aliases aliases)))
  42
  43 (defmethod print-object ((protocol protocol) stream)
  44   (print-unreadable-object (protocol stream :type t :identity nil)
  45     (with-slots (name aliases number) protocol
  46       (format stream "Name: ~S Number: ~A Aliases: ~:[None~;~:*~{~S~^, ~}~]"
  47               name number aliases))))
  48
  49 (defun find-protocol-in-parsed-lines (tokens predicate)
  50   (when (< (length tokens) 2) (error 'parse-error))
  51   (destructuring-bind (name value &rest aliases) tokens
  52     (let ((value (parse-integer value)))
  53       (when (funcall predicate name value aliases)
  54         (make-protocol name value aliases)))))
  55
  56 (defun lookup-protocol-on-disk-by-name (file protocol)
  57   (flet ((good-proto-p (name value aliases)
  58            (declare (ignore value))
  59            (or (string= protocol name)
  60                (member protocol aliases :test #'string=))))
  61     (iterate ((tokens (serialize-etc-file file)))
  62       (ignore-some-conditions (parse-error)
  63         (let ((proto (find-protocol-in-parsed-lines tokens #'good-proto-p)))
  64           (when proto (return-from lookup-protocol-on-disk-by-name proto)))))))
  65
  66 (defun lookup-protocol-on-disk-by-number (file protocol)
  67   (flet ((good-proto-p (name value aliases)
  68            (declare (ignore name aliases))
  69            (= protocol value)))
  70     (iterate ((tokens (serialize-etc-file file)))
  71       (ignore-some-conditions (parse-error)
  72         (let ((proto (find-protocol-in-parsed-lines tokens #'good-proto-p)))
  73           (when proto (return-from lookup-protocol-on-disk-by-number proto)))))))
  74
  75 (define-condition unknown-protocol ()
  76   ((name :initarg :name :initform nil :reader unknown-protocol-name))
  77   (:report (lambda (condition stream)
  78              (format stream "Unknown protocol: ~S" (unknown-protocol-name condition))))
  79   (:documentation "Condition raised when a network protocol is not found."))
  80
  81 (defvar *protocols-cache-by-name*   (make-hash-table :test #'equal))
  82 (defvar *protocols-cache-by-number* (make-hash-table :test #'eql))
  83
  84 (defun find-protocol (thing cache-fn disk-fn)
  85   (or (funcall cache-fn thing)
  86       (let ((protocol (funcall disk-fn *protocols-file* thing)))
  87         (when protocol
  88           (setf (gethash (protocol-name protocol) *protocols-cache-by-name*) protocol)
  89           (dolist (alias (protocol-aliases protocol))
  90             (setf (gethash alias *protocols-cache-by-name*) protocol))
  91           (setf (gethash (protocol-number protocol) *protocols-cache-by-number*) protocol)
  92           (values protocol)))))
  93
  94 (defun lookup-protocol-by-name (proto)
  95   (find-protocol proto
  96                  #'(lambda (p) (gethash p *protocols-cache-by-name*))
  97                  #'lookup-protocol-on-disk-by-name))
  98
  99 (defun lookup-protocol-by-number (proto)
 100   (find-protocol proto
 101                  #'(lambda (p) (gethash p *protocols-cache-by-number*))
 102                  #'lookup-protocol-on-disk-by-number))
 103
 104 (defun purge-protocols-cache (&optional file)
 105   (declare (ignore file))
 106   (map 'nil #'clrhash (list *protocols-cache-by-name*
 107                             *protocols-cache-by-number*)))
 108
 109 (defvar *protocols-monitor*
 110   (make-instance 'file-monitor
 111                  :file *protocols-file*
 112                  :update-fn 'purge-protocols-cache))
 113
 114 (defun lookup-protocol (protocol)
 115   "Lookup a protocol by name or number.  Signals an
 116 UNKNOWN-PROTOCOL error if no protocol is found."
 117   (when (keywordp protocol)
 118     (setf protocol (string-downcase protocol)))
 119   (let ((parsed-number (parse-number-or-nil protocol)))
 120     (when parsed-number (setf protocol parsed-number)))
 121   (update-monitor *protocols-monitor*)
 122   (let ((proto (etypecase protocol
 123                  (unsigned-byte (lookup-protocol-by-number protocol))
 124                  (string        (lookup-protocol-by-name protocol)))))
 125     (if proto (values (protocol-number proto)
 126                       (protocol-name proto)
 127                       (protocol-aliases proto))
 128         (error 'unknown-protocol :name protocol))))