chiark - git - mdw - zone/blob - 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 --------------------------------------------------