zone.lisp: Export `tinydns-output', because it looks handy.

[zone] / serv.lisp

;;; -*-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))

(in-package #:services)

(export '(serv servp serv-name serv-aliases serv-port serv-proto))
(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.
  (export 'serv-by-name)
  (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))))))))

  (export 'serv-by-port)
  (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.
  (export 'serv-list)
  (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 --------------------------------------------------