| 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 -------------------------------------------------- |