X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/679775ba19206747f3a1682cd0090bdae29c13a2..9d1d9739d9562bfdc59661c2256a0246ab113eae:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 7318c2a..909f755 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)) @@ -228,10 +230,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 - 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 +251,27 @@ 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 +296,12 @@ (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 +400,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 +421,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 +431,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." @@ -450,11 +475,12 @@ (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 +533,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) @@ -527,7 +556,9 @@ (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* @@ -653,7 +684,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 +739,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 +786,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 +895,8 @@ $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 :txt)) data) + (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]" + (mapcar #'stringify (listify data))))) ;;;----- That's all, folks --------------------------------------------------