From 716105aa3a725242d5fac82bab8db82e0bb46995 Mon Sep 17 00:00:00 2001 Message-Id: <716105aa3a725242d5fac82bab8db82e0bb46995.1714094220.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sun, 16 Mar 2008 14:28:48 +0000 Subject: [PATCH] zone, serv: Add support for SRV records. Organization: Straylight/Edgeware From: Mark Wooding --- serv.lisp | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ zone.asd | 1 + zone.lisp | 32 +++++++++++++- 3 files changed, 162 insertions(+), 1 deletion(-) create mode 100644 serv.lisp diff --git a/serv.lisp b/serv.lisp new file mode 100644 index 0000000..f8827b1 --- /dev/null +++ b/serv.lisp @@ -0,0 +1,130 @@ +;;; -*-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 -------------------------------------------------- diff --git a/zone.asd b/zone.asd index 0396a19..e16cef7 100644 --- a/zone.asd +++ b/zone.asd @@ -6,6 +6,7 @@ :author "Mark Wooding " :depends-on ("mdw" #+ecl "cffi") :components ((:file "net") + (:file "serv") (:file "zone") (:file "frontend")) :serial t) diff --git a/zone.lisp b/zone.lisp index 611a6ac..2e108ba 100644 --- a/zone.lisp +++ b/zone.lisp @@ -27,7 +27,9 @@ ;;; Packaging. (defpackage #:zone - (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net) + (:use #:common-lisp + #:mdw.base #:mdw.str #:collect #:safely + #:net #:services) (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain #:*default-zone-source* #:*default-zone-refresh* #:*default-zone-retry* #:*default-zone-expire* @@ -612,6 +614,31 @@ (defzoneparse :alias (name data rec :zname zname) :type :cname :data name))) +(defzoneparse :srv (name data rec :zname zname) + ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)" + (dolist (srv data) + (destructuring-bind (servopts &rest providers) srv + (destructuring-bind + (service &key ((:port default-port)) (protocol :tcp)) + (listify servopts) + (unless default-port + (let ((serv (serv-by-name service protocol))) + (setf default-port (and serv (serv-port serv))))) + (let ((rname (format nil "~(_~A._~A~).~A" service protocol name))) + (dolist (prov providers) + (destructuring-bind + (srvname + &key + (port default-port) + (prio *default-mx-priority*) + (weight 0) + ip) + (listify prov) + (let ((host (zone-parse-host srvname zname))) + (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (rec :name rname + :data (list prio weight port host)))))))))) + (defzoneparse :net (name data rec) ":net (NETWORK*)" (dolist (net (listify data)) @@ -810,6 +837,9 @@ (defgeneric bind-record-format-args (type data) (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data))) (:method ((type (eql :mx)) data) (list "~2D ~A" (cdr data) (bind-hostname (car data)))) + (:method ((type (eql :srv)) data) + (destructuring-bind (prio weight port host) data + (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host)))) (:method ((type (eql :txt)) data) (list "~S" (stringify data)))) ;;;----- That's all, folks -------------------------------------------------- -- [mdw]