zone, serv: Add support for SRV records.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 0e579dc95bbfc87608cec558689ed20109aba51d..2e108bab4dcc00ddb145c7c088b92580089170ee 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -27,7 +27,9 @@
 ;;; Packaging.
 
 (defpackage #:zone
 ;;; 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*
   (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
           #:*default-zone-source* #:*default-zone-refresh*
             #:*default-zone-retry* #:*default-zone-expire*


@@ -35,9 +37,12 @@ (defpackage #:zone
             #:*default-mx-priority* #:*default-zone-admin*
           #:*zone-output-path*
           #:*preferred-subnets* #:zone-preferred-subnet-p
             #:*default-mx-priority* #:*default-zone-admin*
           #:*zone-output-path*
           #:*preferred-subnets* #:zone-preferred-subnet-p

+          #:preferred-subnet-case

           #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
           #:defrevzone #:zone-save #:zone-make-name
           #:defzoneparse #:zone-parse-host
           #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
           #:defrevzone #:zone-save #:zone-make-name
           #:defzoneparse #:zone-parse-host

+          #:bind-hostname #:bind-record #:bind-format-record
+          #:bind-record-type #:bind-record-format-args

           #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)
           #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)


@@ -230,6 +235,26 @@ (defun zone-preferred-subnet-p (name)
   "Answer whether NAME (a string or symbol) names a preferred subnet."
   (member name *preferred-subnets* :test #'string-equal))
 
   "Answer whether NAME (a string or symbol) names a preferred subnet."
   (member name *preferred-subnets* :test #'string-equal))
 

+(defmacro preferred-subnet-case (&body clauses)
+  "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
+   SUBNETS (a list or single symbol, not evaluated) are considered preferred
+   by zone-preferred-subnet-p.  If SUBNETS is the symbol t then the clause
+   always matches."
+  `(cond
+    ,@(mapcar (lambda (clause)
+               (let ((subnets (car clause)))
+                 (cons (cond ((eq subnets t)
+                              t)
+                             ((listp subnets)
+                              `(or ,@(mapcar (lambda (subnet)
+                                               `(zone-preferred-subnet-p
+                                                 ',subnet))
+                                             subnets)))
+                             (t
+                              `(zone-preferred-subnet-p ',subnets)))
+                       (cdr clause))))
+             clauses)))
+

 (defun zone-process-records (rec ttl func)
   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
    the default time-to-live for records which don't specify one."
 (defun zone-process-records (rec ttl func)
   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
    the default time-to-live for records which don't specify one."


@@ -356,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))))))))
 
                      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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Serial numbering.
 


@@ -515,6 +500,7 @@        (defun ,func (,prefix ,zname ,data ,ttl ,col)
                                   ((:data ,tdata) ,data)
                                   ((:ttl ,tttl) ,ttl)
                                   ((:make-ptr-p ,tmakeptrp) nil))
                                   ((: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
                        (collect (make-zone-record :name ,tname
                                                   :type ,ttype
                                                   :data ,tdata


@@ -628,6 +614,31 @@ (defzoneparse :alias (name data rec :zname zname)
         :type :cname
         :data name)))
 
         :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))
 (defzoneparse :net (name data rec)
   ":net (NETWORK*)"
   (dolist (net (listify data))


@@ -717,34 +728,53 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec)
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 

-(defun zone-write (zone &optional (stream *standard-output*))
-  "Write a ZONE's records to STREAM."
-  (labels ((fix-admin (a)
-            (let ((at (position #\@ a))
-                  (s (concatenate 'string (string-downcase a) ".")))
-              (when s
-                (setf (char s at) #\.))
-              s))
-          (fix-host (h)
-            (if (not h)
-                "@"
-                (let* ((h (string-downcase (stringify h)))
-                       (hl (length h))
-                       (r (string-downcase (zone-name zone)))
-                       (rl (length r)))
-                  (cond ((string= r h) "@")
-                        ((and (> hl rl)
-                              (char= (char h (- hl rl 1)) #\.)
-                              (string= h r :start1 (- hl rl)))
-                         (subseq h 0 (- hl rl 1)))
-                        (t (concatenate 'string h "."))))))
-          (printrec (zr)
-            (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
-                    (fix-host (zr-name zr))
-                    (and (/= (zr-ttl zr) (zone-default-ttl zone))
-                         (zr-ttl zr))
-                    (string-upcase (symbol-name (zr-type zr))))))
-    (format stream "~
+(defgeneric zone-write (format zone stream)
+  (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
+
+(defvar *writing-zone* nil
+  "The zone currently being written.")
+
+(defvar *zone-output-stream* nil
+  "Stream to write zone data on.")
+
+(defmethod zone-write :around (format zone stream)
+  (let ((*writing-zone* zone)
+       (*zone-output-stream* stream))
+    (call-next-method)))
+
+(defun zone-save (zones &key (format :bind))
+  "Write the named ZONES to files.  If no zones are given, write all the
+   zones."
+  (unless zones
+    (setf zones (hash-table-keys *zones*)))
+  (safely (safe)
+    (dolist (z zones)
+      (let ((zz (zone-find z)))
+       (unless zz
+         (error "Unknown zone `~A'." z))
+       (let ((stream (safely-open-output-stream safe
+                                                (zone-file-name z :zone))))
+         (zone-write format zz stream))))))
+
+;;;--------------------------------------------------------------------------
+;;; Bind format output.
+
+(defun bind-hostname (hostname)
+  (if (not hostname)
+      "@"
+      (let* ((h (string-downcase (stringify hostname)))
+            (hl (length h))
+            (r (string-downcase (zone-name *writing-zone*)))
+            (rl (length r)))
+       (cond ((string= r h) "@")
+             ((and (> hl rl)
+                   (char= (char h (- hl rl 1)) #\.)
+                   (string= h r :start1 (- hl rl)))
+              (subseq h 0 (- hl rl 1)))
+             (t (concatenate 'string h "."))))))
+
+(defmethod zone-write ((format (eql :bind)) zone stream)
+  (format stream "~

 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 
 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 


@@ -753,7 +783,13 @@ (defun zone-write (zone &optional (stream *standard-output*))
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))

-    (let ((soa (zone-soa zone)))
+  (let* ((soa (zone-soa zone))
+        (admin (let* ((name (soa-admin soa))
+                      (at (position #\@ name))
+                      (copy (format nil "~(~A~)." name)))
+                 (when at
+                   (setf (char copy at) #\.))
+                 copy)))

       (format stream "~
 ~A~30TIN SOA~40T~A ~A (
 ~45T~10D~60T ;serial
       (format stream "~
 ~A~30TIN SOA~40T~A ~A (
 ~45T~10D~60T ;serial


@@ -761,42 +797,49 @@ (defun zone-write (zone &optional (stream *standard-output*))
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"

-             (fix-host (zone-name zone))
-             (fix-host (soa-source soa))
-             (fix-admin (soa-admin soa))
+             (bind-hostname (zone-name zone))
+             (bind-hostname (soa-source soa))
+             admin

              (soa-serial soa)
              (soa-refresh soa)
              (soa-retry soa)
              (soa-expire soa)
              (soa-min-ttl soa)))
              (soa-serial soa)
              (soa-refresh soa)
              (soa-retry soa)
              (soa-expire soa)
              (soa-min-ttl soa)))

-    (dolist (zr (zone-records zone))
-      (ecase (zr-type zr)
-       (:a
-        (printrec zr)
-        (format stream "~A~%" (ipaddr-string (zr-data zr))))
-       ((:ptr :cname :ns)
-        (printrec zr)
-        (format stream "~A~%" (fix-host (zr-data zr))))
-       (:mx
-        (printrec zr)
-        (let ((mx (zr-data zr)))
-          (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
-       (:txt
-        (printrec zr)
-        (format stream "~S~%" (stringify (zr-data zr))))))))
-
-(defun zone-save (zones)
-  "Write the named ZONES to files.  If no zones are given, write all the
-   zones."
-  (unless zones
-    (setf zones (hash-table-keys *zones*)))
-  (safely (safe)
-    (dolist (z zones)
-      (let ((zz (zone-find z)))
-       (unless zz
-         (error "Unknown zone `~A'." z))
-       (let ((stream (safely-open-output-stream safe
-                                                (zone-file-name z :zone))))
-         (zone-write zz stream))))))
+  (dolist (zr (zone-records zone))
+    (bind-record (zr-type zr) zr)))
+
+(defgeneric bind-record (type zr))
+
+(defun bind-format-record (name ttl type format args)
+  (format *zone-output-stream*
+         "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
+         (bind-hostname name)
+         (and (/= ttl (zone-default-ttl *writing-zone*))
+              ttl)
+         (string-upcase (symbol-name type))
+         format args))
+
+(defmethod bind-record (type zr)
+  (destructuring-bind (format &rest args)
+      (bind-record-format-args type (zr-data zr))
+    (bind-format-record (zr-name zr)
+                       (zr-ttl zr)
+                       (bind-record-type type)
+                       format args)))
+
+(defgeneric bind-record-type (type)
+  (:method (type) type))
+
+(defgeneric bind-record-format-args (type data)
+  (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
+  (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :cname)) data) (list "~A" (bind-hostname 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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------