+;;; -*-lisp-*-
+;;;
+;;; Database of network service numbers
+;;;
+;;; (c) 2006 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:services
+ (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:net #:anaphora)
+ (:export #:serv #:servp #:serv-name #:serv-aliases #:serv-port #:serv-proto
+ #:serv-by-name #:serv-by-port #:serv-add #:serv-list))
+
+(in-package #:services)
+
+(defstruct (serv (:predicate servp))
+ "Represents a service entry in /etc/services."
+ (name :nil :type keyword)
+ (aliases () :type list)
+ (port 0 :type (integer 0 65535))
+ (proto :tcp :type keyword))
+
+(let ((byname (make-hash-table))
+ (byport (make-hash-table)))
+
+ ;; Translation functions.
+ (defun serv-by-name (name &optional proto)
+ "Look up the service with the given NAME (or alias) and PROTO. If PROTO
+ is nil, use a default protocol from a built-in list."
+ (let ((match (gethash name byname)))
+ (flet ((find-proto (proto)
+ (find proto match :key #'serv-proto)))
+ (cond ((null match) nil)
+ (proto (find-proto proto))
+ ((null (cdr match)) (car match))
+ (t (dolist (proto '(:tcp :udp :icmp) (car match))
+ (awhen (find-proto proto)
+ (return it))))))))
+
+ (defun serv-by-port (port &optional (proto :tcp))
+ "Look up the service with the given PORT number and PROTO."
+ (find proto (gethash port byport) :key #'serv-proto))
+
+ (defun serv-add (serv)
+ "Add a service to the global tables."
+ (push serv (gethash (serv-name serv) byname))
+ (push serv (gethash (serv-port serv) byport))
+ (dolist (alias (serv-aliases serv))
+ (push serv (gethash alias byname))))
+
+ ;; Read the whole damned lot.
+ (defun serv-list (&key (predicate (constantly t)))
+ "Return as a list the services which match PREDICATE (default all of
+ them)."
+ (let ((seen (make-hash-table :test #'eq)))
+ (collecting ()
+ (with-hash-table-iterator (next byport)
+ (loop
+ (multiple-value-bind (goodp port servs) (next)
+ (declare (ignore port))
+ (unless goodp
+ (return))
+ (unless (gethash servs seen)
+ (setf (gethash servs seen) t)
+ (dolist (serv servs)
+ (when (funcall predicate serv)
+ (collect serv))))))))))
+
+ ;; Insert ICMP entries. This is a slight abuse of the `port' slot, but I
+ ;; think we'll live. The names are taken straight from RFC792.
+ ;; (Actually the service class makes exactly the same abuse, so I think
+ ;; we're vindicated here.)
+ (dolist (item '((0 :echo-reply :ping-reply)
+ (3 :destination-unreachable)
+ (4 :source-quench)
+ (5 :redirect)
+ (8 :echo :echo-request :ping)
+ (11 :time-exceeded)
+ (12 :parameter-problem)
+ (13 :timestamp :timestamp-request)
+ (14 :timestamp-reply)
+ (15 :information-request)
+ (16 :information-reply)))
+ (destructuring-bind (type name . aliases) item
+ (serv-add (make-serv :name name
+ :aliases aliases
+ :port type
+ :proto :icmp))))
+
+ ;; Read the /etc/services file.
+ (with-open-file (in "/etc/services")
+ (loop
+ (let ((line (read-line in nil)))
+ (unless line (return))
+ (block insert
+ (flet ((bail () (return-from insert))
+ (to-keyword (name) (intern (string-upcase name) :keyword)))
+ (let* ((end (or (position #\# line) (length line)))
+ (words (or (str-split-words line :end end) (bail)))
+ (name (to-keyword (or (car words) (bail))))
+ (pp (or (cadr words) (bail)))
+ (aliases (mapcar #'to-keyword (cddr words)))
+ (slash (or (position #\/ pp) (bail)))
+ (port (or (parse-integer pp
+ :start 0
+ :end slash
+ :junk-allowed t)
+ (bail)))
+ (proto (to-keyword (subseq pp (1+ slash)))))
+ (serv-add (make-serv :name name
+ :aliases aliases
+ :port port
+ :proto proto)))))))))
+
+;;;----- That's all, folks --------------------------------------------------