X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/48608192115031ce77b027693b1a058e727005ee..f4e0c48f17d3c959d3751faba9ce9cd0becfba41:/zone.lisp diff --git a/zone.lisp b/zone.lisp index a6c4944..9e5795d 100644 --- a/zone.lisp +++ b/zone.lisp @@ -63,7 +63,7 @@ (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 + 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)) @@ -200,8 +200,10 @@ (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) @@ -234,11 +236,12 @@ (export 'preferred-subnet-case) (defmacro preferred-subnet-case (&body clauses) - "CLAUSES have the form (SUBNETS . FORMS). + "Execute a form based on which networks are considered preferred. - 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." + 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) (let ((subnets (car clause))) @@ -259,24 +262,43 @@ 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. + 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). - ZONE-RECORD: RR | TTL | SUBZONE - The body of a zone form is a sequence of these. + 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. - TTL: :ttl INTEGER - Sets the TTL for subsequent RRs in this zone or subzone. + ((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 - RR: SYMBOL DATA - Adds a record for the current NAME; the SYMBOL denotes the record - type, and the DATA depends on the type. + (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." - 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) + ;; 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 @@ -297,7 +319,13 @@ 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 @@ -320,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)) @@ -469,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))) @@ -484,7 +521,9 @@ &body body) "Define a new zone record type. - The TYPES may be a list of synonyms. The other arguments are as follows: + The arguments are as follows: + + TYPES A singleton type symbol, or a list of aliases. NAME The name of the record to be added. @@ -534,35 +573,28 @@ :make-ptr-p ,tmakeptrp) ,col))) ,@body))) - ',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) - (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: + The syntax of a zone form is as follows: ZONE-FORM: ZONE-HEAD ZONE-RECORD* @@ -571,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) @@ -626,6 +656,11 @@ ":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) @@ -655,7 +690,8 @@ (emit (with-output-to-string (out) (write-string "p=" out) (when file - (with-open-file (in file :direction :input) + (with-open-file + (in (merge-pathnames file *dkim-pathname-defaults*)) (loop (when (string= (read-line in) "-----BEGIN PUBLIC KEY-----") @@ -678,10 +714,15 @@ (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 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)))