zone, serv: Add support for SRV records.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index c830a11f3309d9f239724a084b2d1ba30712711c..2e108bab4dcc00ddb145c7c088b92580089170ee 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*
@@ -379,46 +381,6 @@ (defun zone-cidr-delg-default-name (ipn bytes)
                      until (zerop (logand mask (ash #xff (* 8 i))))
                      collect (logand #xff (ash net (* -8 i))))))))
 
-(defun zone-cidr-delegation (data name ttl list)
-  "Given :cidr-delegation info DATA, for a record called NAME and the current
-   TTL, write lots of CNAME records to LIST."
-  (destructuring-bind
-      (net &key bytes)
-      (listify (car data))
-    (setf net (zone-parse-net net name))
-    (unless bytes
-      (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
-    (dolist (map (cdr data))
-      (destructuring-bind
-         (tnet &optional tdom)
-         (listify map)
-       (setf tnet (zone-parse-net tnet name))
-       (unless (ipnet-subnetp net tnet)
-         (error "~A is not a subnet of ~A."
-                (ipnet-pretty tnet)
-                (ipnet-pretty net)))
-       (unless tdom
-         (setf tdom
-               (join-strings #\.
-                             (list (zone-cidr-delg-default-name tnet bytes)
-                                   name))))
-       (setf tdom (string-downcase tdom))
-       (dotimes (i (ipnet-hosts tnet))
-         (let* ((addr (ipnet-host tnet i))
-                (tail (join-strings #\.
-                                    (loop
-                                       for i from 0 below bytes
-                                       collect
-                                         (logand #xff
-                                                 (ash addr (* 8 i)))))))
-           (collect (make-zone-record
-                     :name (join-strings #\.
-                                         (list tail name))
-                     :type :cname
-                     :ttl ttl
-                     :data (join-strings #\. (list tail tdom)))
-                    list)))))))
-
 ;;;--------------------------------------------------------------------------
 ;;; Serial numbering.
 
@@ -538,6 +500,7 @@        (defun ,func (,prefix ,zname ,data ,ttl ,col)
                                   ((:data ,tdata) ,data)
                                   ((:ttl ,tttl) ,ttl)
                                   ((:make-ptr-p ,tmakeptrp) nil))
+                       #+cmu (declare (optimize ext:inhibit-warnings))
                        (collect (make-zone-record :name ,tname
                                                   :type ,ttype
                                                   :data ,tdata
@@ -651,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))
@@ -849,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 --------------------------------------------------