X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/679775ba19206747f3a1682cd0090bdae29c13a2..48608192115031ce77b027693b1a058e727005ee:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 7318c2a..a6c4944 100644 --- a/zone.lisp +++ b/zone.lisp @@ -61,9 +61,10 @@ (defun to-mixed-base (base val) (export 'timespec-seconds) (defun timespec-seconds (ts) - "Convert a timespec TS to seconds. A timespec may be a real count of - seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious - time units." + "Convert a timespec TS to seconds. + + A timespec may be a real count of seconds, or a list (COUNT UNIT): UNIT + may be any of a number of obvious time units." (cond ((null ts) 0) ((realp ts) (floor ts)) ((atom ts) @@ -90,10 +91,11 @@ (defun hash-table-keys (ht) (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht))) (defun iso-date (&optional time &key datep timep (sep #\ )) - "Construct a textual date or time in ISO format. The TIME is the universal - time to convert, which defaults to now; DATEP is whether to emit the date; - TIMEP is whether to emit the time, and SEP (default is space) is how to - separate the two." + "Construct a textual date or time in ISO format. + + The TIME is the universal time to convert, which defaults to now; DATEP is + whether to emit the date; TIMEP is whether to emit the time, and + SEP (default is space) is how to separate the two." (multiple-value-bind (sec min hr day mon yr dow dstp tz) (decode-universal-time (if (or (null time) (eq time :now)) @@ -205,8 +207,12 @@ (defstruct (zone-subdomain (:conc-name zs-)) 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 @@ -219,7 +225,7 @@ (defun zone-file-name (zone type) "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) @@ -228,10 +234,11 @@ (defun zone-preferred-subnet-p (name) (export 'preferred-subnet-case) (defmacro preferred-subnet-case (&body clauses) - "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose - SUBNETS (a list or single symbol, not evaluated) are considered preferred - by zone-preferred-subnet-p. If SUBNETS is the symbol t then the clause - always matches." + "CLAUSES have the form (SUBNETS . FORMS). + + Evaluate the first FORMS whose SUBNETS (a list or single symbol, not + evaluated) are considered preferred by zone-preferred-subnet-p. If + SUBNETS is the symbol t then the clause always matches." `(cond ,@(mapcar (lambda (clause) (let ((subnets (car clause))) @@ -248,8 +255,27 @@ (defmacro preferred-subnet-case (&body clauses) clauses))) (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." + "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. + + 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 @@ -274,13 +300,12 @@ (defun zone-process-records (rec ttl func) (process (rec dom ttl) (multiple-value-bind (top sub) (sift rec ttl) (if (and dom (null top) sub) - (let ((preferred nil)) - (dolist (s sub) - (when (some #'zone-preferred-subnet-p - (listify (zs-name s))) - (setf preferred s))) - (unless preferred - (setf preferred (car sub))) + (let ((preferred + (or (find-if (lambda (s) + (some #'zone-preferred-subnet-p + (listify (zs-name s)))) + sub) + (car sub)))) (when preferred (process (zs-records preferred) dom @@ -379,8 +404,10 @@ (defun zone-cidr-delg-default-name (ipn bytes) (export 'make-zone-serial) (defun make-zone-serial (name) - "Given a zone NAME, come up with a new serial number. This will (very - carefully) update a file ZONE.serial in the current directory." + "Given a zone NAME, come up with a new serial number. + + This will (very carefully) update a file ZONE.serial in the current + directory." (let* ((file (zone-file-name name :serial)) (last (with-open-file (in file :direction :input @@ -398,8 +425,8 @@ (defun make-zone-serial (name) (safely-writing (out file) (format out ";; Serial number file for zone ~A~%~ - ;; (LAST-SEQ DAY MONTH YEAR)~%~ - ~S~%" + ;; (LAST-SEQ DAY MONTH YEAR)~%~ + ~S~%" name (cons seq now))) (from-mixed-base '(100 100 100) (reverse (cons seq now))))) @@ -408,10 +435,12 @@ (defun make-zone-serial (name) ;;; Zone form parsing. (defun zone-parse-head (head) - "Parse the HEAD of a zone form. This has the form + "Parse the HEAD of a zone form. + + This has the form (NAME &key :source :admin :refresh :retry - :expire :min-ttl :ttl :serial) + :expire :min-ttl :ttl :serial) though a singleton NAME needn't be a list. Returns the default TTL and an soa structure representing the zone head." @@ -450,11 +479,12 @@ (defun zone-make-name (prefix zone-name) (export 'defzoneparse) (defmacro defzoneparse (types (name data list &key (prefix (gensym "PREFIX")) - (zname (gensym "ZNAME")) - (ttl (gensym "TTL"))) + (zname (gensym "ZNAME")) + (ttl (gensym "TTL"))) &body body) - "Define a new zone record type (or TYPES -- a list of synonyms is - permitted). The arguments are as follows: + "Define a new zone record type. + + The TYPES may be a list of synonyms. The other arguments are as follows: NAME The name of the record to be added. @@ -507,6 +537,9 @@ (defun ,func (,prefix ,zname ,data ,ttl ,col) ',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) @@ -527,7 +560,9 @@ (defun zone-parse-records (zone records) (export 'zone-parse) (defun zone-parse (zf) - "Parse a ZONE form. The syntax of a zone form is as follows: + "Parse a ZONE form. + + The syntax of a zone form is as follows: ZONE-FORM: ZONE-HEAD ZONE-RECORD* @@ -591,6 +626,87 @@ (defzoneparse :txt (name data rec) ":txt TEXT" (rec :data data)) +(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 file :direction :input) + (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)))) + +(defzoneparse :sshfp (name data rec) + ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }" + (if (stringp data) + (with-open-file (in data) + (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)) @@ -653,7 +769,7 @@ (defzoneparse :net (name data rec) (rec :name (zone-parse-host "mask" name) :type :a :data (ipnet-mask n)) - (rec :name (zone-parse-host "broadcast" name) + (rec :name (zone-parse-host "bcast" name) :type :a :data (ipnet-broadcast n))))) @@ -708,37 +824,38 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname) (unless bytes (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) (dolist (map (or (cdr data) (list (list net)))) - (destructuring-bind (tnet &optional tdom) (listify map) - (setf tnet (zone-parse-net tnet name)) - (unless (ipnet-subnetp net tnet) - (error "~A is not a subnet of ~A." - (ipnet-pretty tnet) - (ipnet-pretty net))) - (unless tdom - (with-ipnet (net mask) tnet - (setf tdom - (join-strings - #\. - (append (reverse (loop - for i from (1- bytes) downto 0 - until (zerop (logand mask - (ash #xff - (* 8 i)))) - collect (ldb (byte 8 (* i 8)) net))) - (list name)))))) - (setf tdom (string-downcase (stringify tdom))) - (dotimes (i (ipnet-hosts tnet)) - (unless (zerop i) - (let* ((addr (ipnet-host tnet i)) - (tail (join-strings #\. - (loop - for i from 0 below bytes - collect - (logand #xff - (ash addr (* 8 i))))))) - (rec :name (format nil "~A.~A" tail name) - :type :cname - :data (format nil "~A.~A" tail tdom))))))))) + (destructuring-bind (tnets &optional tdom) (listify map) + (dolist (tnet (listify tnets)) + (setf tnet (zone-parse-net tnet name)) + (unless (ipnet-subnetp net tnet) + (error "~A is not a subnet of ~A." + (ipnet-pretty tnet) + (ipnet-pretty net))) + (unless tdom + (with-ipnet (net mask) tnet + (setf tdom + (join-strings + #\. + (append (reverse (loop + for i from (1- bytes) downto 0 + until (zerop (logand mask + (ash #xff + (* 8 i)))) + collect (ldb (byte 8 (* i 8)) net))) + (list name)))))) + (setf tdom (string-downcase (stringify tdom))) + (dotimes (i (ipnet-hosts tnet)) + (unless (zerop i) + (let* ((addr (ipnet-host tnet i)) + (tail (join-strings #\. + (loop + for i from 0 below bytes + collect + (logand #xff + (ash addr (* 8 i))))))) + (rec :name (format nil "~A.~A" tail name) + :type :cname + :data (format nil "~A.~A" tail tdom)))))))))) ;;;-------------------------------------------------------------------------- ;;; Zone file output. @@ -754,6 +871,7 @@ (defvar *zone-output-stream* nil "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))) @@ -862,6 +980,10 @@ (defgeneric bind-record-format-args (type 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 :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 --------------------------------------------------