zone.lisp: General support for unknown record types.

There's now a `zone-record-rrdata' protocol for zone record types to
serialize themselves in the correct format, and implementations for all
of the record types currently emitted.

There's also a `zone-write-raw-rrdata' protocol for writing these out
when the format doesn't have a better plan, which is used by a (new)
default method on `zone-write-record'.

diff --git a/zone.lisp b/zone.lisp
index 32f1aed..f4f2367 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -704,16 +704,115 @@
       (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
 
 ;;;--------------------------------------------------------------------------
+;;; Building raw record vectors.
+
+(defvar *record-vector* nil
+  "The record vector under construction.")
+
+(defun rec-ensure (n)
+  "Ensure that at least N octets are spare in the current record."
+  (let ((want (+ n (fill-pointer *record-vector*)))
+       (have (array-dimension *record-vector* 0)))
+    (unless (<= want have)
+      (adjust-array *record-vector*
+                   (do ((new (* 2 have) (* 2 new)))
+                       ((<= want new) new))))))
+
+(export 'rec-byte)
+(defun rec-byte (octets value)
+  "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
+  (rec-ensure octets)
+  (do ((i (1- octets) (1- i)))
+      ((minusp i))
+    (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))
+
+(export 'rec-u8)
+(defun rec-u8 (value)
+  "Append an 8-bit VALUE to the current record."
+  (rec-byte 1 value))
+
+(export 'rec-u16)
+(defun rec-u16 (value)
+  "Append a 16-bit VALUE to the current record."
+  (rec-byte 2 value))
+
+(export 'rec-u32)
+(defun rec-u32 (value)
+  "Append a 32-bit VALUE to the current record."
+  (rec-byte 4 value))
+
+(export 'rec-raw-string)
+(defun rec-raw-string (s &key (start 0) end)
+  "Append (a (substring of) a raw string S to the current record.
+
+   No arrangement is made for reporting the length of the string.  That must
+   be done by the caller, if necessary."
+  (setf-default end (length s))
+  (rec-ensure (- end start))
+  (do ((i start (1+ i)))
+      ((>= i end))
+    (vector-push (char-code (char s i)) *record-vector*)))
+
+(export 'rec-string)
+(defun rec-string (s &key (start 0) end (max 255))
+  (let* ((end (or end (length s)))
+        (len (- end start)))
+    (unless (<= len max)
+      (error "String `~A' too long" (subseq s start end)))
+    (rec-u8 (- end start))
+    (rec-raw-string s :start start :end end)))
+
+(export 'rec-name)
+(defun rec-name (s)
+  "Append a domain name S.
+
+   No attempt is made to perform compression of the name."
+  (let ((i 0) (n (length s)))
+    (loop (let* ((dot (position #\. s :start i))
+                (lim (or dot n)))
+           (rec-string s :start i :end lim :max 63)
+           (if dot
+               (setf i (1+ dot))
+               (return))))
+    (when (< i n)
+      (rec-u8 0))))
+
+(export 'build-record)
+(defmacro build-record (&body body)
+  "Build a raw record, and return it as a vector of octets."
+  `(let ((*record-vector* (make-array 256
+                                     :element-type '(unsigned-byte 8)
+                                     :fill-pointer 0
+                                     :adjustable t)))
+     ,@body
+     (copy-seq *record-vector*)))
+
+(export 'zone-record-rrdata)
+(defgeneric zone-record-rrdata (type zr)
+  (:documentation "Emit (using the `build-record' protocol) RRDATA for ZR.
+
+   The TYPE is a keyword naming the record type.  Return the numeric RRTYPE
+   code."))
+
+;;;--------------------------------------------------------------------------
 ;;; Zone record parsers.
 
 (defzoneparse :a (name data rec)
   ":a IPADDR"
   (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
 
+(defmethod zone-record-rrdata ((type (eql :a)) zr)
+  (rec-u32 (ipaddr-addr (zr-data zr)))
+  1)
+
 (defzoneparse :aaaa (name data rec)
   ":aaaa IPADDR"
   (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
 
+(defmethod zone-record-rrdata ((type (eql :aaaa)) zr)
+  (rec-byte 16 (ipaddr-addr (zr-data zr)))
+  28)
+
 (defzoneparse :addr (name data rec)
   ":addr IPADDR"
   (zone-set-address #'rec data :make-ptr-p t))
@@ -726,14 +825,26 @@
   ":ptr HOST"
   (rec :data (zone-parse-host data zname)))
 
+(defmethod zone-record-rrdata ((type (eql :ptr)) zr)
+  (rec-name (zr-data zr))
+  12)
+
 (defzoneparse :cname (name data rec :zname zname)
   ":cname HOST"
   (rec :data (zone-parse-host data zname)))
 
+(defmethod zone-record-rrdata ((type (eql :cname)) zr)
+  (rec-name (zr-data zr))
+  5)
+
 (defzoneparse :txt (name data rec)
   ":txt (TEXT*)"
   (rec :data (listify data)))
 
+(defmethod zone-record-rrdata ((type (eql :txt)) zr)
+  (mapc #'rec-string (zr-data zr))
+  16)
+
 (export '*dkim-pathname-defaults*)
 (defvar *dkim-pathname-defaults*
   (make-pathname :directory '(:relative "keys")
@@ -826,6 +937,16 @@
                             (lookup type 'sshfp-type)
                             fpr)))))))
 
+(defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
+  (destructuring-bind (alg type fpr) (zr-data zr)
+    (rec-u8 alg)
+    (rec-u8 type)
+    (do ((i 0 (+ i 2))
+        (n (length fpr)))
+       ((>= i n))
+      (rec-u8 (parse-integer fpr :start i :end (+ i 2) :radix 16))))
+  44)
+
 (defzoneparse :mx (name data rec :zname zname)
   ":mx ((HOST :prio INT :ip IPADDR)*)"
   (dolist (mx (listify data))
@@ -836,6 +957,13 @@
        (when ip (zone-set-address #'rec ip :name host))
        (rec :data (cons host prio))))))
 
+(defmethod zone-record-rrdata ((type (eql :mx)) zr)
+  (let ((name (car (zr-data zr)))
+       (prio (cdr (zr-data zr))))
+    (rec-u16 prio)
+    (rec-name name))
+  15)
+
 (defzoneparse :ns (name data rec :zname zname)
   ":ns ((HOST :ip IPADDR)*)"
   (dolist (ns (listify data))
@@ -846,6 +974,10 @@
        (when ip (zone-set-address #'rec ip :name host))
        (rec :data host)))))
 
+(defmethod zone-record-rrdata ((type (eql :ns)) zr)
+  (rec-name (zr-data zr))
+  2)
+
 (defzoneparse :alias (name data rec :zname zname)
   ":alias (LABEL*)"
   (dolist (a (listify data))
@@ -878,6 +1010,14 @@
                (rec :name rname
                     :data (list prio weight port host))))))))))
 
+(defmethod zone-record-rrdata ((type (eql :srv)) zr)
+  (destructuring-bind (prio weight port host) (zr-data zr)
+    (rec-u16 prio)
+    (rec-u16 weight)
+    (rec-u16 port)
+    (rec-name host))
+  33)
+
 (defzoneparse :net (name data rec)
   ":net (NETWORK*)"
   (dolist (net (listify data))
@@ -982,73 +1122,6 @@
                       :make-ptr-p (zr-make-ptr-p zr)))))))))))
 
 ;;;--------------------------------------------------------------------------
-;;; Building raw record vectors.
-
-(defvar *record-vector* nil
-  "The record vector under construction.")
-
-(defun rec-ensure (n)
-  "Ensure that at least N octets are spare in the current record."
-  (let ((want (+ n (fill-pointer *record-vector*)))
-       (have (array-dimension *record-vector* 0)))
-    (unless (<= want have)
-      (adjust-array *record-vector*
-                   (do ((new (* 2 have) (* 2 new)))
-                       ((<= want new) new))))))
-
-(defun rec-byte (octets value)
-  "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
-  (rec-ensure octets)
-  (do ((i (1- octets) (1- i)))
-      ((minusp i))
-    (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))
-
-(defun rec-u8 (value)
-  "Append an 8-bit VALUE to the current record."
-  (rec-byte 1 value))
-(defun rec-u16 (value)
-  "Append a 16-bit VALUE to the current record."
-  (rec-byte 2 value))
-(defun rec-u32 (value)
-  "Append a 32-bit VALUE to the current record."
-  (rec-byte 4 value))
-
-(defun rec-raw-string (s &key (start 0) end)
-  "Append (a (substring of) a raw string S to the current record.
-
-   No arrangement is made for reporting the length of the string.  That must
-   be done by the caller, if necessary."
-  (setf-default end (length s))
-  (rec-ensure (- end start))
-  (do ((i start (1+ i)))
-      ((>= i end))
-    (vector-push (char-code (char s i)) *record-vector*)))
-
-(defun rec-name (s)
-  "Append a domain name S.
-
-   No attempt is made to perform compression of the name."
-  (let ((i 0) (n (length s)))
-    (loop (let* ((dot (position #\. s :start i))
-                (lim (or dot n)))
-           (rec-u8 (- lim i))
-           (rec-raw-string s :start i :end lim)
-           (if dot
-               (setf i (1+ dot))
-               (return))))
-    (when (< i n)
-      (rec-u8 0))))
-
-(defmacro build-record (&body body)
-  "Build a raw record, and return it as a vector of octets."
-  `(let ((*record-vector* (make-array 256
-                                     :element-type '(unsigned-byte 8)
-                                     :fill-pointer 0
-                                     :adjustable t)))
-     ,@body
-     (copy-seq *record-vector*)))
-
-;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
 (export 'zone-write)
@@ -1061,6 +1134,7 @@
 (defvar *zone-output-stream* nil
   "Stream to write zone data on.")
 
+(export 'zone-write-raw-rrdata)
 (defgeneric zone-write-raw-rrdata (format zr type data)
   (:documentation "Write an otherwise unsupported record in a given FORMAT.
 
@@ -1095,7 +1169,12 @@
 (defgeneric zone-write-record (format type zr)
   (:documentation "Emit a record of the given TYPE (a keyword).
 
-   There is no default implementation."))
+   The default implementation builds the raw RRDATA and passes it to
+   `zone-write-raw-rrdata'.")
+  (:method (format type zr)
+    (let* (code
+          (data (build-record (setf code (zone-record-rrdata type zr)))))
+      (zone-write-raw-rrdata format zr code data))))
 
 (defmethod zone-write (format zone stream)
   "This default method calls `zone-write-header', then `zone-write-record'
@@ -1204,6 +1283,31 @@ $TTL ~2@*~D~2%"
          (string-upcase (symbol-name (zr-type zr)))
          format args))
 
+(defmethod zone-write-raw-rrdata ((format (eql :bind)) zr type data)
+  (format *zone-output-stream*
+         "~A~20T~@[~8D~]~30TIN TYPE~A~40T\\# ~A"
+         (bind-output-hostname (zr-name zr))
+         (let ((ttl (zr-ttl zr)))
+           (and (/= ttl (zone-default-ttl *writing-zone*))
+                ttl))
+         type
+         (length data))
+  (let* ((hex (with-output-to-string (out)
+              (dotimes (i (length data))
+                (format out "~(~2,'0X~)" (aref data i)))))
+        (len (length hex)))
+    (cond ((< len 24)
+          (format *zone-output-stream* " ~A~%" hex))
+         (t
+          (format *zone-output-stream* " (")
+          (let ((i 0))
+            (loop
+              (when (>= i len) (return))
+              (let ((j (min (+ i 64) len)))
+                (format *zone-output-stream* "~%~8T~A" (subseq hex i j))
+                (setf i j))))
+          (format *zone-output-stream* " )~%")))))
+
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :a)) zr)
   (bind-format-record zr "~A" (ipaddr-string (zr-data zr))))
 
@@ -1241,7 +1345,7 @@ $TTL ~2@*~D~2%"
 (defun tinydns-output (code &rest fields)
   (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))
 
-(defun tinydns-raw-record (type zr data)
+(defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data)
   (tinydns-output #\: (zr-name zr) type
                  (with-output-to-string (out)
                    (dotimes (i (length data))
@@ -1276,35 +1380,6 @@ $TTL ~2@*~D~2%"
        (prio (cdr (zr-data zr))))
     (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr))))
 
-(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :txt)) zr)
-  (tinydns-raw-record 16 zr
-                     (build-record
-                       (dolist (s (zr-data zr))
-                         (rec-u8 (length s))
-                         (rec-raw-string s)))))
-
-(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :srv)) zr)
-  (destructuring-bind (prio weight port host) (zr-data zr)
-    (tinydns-raw-record 33 zr
-                       (build-record
-                         (rec-u16 prio)
-                         (rec-u16 weight)
-                         (rec-u16 port)
-                         (rec-name host)))))
-
-(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :sshfp)) zr)
-  (destructuring-bind (alg type fpr) (zr-data zr)
-    (tinydns-raw-record 44 zr
-                       (build-record
-                         (rec-u8 alg)
-                         (rec-u8 type)
-                         (do ((i 0 (+ i 2))
-                              (n (length fpr)))
-                             ((>= i n))
-                           (rec-u8 (parse-integer fpr
-                                                  :start i :end (+ i 2)
-                                                  :radix 16))))))))
-
 (defmethod zone-write-header ((format (eql :tinydns)) zone)
   (format *zone-output-stream* "~
 ### Zone file `~(~A~)'