X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/8e7c1366598806dff2b2e4fb2016efb5a78f42ec..b23c65ee5879e401cf7e260e104d3d1f8f3a2266:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 8dc3df0..eaa0e2d 100644 --- a/zone.lisp +++ b/zone.lisp @@ -27,21 +27,7 @@ (defpackage #:zone (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely - #:net #:net-sys #: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) @@ -73,6 +59,7 @@ (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 @@ -124,6 +111,7 @@ ;;;-------------------------------------------------------------------------- ;;; Zone types. +(export 'soa) (defstruct (soa (:predicate soap)) "Start-of-authority record information." source @@ -134,11 +122,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 @@ -149,29 +139,37 @@ ;;;-------------------------------------------------------------------------- ;;; Zone defaults. It is intended that scripts override these. +(export '*default-zone-source*) (defvar *default-zone-source* (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.") @@ -181,14 +179,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 ') @@ -197,6 +196,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." @@ -204,9 +204,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.") @@ -219,10 +221,12 @@ :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 @@ -270,13 +274,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 @@ -293,6 +296,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." @@ -372,6 +376,7 @@ ;;;-------------------------------------------------------------------------- ;;; 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." @@ -392,8 +397,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))))) @@ -405,7 +410,7 @@ "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." @@ -432,6 +437,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 @@ -440,10 +446,11 @@ (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: @@ -517,6 +524,7 @@ #'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: @@ -534,6 +542,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." @@ -542,10 +551,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 @@ -575,6 +586,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)) @@ -637,12 +652,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)) @@ -669,48 +688,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.")) @@ -725,6 +758,7 @@ (*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." @@ -742,6 +776,7 @@ ;;;-------------------------------------------------------------------------- ;;; Bind format output. +(export 'bind-hostname) (defun bind-hostname (hostname) (if (not hostname) "@" @@ -791,8 +826,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~?~%" @@ -810,9 +847,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)))