X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/cc0fa47a50532786e202ee24c6518e50ba6959e2..9d1d9739d9562bfdc59661c2256a0246ab113eae:/zone.lisp diff --git a/zone.lisp b/zone.lisp index ea9fda3..909f755 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; DNS zone generation ;;; ;;; (c) 2005 Straylight/Edgeware @@ -29,21 +27,7 @@ (defpackage #:zone (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely - #:net #:services) - (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain - #:*default-zone-source* #:*default-zone-refresh* - #:*default-zone-retry* #:*default-zone-expire* - #:*default-zone-min-ttl* #:*default-zone-ttl* - #:*default-mx-priority* #:*default-zone-admin* - #:*zone-output-path* - #:*preferred-subnets* #:zone-preferred-subnet-p - #:preferred-subnet-case - #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone - #:defrevzone #:zone-save #:zone-make-name - #:defzoneparse #:zone-parse-host - #:bind-hostname #:bind-record #:bind-format-record - #:bind-record-type #:bind-record-format-args - #:timespec-seconds #:make-zone-serial)) + #:net #:services)) (in-package #:zone) @@ -75,10 +59,12 @@ (push r a) (setf val q))))) +(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) @@ -105,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)) @@ -126,6 +113,7 @@ ;;;-------------------------------------------------------------------------- ;;; Zone types. +(export 'soa) (defstruct (soa (:predicate soap)) "Start-of-authority record information." source @@ -136,11 +124,13 @@ min-ttl serial) +(export 'mx) (defstruct (mx (:predicate mxp)) "Mail-exchange record information." priority domain) +(export 'zone) (defstruct (zone (:predicate zonep)) "Zone information." soa @@ -151,39 +141,37 @@ ;;;-------------------------------------------------------------------------- ;;; Zone defaults. It is intended that scripts override these. -#+ecl -(cffi:defcfun gethostname :int - (name :pointer) - (len :uint)) - +(export '*default-zone-source*) (defvar *default-zone-source* - (let ((hn #+cmu (unix:unix-gethostname) - #+clisp (unix:get-host-name) - #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len) - (let ((rc (gethostname buffer len))) - (unless (zerop rc) - (error "gethostname(2) failed (rc = ~A)." rc)))))) + (let ((hn (gethostname))) (and hn (concatenate 'string (canonify-hostname hn) "."))) "The default zone source: the current host's name.") +(export '*default-zone-refresh*) (defvar *default-zone-refresh* (* 24 60 60) "Default zone refresh interval: one day.") +(export '*default-zone-admin*) (defvar *default-zone-admin* nil "Default zone administrator's email address.") +(export '*default-zone-retry*) (defvar *default-zone-retry* (* 60 60) "Default znoe retry interval: one hour.") +(export '*default-zone-expire*) (defvar *default-zone-expire* (* 14 24 60 60) "Default zone expiry time: two weeks.") +(export '*default-zone-min-ttl*) (defvar *default-zone-min-ttl* (* 4 60 60) "Default zone minimum TTL/negative TTL: four hours.") +(export '*default-zone-ttl*) (defvar *default-zone-ttl* (* 8 60 60) "Default zone TTL (for records without explicit TTLs): 8 hours.") +(export '*default-mx-priority*) (defvar *default-mx-priority* 50 "Default MX priority.") @@ -193,14 +181,15 @@ (defvar *zones* (make-hash-table :test #'equal) "Map of known zones.") +(export 'zone-find) (defun zone-find (name) "Find a zone given its NAME." (gethash (string-downcase (stringify name)) *zones*)) - (defun (setf zone-find) (zone name) "Make the zone NAME map to ZONE." (setf (gethash (string-downcase (stringify name)) *zones*) zone)) +(export 'zone-record) (defstruct (zone-record (:conc-name zr-)) "A zone record." (name ') @@ -209,6 +198,7 @@ (make-ptr-p nil) data) +(export 'zone-subdomain) (defstruct (zone-subdomain (:conc-name zs-)) "A subdomain. Slightly weird. Used internally by zone-process-records below, and shouldn't escape." @@ -216,9 +206,11 @@ ttl records) +(export '*zone-output-path*) (defvar *zone-output-path* *default-pathname-defaults* "Pathname defaults to merge into output files.") +(export '*preferred-subnets*) (defvar *preferred-subnets* nil "Subnets to prefer when selecting defaults.") @@ -231,15 +223,18 @@ :type (string-downcase type)) *zone-output-path*)) +(export 'zone-preferred-subnet-p) (defun zone-preferred-subnet-p (name) "Answer whether NAME (a string or symbol) names a preferred subnet." (member name *preferred-subnets* :test #'string-equal)) +(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))) @@ -256,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 @@ -282,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 @@ -305,6 +318,7 @@ (zs-ttl s)))))) (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." @@ -384,9 +398,12 @@ ;;;-------------------------------------------------------------------------- ;;; Serial numbering. +(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 @@ -404,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))))) @@ -414,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." @@ -444,6 +463,7 @@ :min-ttl (timespec-seconds min-ttl) :serial serial)))) +(export 'zone-make-name) (defun zone-make-name (prefix zone-name) (if (or (not prefix) (string= prefix "@")) zone-name @@ -452,13 +472,15 @@ (join-strings #\. (list prefix zone-name)) prefix)))) +(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. @@ -511,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) @@ -529,8 +554,11 @@ #'parse-record)) (setf (zone-records zone) (nconc (zone-records zone) rec))))) +(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* @@ -546,6 +574,7 @@ (zone-parse-records zone (cdr zf)) zone))) +(export 'zone-create) (defun zone-create (zf) "Zone construction function. Given a zone form ZF, construct the zone and add it to the table." @@ -554,10 +583,12 @@ (setf (zone-find name) zone) name)) +(export 'defzone) (defmacro defzone (soa &rest zf) "Zone definition macro." `(zone-create '(,soa ,@zf))) +(export 'defrevzone) (defmacro defrevzone (head &rest zf) "Define a reverse zone, with the correct name." (destructuring-bind @@ -587,6 +618,10 @@ ":cname HOST" (rec :data (zone-parse-host data zname))) +(defzoneparse :txt (name data rec) + ":txt TEXT" + (rec :data data)) + (defzoneparse :mx (name data rec :zname zname) ":mx ((HOST :prio INT :ip IPADDR)*)" (dolist (mx (listify data)) @@ -649,12 +684,16 @@ (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))))) (defzoneparse (:rev :reverse) (name data rec) - ":reverse ((NET :bytes BYTES) ZONE*)" + ":reverse ((NET :bytes BYTES) ZONE*) + + Add a reverse record each host in the ZONEs (or all zones) that lies + within NET. The BYTES give the number of prefix labels generated; this + defaults to the smallest number of bytes needed to enumerate the net." (setf data (listify data)) (destructuring-bind (net &key bytes) (listify (car data)) (setf net (zone-parse-net net name)) @@ -681,48 +720,62 @@ (setf (gethash name seen) t))))))))) (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname) - ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)" + ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*) + + Insert CNAME records for delegating a portion of the reverse-lookup + namespace which doesn't align with an octet boundary. + + The NET specifies the origin network, in which the reverse records + naturally lie. The BYTES are the number of labels to supply for each + address; the default is the smallest number which suffices to enumerate + the entire NET. The TARGET-NETs are subnets of NET which are to be + delegated. The TARGET-ZONEs are the zones to which we are delegating + authority for the reverse records: the default is to append labels for those + octets of the subnet base address which are not the same in all address in + the subnet." (setf data (listify data)) (destructuring-bind (net &key bytes) (listify (car data)) (setf net (zone-parse-net net name)) (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. +(export 'zone-write) (defgeneric zone-write (format zone stream) (:documentation "Write ZONE's records to STREAM in the specified FORMAT.")) @@ -733,10 +786,12 @@ "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))) +(export 'zone-save) (defun zone-save (zones &key (format :bind)) "Write the named ZONES to files. If no zones are given, write all the zones." @@ -754,6 +809,7 @@ ;;;-------------------------------------------------------------------------- ;;; Bind format output. +(export 'bind-hostname) (defun bind-hostname (hostname) (if (not hostname) "@" @@ -803,8 +859,10 @@ $TTL ~2@*~D~2%" (dolist (zr (zone-records zone)) (bind-record (zr-type zr) zr))) +(export 'bind-record) (defgeneric bind-record (type zr)) +(export 'bind-format-record) (defun bind-format-record (name ttl type format args) (format *zone-output-stream* "~A~20T~@[~8D~]~30TIN ~A~40T~?~%" @@ -822,9 +880,11 @@ $TTL ~2@*~D~2%" (bind-record-type type) format args))) +(export 'bind-record-type) (defgeneric bind-record-type (type) (:method (type) type)) +(export 'bind-record-format-args) (defgeneric bind-record-format-args (type data) (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data))) (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data))) @@ -835,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 --------------------------------------------------