X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/f38bc59e4fdc74fc56553b04b0e135f0ee438747..f760c73a508d858660486f31306d4ae066957cf6:/zone.lisp diff --git a/zone.lisp b/zone.lisp index b0e5582..f03b9dd 100644 --- a/zone.lisp +++ b/zone.lisp @@ -207,8 +207,12 @@ records) (export '*zone-output-path*) -(defvar *zone-output-path* *default-pathname-defaults* - "Pathname defaults to merge into output files.") +(defvar *zone-output-path* nil + "Pathname defaults to merge into output files. + + If this is nil then use the prevailing `*default-pathname-defaults*'. + This is not the same as capturing the `*default-pathname-defaults*' from + load time.") (export '*preferred-subnets*) (defvar *preferred-subnets* nil @@ -221,7 +225,7 @@ "Choose a file name for a given ZONE and TYPE." (merge-pathnames (make-pathname :name (string-downcase zone) :type (string-downcase type)) - *zone-output-path*)) + (or *zone-output-path* *default-pathname-defaults*))) (export 'zone-preferred-subnet-p) (defun zone-preferred-subnet-p (name) @@ -253,7 +257,25 @@ (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." + 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 @@ -515,6 +537,9 @@ ',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) @@ -601,6 +626,98 @@ ":txt TEXT" (rec :data data)) +(export '*dkim-pathname-defaults*) +(defvar *dkim-pathname-defaults* + (make-pathname :directory '(:relative "keys") + :type "dkim")) + +(defzoneparse :dkim (name data rec) + ":dkim (KEYFILE {:TAG VALUE}*)" + (destructuring-bind (file &rest plist) (listify data) + (let ((things nil) (out nil)) + (labels ((flush () + (when out + (push (get-output-stream-string out) things) + (setf out nil))) + (emit (text) + (let ((len (length text))) + (when (and out (> (+ (file-position out) + (length text)) + 64)) + (flush)) + (when (plusp len) + (cond ((< len 64) + (unless out (setf out (make-string-output-stream))) + (write-string text out)) + (t + (do ((i 0 j) + (j 64 (+ j 64))) + ((>= i len)) + (push (subseq text i (min j len)) things)))))))) + (do ((p plist (cddr p))) + ((endp p)) + (emit (format nil "~(~A~)=~A;" (car p) (cadr p)))) + (emit (with-output-to-string (out) + (write-string "p=" out) + (when file + (with-open-file + (in (merge-pathnames file *dkim-pathname-defaults*)) + (loop + (when (string= (read-line in) + "-----BEGIN PUBLIC KEY-----") + (return))) + (loop + (let ((line (read-line in))) + (if (string= line "-----END PUBLIC KEY-----") + (return) + (write-string line out))))))))) + (rec :type :txt + :data (nreverse things))))) + +(eval-when (:load-toplevel :execute) + (dolist (item '((sshfp-algorithm rsa 1) + (sshfp-algorithm dsa 2) + (sshfp-algorithm ecdsa 3) + (sshfp-type sha-1 1) + (sshfp-type sha-256 2))) + (destructuring-bind (prop sym val) item + (setf (get sym prop) val) + (export sym)))) + +(export '*sshfp-pathname-defaults*) +(defvar *sshfp-pathname-defaults* + (make-pathname :directory '(:relative "keys") + :type "sshfp")) + +(defzoneparse :sshfp (name data rec) + ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }" + (if (stringp data) + (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*)) + (loop (let ((line (read-line in nil))) + (unless line (return)) + (let ((words (str-split-words line))) + (pop words) + (when (string= (car words) "IN") (pop words)) + (unless (and (string= (car words) "SSHFP") + (= (length words) 4)) + (error "Invalid SSHFP record.")) + (pop words) + (destructuring-bind (alg type fpr) words + (rec :data (list (parse-integer alg) + (parse-integer type) + fpr))))))) + (flet ((lookup (what prop) + (etypecase what + (fixnum what) + (symbol (or (get what prop) + (error "~S is not a known ~A" what prop)))))) + (dolist (item (listify data)) + (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1)) + (listify item) + (rec :data (list (lookup alg 'sshfp-algorithm) + (lookup type 'sshfp-type) + fpr))))))) + (defzoneparse :mx (name data rec :zname zname) ":mx ((HOST :prio INT :ip IPADDR)*)" (dolist (mx (listify data)) @@ -765,6 +882,7 @@ "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))) @@ -873,6 +991,10 @@ $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 :txt)) data) (list "~S" (stringify data)))) + (:method ((type (eql :sshfp)) data) + (cons "~2D ~2D ~A" data)) + (:method ((type (eql :txt)) data) + (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]" + (mapcar #'stringify (listify data))))) ;;;----- That's all, folks --------------------------------------------------