X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/05e83012402ab4231225d00f937924272924fb4b..422e7cfc8bb601ae1f24422d5fe1325ee72de82a:/zone.lisp diff --git a/zone.lisp b/zone.lisp index c586915..e686322 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,11 +1134,59 @@ (defvar *zone-output-stream* nil "Stream to write zone data on.") -(defmethod zone-write :around (format zone stream) - (declare (ignore format)) +(export 'zone-write-raw-rrdata) +(defgeneric zone-write-raw-rrdata (format zr type data) + (:documentation "Write an otherwise unsupported record in a given FORMAT. + + ZR gives the record object, which carries the name and TTL; the TYPE is + the numeric RRTYPE code; and DATA is an octet vector giving the RRDATA. + This is used by the default `zone-write-record' method to handle record + types which aren't directly supported by the format driver.")) + +(export 'zone-write-header) +(defgeneric zone-write-header (format zone) + (:documentation "Emit the header for a ZONE, in a given FORMAT. + + The header includes any kind of initial comment, the SOA record, and any + other necessary preamble. There is no default implementation. + + This is part of the protocol used by the default method on `zone-write'; + if you override that method.")) + +(export 'zone-write-trailer) +(defgeneric zone-write-trailer (format zone) + (:documentation "Emit the header for a ZONE, in a given FORMAT. + + The footer may be empty, and is so by default. + + This is part of the protocol used by the default method on `zone-write'; + if you override that method.") + (:method (format zone) + (declare (ignore format zone)) + nil)) + +(export 'zone-write-record) +(defgeneric zone-write-record (format type zr) + (:documentation "Emit a record of the given TYPE (a keyword). + + 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' + for each record in the zone, and finally `zone-write-trailer'. While it's + running, `*writing-zone*' is bound to the zone object, and + `*zone-output-stream*' to the output stream." (let ((*writing-zone* zone) (*zone-output-stream* stream)) - (call-next-method))) + (zone-write-header format zone) + (dolist (zr (zone-records-sorted zone)) + (zone-write-record format (zr-type zr) zr)) + (zone-write-trailer format zone))) (export 'zone-save) (defun zone-save (zones &key (format :bind)) @@ -1113,11 +1234,12 @@ (setf *bind-last-record-name* name) name)))) -(export 'bind-record) -(defgeneric bind-record (type zr)) +(defmethod zone-write :around ((format (eql :bind)) zone stream) + (let ((*bind-last-record-name* nil)) + (call-next-method))) -(defmethod zone-write ((format (eql :bind)) zone stream) - (format stream "~ +(defmethod zone-write-header ((format (eql :bind)) zone) + (format *zone-output-stream* "~ ;;; Zone file `~(~A~)' ;;; (generated ~A) @@ -1126,15 +1248,14 @@ $TTL ~2@*~D~2%" (zone-name zone) (iso-date :now :datep t :timep t) (zone-default-ttl zone)) - (let* ((*bind-last-record-name* nil) - (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 "~ + (format *zone-output-stream* "~ ~A~30TIN SOA~40T~A ( ~55@A~60T ;administrator ~45T~10D~60T ;serial @@ -1149,57 +1270,83 @@ $TTL ~2@*~D~2%" (soa-refresh soa) (soa-retry soa) (soa-expire soa) - (soa-min-ttl soa)) - (dolist (zr (zone-records-sorted zone)) - (bind-record (zr-type zr) zr)))) + (soa-min-ttl soa)))) (export 'bind-format-record) -(defun bind-format-record (name ttl type format args) +(defun bind-format-record (zr format &rest args) (format *zone-output-stream* "~A~20T~@[~8D~]~30TIN ~A~40T~?~%" - (bind-output-hostname name) - (and (/= ttl (zone-default-ttl *writing-zone*)) - ttl) - (string-upcase (symbol-name type)) + (bind-output-hostname (zr-name zr)) + (let ((ttl (zr-ttl zr))) + (and (/= ttl (zone-default-ttl *writing-zone*)) + ttl)) + (string-upcase (symbol-name (zr-type zr))) format args)) -(export 'bind-record-type) -(defgeneric bind-record-type (type) - (:method (type) type)) - -(export 'bind-record-format-args) -(defgeneric bind-record-format-args (type data) - (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data))) - (:method ((type (eql :aaaa)) 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 :sshfp)) data) - (cons "~2D ~2D ~A" data)) - (:method ((type (eql :txt)) data) - (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]" - (mapcar #'stringify data)))) - -(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))) +(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)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr) + (bind-format-record zr "~A" (ipaddr-string (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr) + (bind-format-record zr "~A" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr) + (bind-format-record zr "~A" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr) + (bind-format-record zr "~A" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr) + (bind-format-record zr "~2D ~A" + (cdr (zr-data zr)) + (bind-hostname (car (zr-data zr))))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr) + (destructuring-bind (prio weight port host) (zr-data zr) + (bind-format-record zr "~2D ~5D ~5D ~A" + prio weight port (bind-hostname host)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr) + (bind-format-record zr "~{~2D ~2D ~A~}" (zr-data zr))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr) + (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}" (zr-data zr))) ;;;-------------------------------------------------------------------------- ;;; tinydns-data output format. +(export 'tinydns-output) (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)) @@ -1211,53 +1358,31 @@ $TTL ~2@*~D~2%" (write-char (code-char byte) out))))) (zr-ttl zr))) -(defgeneric tinydns-record (type zr) - (:method ((type (eql :a)) zr) - (tinydns-output #\+ (zr-name zr) - (ipaddr-string (zr-data zr)) (zr-ttl zr))) - (:method ((type (eql :aaaa)) zr) - (tinydns-output #\3 (zr-name zr) - (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr))) - (zr-ttl zr))) - (:method ((type (eql :ptr)) zr) - (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr))) - (:method ((type (eql :cname)) zr) - (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr))) - (:method ((type (eql :ns)) zr) - (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr))) - (:method ((type (eql :mx)) zr) - (let ((name (car (zr-data zr))) - (prio (cdr (zr-data zr)))) - (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr)))) - (:method ((type (eql :txt)) zr) - (tinydns-raw-record 16 zr - (build-record - (dolist (s (zr-data zr)) - (rec-u8 (length s)) - (rec-raw-string s))))) - (:method ((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))))) - (:method ((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 ((format (eql :tinydns)) zone stream) - (format stream "~ +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :a)) zr) + (tinydns-output #\+ (zr-name zr) + (ipaddr-string (zr-data zr)) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :aaaa)) zr) + (tinydns-output #\3 (zr-name zr) + (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr))) + (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ptr)) zr) + (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :cname)) zr) + (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ns)) zr) + (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :mx)) zr) + (let ((name (car (zr-data zr))) + (prio (cdr (zr-data zr)))) + (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr)))) + +(defmethod zone-write-header ((format (eql :tinydns)) zone) + (format *zone-output-stream* "~ ### Zone file `~(~A~)' ### (generated ~A) ~%" @@ -1275,8 +1400,6 @@ $TTL ~2@*~D~2%" (soa-refresh soa) (soa-expire soa) (soa-min-ttl soa) - (zone-default-ttl zone))) - (dolist (zr (zone-records-sorted zone)) - (tinydns-record (zr-type zr) zr))) + (zone-default-ttl zone)))) ;;;----- That's all, folks --------------------------------------------------