X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/679775ba19206747f3a1682cd0090bdae29c13a2..f4e0c48f17d3c959d3751faba9ce9cd0becfba41:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 7318c2a..9e5795d 100644 --- a/zone.lisp +++ b/zone.lisp @@ -61,9 +61,10 @@ (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 @@ (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)) @@ -198,15 +200,21 @@ (export 'zone-subdomain) (defstruct (zone-subdomain (:conc-name zs-)) - "A subdomain. Slightly weird. Used internally by zone-process-records - below, and shouldn't escape." + "A subdomain. + + Slightly weird. Used internally by `zone-process-records', and shouldn't + escape." name ttl 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 +227,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) @@ -228,9 +236,11 @@ (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 + "Execute a form based on which networks are considered preferred. + + The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS + whose SUBNETS (a list or single symbol, not evaluated) are listed in + `*preferred-subnets*'. If SUBNETS is the symbol `t' then the clause always matches." `(cond ,@(mapcar (lambda (clause) @@ -248,9 +258,47 @@ 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. + + REC is a list of records of the form + + ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*) + + The various kinds of entries have the following meanings. + + :ttl TTL Set the TTL for subsequent records (at this level of + nesting only). + + TYPE DATA Define a record with a particular TYPE and DATA. + Record types are defined using `defzoneparse' and + the syntax of the data is idiosyncratic. + + ((LABEL ...) . REC) Define records for labels within the zone. Any + records defined within REC will have their domains + prefixed by each of the LABELs. A singleton list + of labels may instead be written as a single + label. Note, therefore, that + + (host (sub :a \"169.254.1.1\")) + + defines a record for `host.sub' -- not `sub.host'. + + If REC contains no top-level records, but it does define records for a + label listed in `*preferred-subnets*', then the records for the first such + label are also promoted to top-level. + + The FUNC is called for each record encountered, represented as a + `zone-record' object. Zone parsers are not called: you get the record + types and data from the input form; see `zone-parse-records' if you want + the raw output." + (labels ((sift (rec ttl) + ;; Parse the record list REC into lists of `zone-record' and + ;; `zone-subdomain' objects, sorting out TTLs and so on. + ;; Returns them as two values. + (collecting (top sub) (loop (unless rec @@ -271,16 +319,21 @@ sub))) (t (error "Unexpected record form ~A" (car r)))))))) + (process (rec dom ttl) + ;; Recursirvely process the record list REC, with a list DOM of + ;; prefix labels, and a default TTL. Promote records for a + ;; preferred subnet to toplevel if there are no toplevel records + ;; already. + (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 @@ -295,12 +348,16 @@ (process (zs-records s) (cons (zs-name s) dom) (zs-ttl s)))))) + + ;; Process the records we're given with no prefix. (process rec nil ttl))) (export 'zone-parse-host) (defun zone-parse-host (f zname) - "Parse a host name F: if F ends in a dot then it's considered absolute; - otherwise it's relative to ZNAME." + "Parse a host name F. + + If F ends in a dot then it's considered absolute; otherwise it's relative + to ZNAME." (setf f (stringify f)) (cond ((string= f "@") (stringify zname)) ((and (plusp (length f)) @@ -379,8 +436,10 @@ (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 +457,8 @@ (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 +467,12 @@ ;;; 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." @@ -440,6 +501,11 @@ (export 'zone-make-name) (defun zone-make-name (prefix zone-name) + "Compute a full domain name from a PREFIX and a ZONE-NAME. + + If the PREFIX ends with `.' then it's absolute already; otherwise, append + the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then + return the ZONE-NAME only." (if (or (not prefix) (string= prefix "@")) zone-name (let ((len (length prefix))) @@ -450,11 +516,14 @@ (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 arguments are as follows: + + TYPES A singleton type symbol, or a list of aliases. NAME The name of the record to be added. @@ -504,30 +573,28 @@ :make-ptr-p ,tmakeptrp) ,col))) ,@body))) - ',type))))) - -(defun zone-parse-records (zone records) - (let ((zname (zone-name zone))) - (with-collection (rec) - (flet ((parse-record (zr) - (let ((func (or (get (zr-type zr) 'zone-parse) - (error "No parser for record ~A." - (zr-type zr)))) - (name (and (zr-name zr) (stringify (zr-name zr))))) - (funcall func - name - zname - (zr-data zr) - (zr-ttl zr) - rec)))) - (zone-process-records records - (zone-default-ttl zone) - #'parse-record)) - (setf (zone-records zone) (nconc (zone-records zone) rec))))) + ',type))))) + +(export 'zone-parse-records) +(defun zone-parse-records (zname ttl records) + "Parse a sequence of RECORDS and return a list of raw records. + + The records are parsed relative to the zone name ZNAME, and using the + given default TTL." + (collecting (rec) + (flet ((parse-record (zr) + (let ((func (or (get (zr-type zr) 'zone-parse) + (error "No parser for record ~A." + (zr-type zr)))) + (name (and (zr-name zr) (stringify (zr-name zr))))) + (funcall func name zname (zr-data zr) (zr-ttl zr) rec)))) + (zone-process-records records ttl #'parse-record)))) (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* @@ -536,12 +603,10 @@ ((NAME*) ZONE-RECORD*) | SYM ARGS" (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf)) - (let ((zone (make-zone :name zname - :default-ttl ttl - :soa soa - :records nil))) - (zone-parse-records zone (cdr zf)) - zone))) + (make-zone :name zname + :default-ttl ttl + :soa soa + :records (zone-parse-records zname ttl (cdr zf))))) (export 'zone-create) (defun zone-create (zf) @@ -591,6 +656,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)) @@ -653,7 +810,7 @@ (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 +865,38 @@ (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 +912,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))) @@ -862,6 +1021,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 --------------------------------------------------