chiark / gitweb /
zone.lisp: Support for SSHFP records.
[zone] / serv.lisp
1 ;;; -*-lisp-*-
2 ;;;
3 ;;; Database of network service numbers
4 ;;;
5 ;;; (c) 2006 Straylight/Edgeware
6 ;;;
7
8 ;;;----- Licensing notice ---------------------------------------------------
9 ;;;
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 2 of the License, or
13 ;;; (at your option) any later version.
14 ;;;
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software Foundation,
22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23
24 (defpackage #:services
25   (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:net #:anaphora))
26
27 (in-package #:services)
28
29 (export '(serv servp serv-name serv-aliases serv-port serv-proto))
30 (defstruct (serv (:predicate servp))
31   "Represents a service entry in /etc/services."
32   (name :nil :type keyword)
33   (aliases () :type list)
34   (port 0 :type (integer 0 65535))
35   (proto :tcp :type keyword))
36
37 (let ((byname (make-hash-table))
38       (byport (make-hash-table)))
39
40   ;; Translation functions.
41   (export 'serv-by-name)
42   (defun serv-by-name (name &optional proto)
43     "Look up the service with the given NAME (or alias) and PROTO.  If PROTO
44      is nil, use a default protocol from a built-in list."
45     (let ((match (gethash name byname)))
46       (flet ((find-proto (proto)
47                (find proto match :key #'serv-proto)))
48         (cond ((null match) nil)
49               (proto (find-proto proto))
50               ((null (cdr match)) (car match))
51               (t (dolist (proto '(:tcp :udp :icmp) (car match))
52                    (awhen (find-proto proto)
53                      (return it))))))))
54
55   (export 'serv-by-port)
56   (defun serv-by-port (port &optional (proto :tcp))
57     "Look up the service with the given PORT number and PROTO."
58     (find proto (gethash port byport) :key #'serv-proto))
59
60   (defun serv-add (serv)
61     "Add a service to the global tables."
62     (push serv (gethash (serv-name serv) byname))
63     (push serv (gethash (serv-port serv) byport))
64     (dolist (alias (serv-aliases serv))
65       (push serv (gethash alias byname))))
66
67   ;; Read the whole damned lot.
68   (export 'serv-list)
69   (defun serv-list (&key (predicate (constantly t)))
70     "Return as a list the services which match PREDICATE (default all of
71      them)."
72     (let ((seen (make-hash-table :test #'eq)))
73       (collecting ()
74         (with-hash-table-iterator (next byport)
75           (loop
76             (multiple-value-bind (goodp port servs) (next)
77               (declare (ignore port))
78               (unless goodp
79                 (return))
80               (unless (gethash servs seen)
81                 (setf (gethash servs seen) t)
82                 (dolist (serv servs)
83                   (when (funcall predicate serv)
84                     (collect serv))))))))))
85
86   ;; Insert ICMP entries.  This is a slight abuse of the `port' slot, but I
87   ;; think we'll live.  The names are taken straight from RFC792.
88   ;; (Actually the service class makes exactly the same abuse, so I think
89   ;; we're vindicated here.)
90   (dolist (item '((0 :echo-reply :ping-reply)
91                   (3 :destination-unreachable)
92                   (4 :source-quench)
93                   (5 :redirect)
94                   (8 :echo :echo-request :ping)
95                   (11 :time-exceeded)
96                   (12 :parameter-problem)
97                   (13 :timestamp :timestamp-request)
98                   (14 :timestamp-reply)
99                   (15 :information-request)
100                   (16 :information-reply)))
101     (destructuring-bind (type name . aliases) item
102       (serv-add (make-serv :name name
103                            :aliases aliases
104                            :port type
105                            :proto :icmp))))
106
107   ;; Read the /etc/services file.
108   (with-open-file (in "/etc/services")
109     (loop
110       (let ((line (read-line in nil)))
111         (unless line (return))
112         (block insert
113           (flet ((bail () (return-from insert))
114                  (to-keyword (name) (intern (string-upcase name) :keyword)))
115             (let* ((end (or (position #\# line) (length line)))
116                    (words (or (str-split-words line :end end) (bail)))
117                    (name (to-keyword (or (car words) (bail))))
118                    (pp (or (cadr words) (bail)))
119                    (aliases (mapcar #'to-keyword (cddr words)))
120                    (slash (or (position #\/ pp) (bail)))
121                    (port (or (parse-integer pp
122                                             :start 0
123                                             :end slash
124                                             :junk-allowed t)
125                              (bail)))
126                    (proto (to-keyword (subseq pp (1+ slash)))))
127               (serv-add (make-serv :name name
128                                    :aliases aliases
129                                    :port port
130                                    :proto proto)))))))))
131
132 ;;;----- That's all, folks --------------------------------------------------