chiark / gitweb /
zone.lisp: Fix `:sshfp' handling of literals.
[zone] / serv.lisp
CommitLineData
716105aa
MW
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
a1428e57 25 (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:net #:anaphora))
716105aa
MW
26
27(in-package #:services)
28
a1428e57 29(export '(serv servp serv-name serv-aliases serv-port serv-proto))
716105aa
MW
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.
a1428e57 41 (export 'serv-by-name)
716105aa
MW
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
a1428e57 55 (export 'serv-by-port)
716105aa
MW
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.
a1428e57 68 (export 'serv-list)
716105aa
MW
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 --------------------------------------------------