X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/86d1b853ec49712cd658bb3ed36f73cd386a3da3..098b57a28b428a9f21b44098da374c79d866ed80:/zone.lisp diff --git a/zone.lisp b/zone.lisp index f313702..751baff 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; DNS zone generation ;;; ;;; (c) 2005 Straylight/Edgeware @@ -27,21 +25,9 @@ ;;; Packaging. (defpackage #:zone - (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net) - (: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)) + (:use #:common-lisp + #:mdw.base #:mdw.str #:collect #:safely + #:net #:services)) (in-package #:zone) @@ -73,6 +59,7 @@ (defun to-mixed-base (base val) (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 @@ (defun iso-date (&optional time &key datep timep (sep #\ )) ;;;-------------------------------------------------------------------------- ;;; Zone types. +(export 'soa) (defstruct (soa (:predicate soap)) "Start-of-authority record information." source @@ -134,11 +122,13 @@ (defstruct (soa (:predicate soap)) 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,39 +139,37 @@ (defstruct (zone (:predicate zonep)) ;;;-------------------------------------------------------------------------- ;;; 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.") @@ -191,14 +179,15 @@ (defvar *default-mx-priority* 50 (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 ') @@ -207,6 +196,7 @@ (defstruct (zone-record (:conc-name zr-)) (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." @@ -214,9 +204,11 @@ (defstruct (zone-subdomain (:conc-name zs-)) 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.") @@ -229,10 +221,12 @@ (defun zone-file-name (zone type) :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 @@ -303,6 +297,7 @@ (defun zone-process-records (rec ttl func) (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." @@ -382,6 +377,7 @@ (defun zone-cidr-delg-default-name (ipn bytes) ;;;-------------------------------------------------------------------------- ;;; 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." @@ -442,6 +438,7 @@ (defun zone-parse-head (head) :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 @@ -450,6 +447,7 @@ (defun zone-make-name (prefix zone-name) (join-strings #\. (list prefix zone-name)) prefix)))) +(export 'defzoneparse) (defmacro defzoneparse (types (name data list &key (prefix (gensym "PREFIX")) (zname (gensym "ZNAME")) @@ -498,6 +496,7 @@ (defun ,func (,prefix ,zname ,data ,ttl ,col) ((:data ,tdata) ,data) ((:ttl ,tttl) ,ttl) ((:make-ptr-p ,tmakeptrp) nil)) + #+cmu (declare (optimize ext:inhibit-warnings)) (collect (make-zone-record :name ,tname :type ,ttype :data ,tdata @@ -526,6 +525,7 @@ (defun zone-parse-records (zone records) #'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: @@ -543,6 +543,7 @@ (defun zone-parse (zf) (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." @@ -551,10 +552,12 @@ (defun zone-create (zf) (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 @@ -584,6 +587,10 @@ (defzoneparse :cname (name data rec :zname zname) ":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)) @@ -611,6 +618,31 @@ (defzoneparse :alias (name data rec :zname zname) :type :cname :data name))) +(defzoneparse :srv (name data rec :zname zname) + ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)" + (dolist (srv data) + (destructuring-bind (servopts &rest providers) srv + (destructuring-bind + (service &key ((:port default-port)) (protocol :tcp)) + (listify servopts) + (unless default-port + (let ((serv (serv-by-name service protocol))) + (setf default-port (and serv (serv-port serv))))) + (let ((rname (format nil "~(_~A._~A~).~A" service protocol name))) + (dolist (prov providers) + (destructuring-bind + (srvname + &key + (port default-port) + (prio *default-mx-priority*) + (weight 0) + ip) + (listify prov) + (let ((host (zone-parse-host srvname zname))) + (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (rec :name rname + :data (list prio weight port host)))))))))) + (defzoneparse :net (name data rec) ":net (NETWORK*)" (dolist (net (listify data)) @@ -621,16 +653,18 @@ (defzoneparse :net (name data rec) (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)) + (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)))) @@ -654,52 +688,63 @@ (defzoneparse (:rev :reverse) (name data rec) :ttl (zr-ttl zr) :data (zr-name zr)) (setf (gethash name seen) t))))))))) -(defzoneparse (:cidr-delegation :cidr) (name data rec) - ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)" - (destructuring-bind - (net &key bytes) - (listify (car data)) +(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname) + ":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 (cdr data)) - (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 + (dolist (map (or (cdr data) (list (list net)))) + (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 (logand #xff - (ash net (* -8 i))))) - (list name)))))) - (setf tdom (string-downcase tdom)) - (dotimes (i (ipnet-hosts tnet)) - (let* ((addr (ipnet-host tnet i)) - (tail (join-strings #\. - (loop - for i from 0 below bytes - collect + 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)))))))) + (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.")) @@ -714,6 +759,7 @@ (defmethod zone-write :around (format zone stream) (*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." @@ -731,6 +777,7 @@ (defun zone-save (zones &key (format :bind)) ;;;-------------------------------------------------------------------------- ;;; Bind format output. +(export 'bind-hostname) (defun bind-hostname (hostname) (if (not hostname) "@" @@ -780,8 +827,10 @@ (defmethod zone-write ((format (eql :bind)) zone stream) (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~?~%" @@ -799,9 +848,11 @@ (defmethod bind-record (type zr) (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))) @@ -809,6 +860,9 @@ (defgeneric bind-record-format-args (type data) (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data))) (:method ((type (eql :mx)) data) (list "~2D ~A" (cdr data) (bind-hostname (car data)))) + (: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)))) ;;;----- That's all, folks --------------------------------------------------