net.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-parse-errors
  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-parse-errors
  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 (defvar *protocols-cache-lock* (bt:make-lock "/etc/protocols cache lock"))
  84
  85 (defun find-protocol (thing cache-fn disk-fn)
  86   (or (funcall cache-fn thing)
  87       (let ((protocol (funcall disk-fn *protocols-file* thing)))
  88         (when protocol
  89           (setf (gethash (protocol-name protocol) *protocols-cache-by-name*) protocol)
  90           (dolist (alias (protocol-aliases protocol))
  91             (setf (gethash alias *protocols-cache-by-name*) protocol))
  92           (setf (gethash (protocol-number protocol) *protocols-cache-by-number*) protocol)
  93           (values protocol)))))
  94
  95 (defun lookup-protocol-by-name (proto)
  96   (bt:with-lock-held (*protocols-cache-lock*)
  97     (find-protocol proto
  98                    #'(lambda (p) (gethash p *protocols-cache-by-name*))
  99                    #'lookup-protocol-on-disk-by-name)))
 100
 101 (defun lookup-protocol-by-number (proto)
 102   (bt:with-lock-held (*protocols-cache-lock*)
 103     (find-protocol proto
 104                    #'(lambda (p) (gethash p *protocols-cache-by-number*))
 105                    #'lookup-protocol-on-disk-by-number)))
 106
 107 (defun purge-protocols-cache (&optional file)
 108   (declare (ignore file))
 109   (map 'nil #'clrhash (list *protocols-cache-by-name*
 110                             *protocols-cache-by-number*)))
 111
 112 (defvar *protocols-monitor*
 113   (make-instance 'file-monitor
 114                  :file *protocols-file*
 115                  :update-fn 'purge-protocols-cache
 116                  :lock *protocols-cache-lock*))
 117
 118 (defun lookup-protocol (protocol)
 119   "Lookup a protocol by name or number.  Signals an
 120 UNKNOWN-PROTOCOL error if no protocol is found."
 121   (check-type protocol (or unsigned-byte string symbol) "non-negative integer, a string or a symbol")
 122   (update-monitor *protocols-monitor*)
 123   (let ((protocol (ensure-string-or-unsigned-byte protocol))
 124         (proto (etypecase protocol
 125                  (unsigned-byte (lookup-protocol-by-number protocol))
 126                  (string        (lookup-protocol-by-name protocol)))))
 127     (if proto (values (protocol-number proto)
 128                       (protocol-name proto)
 129                       (protocol-aliases proto))
 130         (error 'unknown-protocol :name protocol))))