zone, serv: Add support for SRV records.

diff --git a/serv.lisp b/serv.lisp
new file mode 100644 (file)
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 (file)
--- a/zone.asd
+++ b/zone.asd
@@ -6,6 +6,7 @@
   :author "Mark Wooding <mdw@distorted.org.uk>"
   :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 (file)
--- 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 @@
         :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 @@ $TTL ~2@*~D~2%"
   (: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 --------------------------------------------------