3 ;;; Database of network service numbers
5 ;;; (c) 2006 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
24 (defpackage #:services
25 (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:net #:anaphora)
26 (:export #:serv #:servp #:serv-name #:serv-aliases #:serv-port #:serv-proto
27 #:serv-by-name #:serv-by-port #:serv-add #:serv-list))
29 (in-package #:services)
31 (defstruct (serv (:predicate servp))
32 "Represents a service entry in /etc/services."
33 (name :nil :type keyword)
34 (aliases () :type list)
35 (port 0 :type (integer 0 65535))
36 (proto :tcp :type keyword))
38 (let ((byname (make-hash-table))
39 (byport (make-hash-table)))
41 ;; Translation functions.
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)
55 (defun serv-by-port (port &optional (proto :tcp))
56 "Look up the service with the given PORT number and PROTO."
57 (find proto (gethash port byport) :key #'serv-proto))
59 (defun serv-add (serv)
60 "Add a service to the global tables."
61 (push serv (gethash (serv-name serv) byname))
62 (push serv (gethash (serv-port serv) byport))
63 (dolist (alias (serv-aliases serv))
64 (push serv (gethash alias byname))))
66 ;; Read the whole damned lot.
67 (defun serv-list (&key (predicate (constantly t)))
68 "Return as a list the services which match PREDICATE (default all of
70 (let ((seen (make-hash-table :test #'eq)))
72 (with-hash-table-iterator (next byport)
74 (multiple-value-bind (goodp port servs) (next)
75 (declare (ignore port))
78 (unless (gethash servs seen)
79 (setf (gethash servs seen) t)
81 (when (funcall predicate serv)
82 (collect serv))))))))))
84 ;; Insert ICMP entries. This is a slight abuse of the `port' slot, but I
85 ;; think we'll live. The names are taken straight from RFC792.
86 ;; (Actually the service class makes exactly the same abuse, so I think
87 ;; we're vindicated here.)
88 (dolist (item '((0 :echo-reply :ping-reply)
89 (3 :destination-unreachable)
92 (8 :echo :echo-request :ping)
94 (12 :parameter-problem)
95 (13 :timestamp :timestamp-request)
97 (15 :information-request)
98 (16 :information-reply)))
99 (destructuring-bind (type name . aliases) item
100 (serv-add (make-serv :name name
105 ;; Read the /etc/services file.
106 (with-open-file (in "/etc/services")
108 (let ((line (read-line in nil)))
109 (unless line (return))
111 (flet ((bail () (return-from insert))
112 (to-keyword (name) (intern (string-upcase name) :keyword)))
113 (let* ((end (or (position #\# line) (length line)))
114 (words (or (str-split-words line :end end) (bail)))
115 (name (to-keyword (or (car words) (bail))))
116 (pp (or (cadr words) (bail)))
117 (aliases (mapcar #'to-keyword (cddr words)))
118 (slash (or (position #\/ pp) (bail)))
119 (port (or (parse-integer pp
124 (proto (to-keyword (subseq pp (1+ slash)))))
125 (serv-add (make-serv :name name
128 :proto proto)))))))))
130 ;;;----- That's all, folks --------------------------------------------------