From 9f408c6016659a51546516b41c96e926bace3847 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Wed, 30 Apr 2014 16:17:09 +0100 Subject: [PATCH] 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'. --- zone.lisp | 271 +++++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 173 insertions(+), 98 deletions(-) diff --git a/zone.lisp b/zone.lisp index 32f1aed..f4f2367 100644 --- 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~)' -- 2.11.0