X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/32ebbe9b0fcc1a698c6ffec760259c5f7e953a9d..3f0a712769b209f54360e23c543bcc4eda72d149:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 735e87f..2228c07 100644 --- a/zone.lisp +++ b/zone.lisp @@ -439,7 +439,7 @@ (ttl min-ttl) (serial (make-zone-serial zname))) (listify head) - (values zname + (values (string-downcase zname) (timespec-seconds ttl) (make-soa :admin admin :source (zone-parse-host source zname) @@ -580,12 +580,14 @@ nconc (list k v))) ,@',zf))))))) +(export 'map-host-addresses) (defun map-host-addresses (func addr &key (family *address-family*)) "Call FUNC for each address denoted by ADDR (a `host-parse' address)." (dolist (a (host-addrs (host-parse addr family))) (funcall func a))) +(export 'do-host) (defmacro do-host ((addr spec &key (family *address-family*)) &body body) "Evaluate BODY, binding ADDR to each address denoted by SPEC." `(dolist (,addr (host-addrs (host-parse ,spec ,family))) @@ -609,6 +611,10 @@ ":a IPADDR" (zone-set-address #'rec data :make-ptr-p t :family :ipv4)) +(defzoneparse :aaaa (name data rec) + ":aaaa IPADDR" + (zone-set-address #'rec data :make-ptr-p t :family :ipv6)) + (defzoneparse :addr (name data rec) ":addr IPADDR" (zone-set-address #'rec data :make-ptr-p t)) @@ -626,8 +632,8 @@ (rec :data (zone-parse-host data zname))) (defzoneparse :txt (name data rec) - ":txt TEXT" - (rec :data data)) + ":txt (TEXT*)" + (rec :data (listify data))) (export '*dkim-pathname-defaults*) (defvar *dkim-pathname-defaults* @@ -815,7 +821,7 @@ :ttl (zr-ttl zr) :data (zr-name zr)) (setf (gethash name seen) t)))))))))) -(defzoneparse (:multi) (name data rec :zname zname :ttl ttl) +(defzoneparse :multi (name data rec :zname zname :ttl ttl) ":multi (((NET*) &key :start :end :family :suffix) . REC) Output multiple records covering a portion of the reverse-resolution @@ -877,6 +883,73 @@ :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) @@ -949,7 +1022,8 @@ $TTL ~2@*~D~2%" (setf (char copy at) #\.)) copy))) (format stream "~ -~A~30TIN SOA~40T~A ~A ( +~A~30TIN SOA~40T~A ( +~55@A~60T ;administrator ~45T~10D~60T ;serial ~45T~10D~60T ;refresh ~45T~10D~60T ;retry @@ -983,6 +1057,7 @@ $TTL ~2@*~D~2%" (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))) @@ -995,7 +1070,7 @@ $TTL ~2@*~D~2%" (cons "~2D ~2D ~A" data)) (:method ((type (eql :txt)) data) (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]" - (mapcar #'stringify (listify data))))) + (mapcar #'stringify data)))) (defmethod bind-record (type zr) (destructuring-bind (format &rest args) @@ -1005,4 +1080,90 @@ $TTL ~2@*~D~2%" (bind-record-type type) format args))) +;;;-------------------------------------------------------------------------- +;;; tinydns-data output format. + +(defun tinydns-output (code &rest fields) + (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields)) + +(defun tinydns-raw-record (type zr data) + (tinydns-output #\: (zr-name zr) type + (with-output-to-string (out) + (dotimes (i (length data)) + (let ((byte (aref data i))) + (if (or (<= byte 32) + (>= byte 128) + (member byte '(#\: #\\) :key #'char-code)) + (format out "\\~3,'0O" byte) + (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 "~ +### Zone file `~(~A~)' +### (generated ~A) +~%" + (zone-name zone) + (iso-date :now :datep t :timep t)) + (let ((soa (zone-soa zone))) + (tinydns-output #\Z + (zone-name zone) + (soa-source soa) + (let* ((name (copy-seq (soa-admin soa))) + (at (position #\@ name))) + (when at (setf (char name at) #\.)) + name) + (soa-serial soa) + (soa-refresh soa) + (soa-expire soa) + (soa-min-ttl soa) + (zone-default-ttl zone))) + (dolist (zr (zone-records zone)) + (tinydns-record (zr-type zr) zr))) + ;;;----- That's all, folks --------------------------------------------------