zone.lisp: Support multi-line TXT records.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 7318c2a..909f755 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -61,9 +61,10 @@
 
 (export 'timespec-seconds)
 (defun timespec-seconds (ts)
 
 (export 'timespec-seconds)
 (defun timespec-seconds (ts)

-  "Convert a timespec TS to seconds.  A timespec may be a real count of
-   seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
-   time units."
+  "Convert a timespec TS to seconds.
+
+   A timespec may be a real count of seconds, or a list (COUNT UNIT): UNIT
+   may be any of a number of obvious time units."

   (cond ((null ts) 0)
        ((realp ts) (floor ts))
        ((atom ts)
   (cond ((null ts) 0)
        ((realp ts) (floor ts))
        ((atom ts)


@@ -90,10 +91,11 @@
     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 
 (defun iso-date (&optional time &key datep timep (sep #\ ))
     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 
 (defun iso-date (&optional time &key datep timep (sep #\ ))

-  "Construct a textual date or time in ISO format.  The TIME is the universal
-   time to convert, which defaults to now; DATEP is whether to emit the date;
-   TIMEP is whether to emit the time, and SEP (default is space) is how to
-   separate the two."
+  "Construct a textual date or time in ISO format.
+
+   The TIME is the universal time to convert, which defaults to now; DATEP is
+   whether to emit the date; TIMEP is whether to emit the time, and
+   SEP (default is space) is how to separate the two."

   (multiple-value-bind
       (sec min hr day mon yr dow dstp tz)
       (decode-universal-time (if (or (null time) (eq time :now))
   (multiple-value-bind
       (sec min hr day mon yr dow dstp tz)
       (decode-universal-time (if (or (null time) (eq time :now))


@@ -228,10 +230,11 @@
 
 (export 'preferred-subnet-case)
 (defmacro preferred-subnet-case (&body clauses)
 
 (export 'preferred-subnet-case)
 (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."
+  "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)))
   `(cond
     ,@(mapcar (lambda (clause)
                (let ((subnets (car clause)))


@@ -248,8 +251,27 @@
              clauses)))
 
 (defun zone-process-records (rec ttl func)
              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."
+  "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.
+
+   The syntax is a little fiddly to describe.  It operates relative to a
+   subzone name NAME.
+
+   ZONE-RECORD: RR | TTL | SUBZONE
+       The body of a zone form is a sequence of these.
+
+   TTL: :ttl INTEGER
+       Sets the TTL for subsequent RRs in this zone or subzone.
+
+   RR: SYMBOL DATA
+       Adds a record for the current NAME; the SYMBOL denotes the record
+       type, and the DATA depends on the type.
+
+   SUBZONE: (LABELS ZONE-RECORD*)
+       Defines a subzone.  The LABELS is either a list of labels, or a
+       singleton label.  For each LABEL, evaluate the ZONE-RECORDs relative
+       to LABEL.NAME.  The special LABEL `@' is a no-op."

   (labels ((sift (rec ttl)
             (collecting (top sub)
               (loop
   (labels ((sift (rec ttl)
             (collecting (top sub)
               (loop


@@ -274,13 +296,12 @@
           (process (rec dom ttl)
             (multiple-value-bind (top sub) (sift rec ttl)
               (if (and dom (null top) sub)
           (process (rec dom ttl)
             (multiple-value-bind (top sub) (sift rec ttl)
               (if (and dom (null top) sub)

-                  (let ((preferred nil))
-                    (dolist (s sub)
-                      (when (some #'zone-preferred-subnet-p
-                                  (listify (zs-name s)))
-                        (setf preferred s)))
-                    (unless preferred
-                      (setf preferred (car sub)))
+                  (let ((preferred
+                         (or (find-if (lambda (s)
+                                        (some #'zone-preferred-subnet-p
+                                              (listify (zs-name s))))
+                                      sub)
+                             (car sub))))

                     (when preferred
                       (process (zs-records preferred)
                                dom
                     (when preferred
                       (process (zs-records preferred)
                                dom


@@ -379,8 +400,10 @@
 
 (export 'make-zone-serial)
 (defun make-zone-serial (name)
 
 (export 'make-zone-serial)
 (defun make-zone-serial (name)

-  "Given a zone NAME, come up with a new serial number.  This will (very
-   carefully) update a file ZONE.serial in the current directory."
+  "Given a zone NAME, come up with a new serial number.
+
+   This will (very carefully) update a file ZONE.serial in the current
+   directory."

   (let* ((file (zone-file-name name :serial))
         (last (with-open-file (in file
                                   :direction :input
   (let* ((file (zone-file-name name :serial))
         (last (with-open-file (in file
                                   :direction :input


@@ -398,8 +421,8 @@
     (safely-writing (out file)
       (format out
              ";; Serial number file for zone ~A~%~
     (safely-writing (out file)
       (format out
              ";; Serial number file for zone ~A~%~

-               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
-               ~S~%"
+              ;;   (LAST-SEQ DAY MONTH YEAR)~%~
+              ~S~%"

              name
              (cons seq now)))
     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
              name
              (cons seq now)))
     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))


@@ -408,10 +431,12 @@
 ;;; Zone form parsing.
 
 (defun zone-parse-head (head)
 ;;; Zone form parsing.
 
 (defun zone-parse-head (head)

-  "Parse the HEAD of a zone form.  This has the form
+  "Parse the HEAD of a zone form.
+
+   This has the form

 
      (NAME &key :source :admin :refresh :retry
 
      (NAME &key :source :admin :refresh :retry

-                :expire :min-ttl :ttl :serial)
+               :expire :min-ttl :ttl :serial)

 
    though a singleton NAME needn't be a list.  Returns the default TTL and an
    soa structure representing the zone head."
 
    though a singleton NAME needn't be a list.  Returns the default TTL and an
    soa structure representing the zone head."


@@ -450,11 +475,12 @@
 (export 'defzoneparse)
 (defmacro defzoneparse (types (name data list
                               &key (prefix (gensym "PREFIX"))
 (export 'defzoneparse)
 (defmacro defzoneparse (types (name data list
                               &key (prefix (gensym "PREFIX"))

-                                   (zname (gensym "ZNAME"))
-                                   (ttl (gensym "TTL")))
+                                   (zname (gensym "ZNAME"))
+                                   (ttl (gensym "TTL")))

                        &body body)
                        &body body)

-  "Define a new zone record type (or TYPES -- a list of synonyms is
-   permitted).  The arguments are as follows:
+  "Define a new zone record type.
+
+   The TYPES may be a list of synonyms.  The other arguments are as follows:

 
    NAME                The name of the record to be added.
 
 
    NAME                The name of the record to be added.
 


@@ -507,6 +533,9 @@
          ',type)))))
 
 (defun zone-parse-records (zone records)
          ',type)))))
 
 (defun zone-parse-records (zone records)

+  "Parse the body of a zone form.
+
+   ZONE is the zone object; RECORDS is the body of the form."

   (let ((zname (zone-name zone)))
     (with-collection (rec)
        (flet ((parse-record (zr)
   (let ((zname (zone-name zone)))
     (with-collection (rec)
        (flet ((parse-record (zr)


@@ -527,7 +556,9 @@
 
 (export 'zone-parse)
 (defun zone-parse (zf)
 
 (export 'zone-parse)
 (defun zone-parse (zf)

-  "Parse a ZONE form.  The syntax of a zone form is as follows:
+  "Parse a ZONE form.
+
+  The syntax of a zone form is as follows:

 
    ZONE-FORM:
      ZONE-HEAD ZONE-RECORD*
 
    ZONE-FORM:
      ZONE-HEAD ZONE-RECORD*


@@ -653,7 +684,7 @@
       (rec :name (zone-parse-host "mask" name)
           :type :a
           :data (ipnet-mask n))
       (rec :name (zone-parse-host "mask" name)
           :type :a
           :data (ipnet-mask n))

-      (rec :name (zone-parse-host "broadcast" name)
+      (rec :name (zone-parse-host "bcast" name)

           :type :a
           :data (ipnet-broadcast n)))))
 
           :type :a
           :data (ipnet-broadcast n)))))
 


@@ -708,37 +739,38 @@
     (unless bytes
       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
     (dolist (map (or (cdr data) (list (list net))))
     (unless bytes
       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
     (dolist (map (or (cdr data) (list (list net))))

-      (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
-         (with-ipnet (net mask) tnet
-           (setf tdom
-                 (join-strings
-                  #\.
-                  (append (reverse (loop
-                                    for i from (1- bytes) downto 0
-                                    until (zerop (logand mask
-                                                         (ash #xff
-                                                              (* 8 i))))
-                                    collect (ldb (byte 8 (* i 8)) net)))
-                          (list name))))))
-       (setf tdom (string-downcase (stringify tdom)))
-       (dotimes (i (ipnet-hosts tnet))
-         (unless (zerop i)
-           (let* ((addr (ipnet-host tnet i))
-                  (tail (join-strings #\.
-                                      (loop
-                                       for i from 0 below bytes
-                                       collect
-                                       (logand #xff
-                                               (ash addr (* 8 i)))))))
-             (rec :name (format nil "~A.~A" tail name)
-                  :type :cname
-                  :data (format nil "~A.~A" tail tdom)))))))))
+      (destructuring-bind (tnets &optional tdom) (listify map)
+       (dolist (tnet (listify tnets))
+         (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
+           (with-ipnet (net mask) tnet
+             (setf tdom
+                   (join-strings
+                    #\.
+                    (append (reverse (loop
+                                      for i from (1- bytes) downto 0
+                                      until (zerop (logand mask
+                                                           (ash #xff
+                                                                (* 8 i))))
+                                      collect (ldb (byte 8 (* i 8)) net)))
+                            (list name))))))
+         (setf tdom (string-downcase (stringify tdom)))
+         (dotimes (i (ipnet-hosts tnet))
+           (unless (zerop i)
+             (let* ((addr (ipnet-host tnet i))
+                    (tail (join-strings #\.
+                                        (loop
+                                         for i from 0 below bytes
+                                         collect
+                                         (logand #xff
+                                                 (ash addr (* 8 i)))))))
+               (rec :name (format nil "~A.~A" tail name)
+                    :type :cname
+                    :data (format nil "~A.~A" tail tdom))))))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.


@@ -754,6 +786,7 @@
   "Stream to write zone data on.")
 
 (defmethod zone-write :around (format zone stream)
   "Stream to write zone data on.")
 
 (defmethod zone-write :around (format zone stream)

+  (declare (ignore format))

   (let ((*writing-zone* zone)
        (*zone-output-stream* stream))
     (call-next-method)))
   (let ((*writing-zone* zone)
        (*zone-output-stream* stream))
     (call-next-method)))


@@ -862,6 +895,8 @@ $TTL ~2@*~D~2%"
   (: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 :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))))
+  (:method ((type (eql :txt)) data)
+    (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
+         (mapcar #'stringify (listify data)))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------