Commit | Line | Data |
---|---|---|
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 -------------------------------------------------- |