1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; protocols.lisp --- Protocol lookup.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
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
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.
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
24 (in-package :net.sockets
)
26 (defvar *protocols-file
* "/etc/protocols")
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."))
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
)))
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
))))
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
)))))
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
)))))))
66 (defun lookup-protocol-on-disk-by-number (file protocol
)
67 (flet ((good-proto-p (name value aliases
)
68 (declare (ignore name aliases
))
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
)))))))
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."))
81 (defvar *protocols-cache-by-name
* (make-hash-table :test
#'equal
))
82 (defvar *protocols-cache-by-number
* (make-hash-table :test
#'eql
))
84 (defun find-protocol (thing cache-fn disk-fn
)
85 (or (funcall cache-fn thing
)
86 (let ((protocol (funcall disk-fn
*protocols-file
* thing
)))
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
)
94 (defun lookup-protocol-by-name (proto)
96 #'(lambda (p) (gethash p
*protocols-cache-by-name
*))
97 #'lookup-protocol-on-disk-by-name
))
99 (defun lookup-protocol-by-number (proto)
101 #'(lambda (p) (gethash p
*protocols-cache-by-number
*))
102 #'lookup-protocol-on-disk-by-number
))
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
*)))
109 (defvar *protocols-monitor
*
110 (make-instance 'file-monitor
111 :file
*protocols-file
*
112 :update-fn
'purge-protocols-cache
))
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
))))