X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/8a4f9a1858cade6284a71434dc7e6af21746699b..HEAD:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 90867ea..7649f54 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; DNS zone generation ;;; ;;; (c) 2005 Straylight/Edgeware @@ -13,341 +11,257 @@ ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. -;;; +;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. -;;; +;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;;-------------------------------------------------------------------------- +;;; Packaging. + (defpackage #:zone - (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:mdw.safely) - (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp - #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet - #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet - #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts - #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp - #:host-find# #:host-create #:defhost #:parse-ipaddr - #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet - #:net-next-host #:net-host - #: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-find #:zone-parse #:zone-write #:zone-create #:defzone - #:defrevzone #:zone-save - #:timespec-seconds #:make-zone-serial)) + (:use #:common-lisp + #:mdw.base #:mdw.str #:anaphora #:collect #:safely + #:net #:services) + (:import-from #:net #:round-down #:round-up)) + (in-package #:zone) -(defun mask (n) - "Return 2^N - 1: i.e., a mask of N set bits." - (1- (ash 1 n))) -(deftype u32 () - "The type of unsigned 32-bit values." - '(unsigned-byte 32)) -(deftype ipaddr () - "The type of IP (version 4) addresses." - 'u32) - -(defun string-ipaddr (str &key (start 0) (end nil)) - "Parse STR as an IP address in dotted-quad form and return the integer -equivalent. STR may be anything at all: it's converted as if by -`stringify'. The START and END arguments may be used to parse out a -substring." - (setf str (stringify str)) - (unless end - (setf end (length str))) - (let ((addr 0) (noct 0)) - (loop - (let* ((pos (position #\. str :start start :end end)) - (i (parse-integer str :start start :end (or pos end)))) - (unless (<= 0 i 256) - (error "IP address octet out of range")) - (setf addr (+ (* addr 256) i)) - (incf noct) - (unless pos - (return)) - (setf start (1+ pos)))) - (unless (= noct 4) - (error "Wrong number of octets in IP address")) - addr)) -(defun ipaddr-byte (ip n) - "Return byte N (from most significant downwards) of an IP address." - (assert (<= 0 n 3)) - (logand #xff (ash ip (* -8 (- 3 n))))) -(defun ipaddr-string (ip) - "Transform the address IP into a string in dotted-quad form." - (check-type ip ipaddr) - (join-strings #\. (collecting () - (dotimes (i 4) - (collect (ipaddr-byte ip i)))))) -(defun ipaddrp (ip) - "Answer true if IP is a valid IP address in integer form." - (typep ip 'ipaddr)) -(defun ipaddr (ip) - "Convert IP to an IP address. If it's an integer, return it unchanged; -otherwise convert by `string-ipaddr'." - (typecase ip - (ipaddr ip) - (t (string-ipaddr ip)))) - -(defun integer-netmask (i) - "Given an integer I, return a netmask with its I top bits set." - (- (ash 1 32) (ash 1 (- 32 i)))) -(defun ipmask (ip) - "Transform IP into a netmask. If it's a small integer then it's converted -by `integer-netmask'; if nil, then all-bits-set; otherwise convert using -`ipaddr'." - (typecase ip - (null (mask 32)) - ((integer 0 32) (integer-netmask ip)) - (t (ipaddr ip)))) -(defun ipmask-cidl-slash (mask) - "Given a netmask MASK, return an integer N such that (integer-netmask N) = -MASK, or nil if this is impossible." - (dotimes (i 33) - (when (= mask (integer-netmask i)) - (return i)))) - -(defun make-ipnet (net mask) - "Construct an IP-network object given the NET and MASK; these are -transformed as though by `ipaddr' and `ipmask'." - (let ((net (ipaddr net)) - (mask (ipmask mask))) - (cons (logand net mask) mask))) -(defun string-ipnet (str &key (start 0) (end nil)) - "Parse an IP-network from the string STR." - (setf str (stringify str)) - (unless end (setf end (length str))) - (let ((sl (position #\/ str :start start :end end))) - (if sl - (make-ipnet (parse-ipaddr (subseq str start sl)) - (if (find #\. str :start (1+ sl) :end end) - (string-ipaddr str :start (1+ sl) :end end) - (integer-netmask (parse-integer str - :start (1+ sl) - :end end)))) - (make-ipnet (parse-ipaddr (subseq str start end)) - (integer-netmask 32))))) -(defun ipnet (net &optional mask) - "Construct an IP-network object from the given arguments. A number of -forms are acceptable: - - * NET MASK -- as for `make-ipnet'. - * ADDR -- a single address (equivalent to ADDR 32) - * (NET . MASK|nil) -- a single-object representation. - * IPNET -- return an equivalent (`equal', not necessarily `eql') version." - (cond (mask (make-ipnet net mask)) - ((or (stringp net) (symbolp net)) (string-ipnet net)) - (t (apply #'make-ipnet (pairify net 32))))) -(defun ipnet-net (ipn) - "Return the base network address of IPN." - (car ipn)) -(defun ipnet-mask (ipn) - "Return the netmask of IPN." - (cdr ipn)) -(defmacro with-ipnet ((net mask) ipn &body body) - "Evaluate BODY with NET and MASK bound to the base address and netmask of -IPN. Either NET or MASK (or, less usefully, both) may be nil if not wanted." - (with-gensyms tmp - `(let ((,tmp ,ipn)) - (let (,@(and net `((,net (ipnet-net ,tmp)))) - ,@(and mask `((,mask (ipnet-mask ,tmp))))) - ,@body)))) -(defun ipnet-pretty (ipn) - "Convert IPN to a pretty cons-cell form." - (with-ipnet (net mask) ipn - (cons (ipaddr-string net) - (or (ipmask-cidl-slash mask) (ipaddr-string mask))))) -(defun ipnet-string (ipn) - "Convert IPN to a string." - (with-ipnet (net mask) ipn - (format nil "~A/~A" - (ipaddr-string net) - (or (ipmask-cidl-slash mask) (ipaddr-string mask))))) -(defun ipnet-broadcast (ipn) - "Return the broadcast address for the network IPN." - (with-ipnet (net mask) ipn - (logior net (logxor (mask 32) mask)))) -(defun ipnet-hosts (ipn) - "Return the number of available addresses in network IPN." - (ash 1 (- 32 (logcount (ipnet-mask ipn))))) -(defun ipnet-host (ipn host) - "Return the address of the given HOST in network IPN. This works even with -a non-contiguous netmask." - (check-type host u32) - (with-ipnet (net mask) ipn - (let ((i 0) (m 1) (a net) (h host)) - (loop - (when (>= i 32) - (error "Host index ~D out of range for network ~A" - host (ipnet-pretty ipn))) - (cond ((zerop h) - (return a)) - ((logbitp i mask) - (setf h (ash h 1))) - (t - (setf a (logior a (logand m h))) - (setf h (logandc2 h m)))) - (setf m (ash m 1)) - (incf i))))) -(defun ipaddr-networkp (ip ipn) - "Returns true if address IP is within network IPN." - (with-ipnet (net mask) ipn - (= net (logand ip mask)))) -(defun ipnet-subnetp (ipn subn) - "Returns true if SUBN is a (non-strict) subnet of IPN." - (with-ipnet (net mask) ipn - (with-ipnet (subnet submask) subn - (and (= net (logand subnet mask)) - (= submask (logior mask submask)))))) - -(defun resolve-hostname (name) - "Resolve a hostname to an IP address using the DNS, or return nil." - (let ((he (ext:lookup-host-entry name))) - (and he - (ext:host-entry-addr he)))) -(defun canonify-hostname (name) - "Resolve a hostname to canonical form using the DNS, or return nil." - (let ((he (ext:lookup-host-entry name))) - (and he - (ext:host-entry-name he)))) -(defun parse-ipaddr (addr) - "Convert the string ADDR into an IP address: tries all sorts of things: - - (NET [INDEX]) -- index a network: NET is a network name defined by defnet; - INDEX is an index or one of the special symbols understood by net-host, - and defaults to :next - INTEGER -- an integer IP address - IPADDR -- an IP address in dotted-quad form - HOST -- a host name defined by defhost - DNSNAME -- a name string to look up in the DNS" - (cond ((listp addr) - (destructuring-bind - (net host) - (pairify addr :next) - (net-host (or (net-find net) - (error "Network ~A not found" net)) - host))) - ((ipaddrp addr) addr) - (t - (setf addr (string-downcase (stringify addr))) - (or (host-find addr) - (and (plusp (length addr)) - (digit-char-p (char addr 0)) - (string-ipaddr addr)) - (resolve-hostname (stringify addr)) - (error "Host name ~A unresolvable" addr))))) - -(defvar *hosts* (make-hash-table :test #'equal) - "The table of known hostnames.") -(defun host-find (name) - "Find a host by NAME." - (gethash (string-downcase (stringify name)) *hosts*)) -(defun (setf host-find) (addr name) - "Make NAME map to ADDR (must be an ipaddr in integer form)." - (setf (gethash (string-downcase (stringify name)) *hosts*) addr)) -(defun host-create (name addr) - "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)." - (setf (host-find name) (parse-ipaddr addr))) -(defmacro defhost (name addr) - "Main host definition macro. Neither NAME nor ADDR is evaluated." - `(progn - (host-create ',name ',addr) - ',name)) - -(defstruct (net (:predicate netp)) - "A network structure. Slots: - -NAME The network's name, as a string -IPNET The network base address and mask -HOSTS Number of hosts in the network -NEXT Index of the next unassigned host" - name - ipnet - hosts - next) - -(defvar *networks* (make-hash-table :test #'equal) - "The table of known networks.") -(defun net-find (name) - "Find a network by NAME." - (gethash (string-downcase (stringify name)) *networks*)) -(defun (setf net-find) (net name) - "Make NAME map to NET." - (setf (gethash (string-downcase (stringify name)) *networks*) net)) -(defun net-get-as-ipnet (form) - "Transform FORM into an ipnet. FORM may be a network name, or something -acceptable to the ipnet function." - (let ((net (net-find form))) - (if net (net-ipnet net) - (ipnet form)))) -(defun net-create (name &rest args) - "Construct a new network called NAME and add it to the map. The ARGS -describe the new network, in a form acceptable to the ipnet function." - (let ((ipn (apply #'ipnet args))) - (setf (net-find name) - (make-net :name (string-downcase (stringify name)) - :ipnet ipn - :hosts (ipnet-hosts ipn) - :next 1)))) -(defmacro defnet (name &rest args) - "Main network definition macro. Neither NAME nor any of the ARGS is -evaluated." - `(progn - (net-create ',name ,@(mapcar (lambda (x) `',x) args)) - ',name)) -(defun net-next-host (net) - "Given a NET, return the IP address (as integer) of the next available -address in the network." - (unless (< (net-next net) (net-hosts net)) - (error "No more hosts left in network ~A" (net-name net))) - (let ((next (net-next net))) - (incf (net-next net)) - (net-host net next))) -(defun net-host (net host) - "Return the given HOST on the NEXT. HOST may be an index (in range, of -course), or one of the keywords: -:NEXT next host, as by net-next-host -:NET network base address -:BROADCAST network broadcast address" - (case host - (:next (net-next-host net)) - (:net (ipnet-net (net-ipnet net))) - (:broadcast (ipnet-broadcast (net-ipnet net))) - (t (ipnet-host (net-ipnet net) host)))) +;;;-------------------------------------------------------------------------- +;;; Various random utilities. + +(export '*zone-config*) +(defparameter *zone-config* nil + "A list of configuration variables. + + This is for the benefit of the frontend, which will dynamically bind them + so that input files can override them independently. Not intended for use + by users.") (defun to-integer (x) "Convert X to an integer in the most straightforward way." (floor (rational x))) -(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." - (cond ((null ts) 0) - ((realp ts) (floor ts)) - ((atom ts) - (error "Unknown timespec format ~A" ts)) - ((null (cdr ts)) - (timespec-seconds (car ts))) - (t (+ (to-integer (* (car ts) - (case (intern (string-upcase - (stringify (cadr ts))) - '#:zone) - ((s sec secs second seconds) 1) - ((m min mins minute minutes) 60) - ((h hr hrs hour hours) #.(* 60 60)) - ((d dy dys day days) #.(* 24 60 60)) - ((w wk wks week weeks) #.(* 7 24 60 60)) - ((y yr yrs year years) #.(* 365 24 60 60)) - (t (error "Unknown time unit ~A" - (cadr ts)))))) - (timespec-seconds (cddr ts)))))) +(defun from-mixed-base (base val) + "BASE is a list of the ranges for the `digits' of a mixed-base + representation. Convert VAL, a list of digits, into an integer." + (do ((base base (cdr base)) + (val (cdr val) (cdr val)) + (a (car val) (+ (* a (car base)) (car val)))) + ((or (null base) (null val)) a))) + +(defun to-mixed-base (base val) + "BASE is a list of the ranges for the `digits' of a mixed-base + representation. Convert VAL, an integer, into a list of digits." + (let ((base (reverse base)) + (a nil)) + (loop + (unless base + (push val a) + (return a)) + (multiple-value-bind (q r) (floor val (pop base)) + (push r a) + (setf val q))))) + +(let ((unit-scale (make-hash-table)) + (scales nil)) + + (dolist (item `(((:second :seconds :sec :secs :s) ,1) + ((:minute :minutes :min :mins :m) ,60) + ((:hour :hours :hr :hrs :h) ,(* 60 60)) + ((:day :days :dy :dys :d) ,(* 24 60 60)) + ((:week :weeks :wk :wks :w) ,(* 7 24 60 60)))) + (destructuring-bind + ((&whole units singular plural &rest hunoz) scale) item + (declare (ignore hunoz)) + (dolist (unit units) (setf (gethash unit unit-scale) scale)) + (push (cons scale (cons singular plural)) scales))) + (setf scales (sort scales #'> :key #'car)) + + (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." + (labels ((convert (acc ts) + (cond ((null ts) acc) + ((realp ts) (+ acc (floor ts))) + ((atom ts) (error "Unknown timespec format ~A" ts)) + (t + (destructuring-bind + (count &optional unit &rest tail) ts + (let ((scale + (acond ((null unit) 1) + ((gethash (intern (string-upcase + (stringify unit)) + :keyword) + unit-scale) + it) + (t + (error "Unknown time unit ~S" + unit))))) + (convert (+ acc (to-integer (* count scale))) + tail))))))) + (convert 0 ts))) + + (export 'seconds-timespec) + (defun seconds-timespec (secs) + "Convert a count of seconds to a time specification." + (let ((sign (if (minusp secs) -1 +1)) (secs (abs secs))) + (collecting () + (loop (cond ((zerop secs) + (unless (collected) (collect-append '(0 :seconds))) + (return)) + ((< secs 60) + (collect (* secs sign)) + (collect (if (= secs 1) :second :seconds)) + (return)) + (t + (let ((match (find secs scales :test #'>= :key #'car))) + (multiple-value-bind (quot rem) (floor secs (car match)) + (collect (* quot sign)) + (collect (if (= quot 1) (cadr match) (cddr match))) + (setf secs rem)))))))))) + +(defun hash-table-keys (ht) + "Return a list of the keys in hashtable HT." + (collecting () + (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." + (multiple-value-bind + (sec min hr day mon yr dow dstp tz) + (decode-universal-time (if (or (null time) (eq time :now)) + (get-universal-time) + time)) + (declare (ignore dow dstp tz)) + (with-output-to-string (s) + (when datep + (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day) + (when timep + (write-char sep s))) + (when timep + (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec))))) + +(deftype octet () '(unsigned-byte 8)) +(deftype octet-vector (&optional n) `(array octet (,n))) + +(defun decode-hex (hex &key (start 0) end) + "Decode a hexadecimal-encoded string, returning a vector of octets." + (let* ((end (or end (length hex))) + (len (- end start)) + (raw (make-array (floor len 2) :element-type 'octet))) + (unless (evenp len) + (error "Invalid hex string `~A' (odd length)" hex)) + (do ((i start (+ i 2))) + ((>= i end) raw) + (let ((high (digit-char-p (char hex i) 16)) + (low (digit-char-p (char hex (1+ i)) 16))) + (unless (and high low) + (error "Invalid hex string `~A' (bad digit)" hex)) + (setf (aref raw (/ (- i start) 2)) (+ (* 16 high) low)))))) + +(defun slurp-file (file &optional (element-type 'character)) + "Read and return the contents of FILE as a vector." + (with-open-file (in file :element-type element-type) + (let ((buf (make-array 1024 :element-type element-type)) + (pos 0)) + (loop + (let ((end (read-sequence buf in :start pos))) + (when (< end (length buf)) + (return (adjust-array buf end))) + (setf pos end + buf (adjust-array buf (* 2 pos)))))))) + +(defmacro defenum (name (&key export) &body values) + "Set up symbol properties for manifest constants. + + The VALUES are a list of (TAG VALUE) pairs. Each TAG is a symbol; we set + the NAME property on TAG to VALUE, and export TAG. There are also handy + hash-tables mapping in the forward and reverse directions, in the name + symbol's `enum-forward' and `enum-reverse' properties." + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,(let*/gensyms (export) + (with-gensyms (forward reverse valtmp) + `(let ((,forward (make-hash-table)) + (,reverse (make-hash-table))) + (when ,export (export ',name)) + ,@(mapcar (lambda (item) + (destructuring-bind (tag value) item + (let ((constant + (intern (concatenate 'string + (symbol-name name) + "/" + (symbol-name tag))))) + `(let ((,valtmp ,value)) + (when ,export + (export ',constant) + (when (eq (symbol-package ',tag) *package*) + (export ',tag))) + (defconstant ,constant ,valtmp) + (setf (get ',tag ',name) ,value + (gethash ',tag ,forward) ,valtmp + (gethash ,valtmp ,reverse) ',tag))))) + values) + (setf (get ',name 'enum-forward) ,forward + (get ',name 'enum-reverse) ,reverse)))))) + +(defun lookup-enum (name tag &key min max) + "Look up a TAG in an enumeration. + + If TAG is a symbol, check its NAME property; if it's a fixnum then take it + as it is. Make sure that it's between MIN and MAX, if they're not nil." + (let ((value (etypecase tag + (fixnum tag) + (symbol (or (get tag name) + (error "~S is not a known ~A" tag name)))))) + (unless (and (or (null min) (<= min value)) + (or (null max) (<= value max))) + (error "Value ~S out of range for ~A" value name)) + value)) + +(defun reverse-enum (name value) + "Reverse-lookup of a VALUE in enumeration NAME. + + If a tag for the VALUE is found, return it and `t'; otherwise return VALUE + unchanged and `nil'." + (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse)) + (if foundp + (values tag t) + (values value nil)))) + +(defun mapenum (func name) + "Call FUNC on TAG/VALUE pairs from the enumeration called NAME." + (maphash func (get name 'enum-forward))) + +(defun hash-file (hash file context) + "Hash the FILE using the OpenSSL HASH function, returning an octet string. + + CONTEXT is a temporary-files context." + (let ((temp (temporary-file context "hash"))) + (run-program (list "openssl" "dgst" (concatenate 'string "-" hash)) + :input file :output temp) + (with-open-file (in temp) + (let ((line (read-line in))) + (assert (and (>= (length line) 9) + (string= line "(stdin)= " :end1 9))) + (decode-hex line :start 9))))) + +;;;-------------------------------------------------------------------------- +;;; Zone types. + +(export 'soa) (defstruct (soa (:predicate soap)) "Start-of-authority record information." source @@ -357,10 +271,14 @@ units." expire min-ttl serial) + +(export 'mx) (defstruct (mx (:predicate mxp)) "Mail-exchange record information." priority domain) + +(export 'zone) (defstruct (zone (:predicate zonep)) "Zone information." soa @@ -368,49 +286,166 @@ units." name records) +(export 'zone-text-name) +(defun zone-text-name (zone) + (princ-to-string (zone-name zone))) + +;;;-------------------------------------------------------------------------- +;;; Zone defaults. It is intended that scripts override these. + +(export '*default-zone-source*) (defvar *default-zone-source* - (let ((hn (unix:unix-gethostname))) + (let ((hn (gethostname))) (and hn (concatenate 'string (canonify-hostname hn) "."))) "The default zone source: the current host's name.") -(defvar *default-zone-refresh* (* 24 60 60) - "Default zone refresh interval: one day.") + +(export '*default-zone-refresh*) +(defvar *default-zone-refresh* '(8 :hours) + "Default zone refresh interval: eight hours.") + +(export '*default-zone-admin*) (defvar *default-zone-admin* nil "Default zone administrator's email address.") -(defvar *default-zone-retry* (* 60 60) - "Default znoe retry interval: one hour.") -(defvar *default-zone-expire* (* 14 24 60 60) - "Default zone expiry time: two weeks.") -(defvar *default-zone-min-ttl* (* 4 60 60) - "Default zone minimum TTL/negative TTL: four hours.") -(defvar *default-zone-ttl* (* 8 60 60) - "Default zone TTL (for records without explicit TTLs): 8 hours.") + +(export '*default-zone-retry*) +(defvar *default-zone-retry* '(20 :minutes) + "Default zone retry interval: twenty minutes.") + +(export '*default-zone-expire*) +(defvar *default-zone-expire* '(3 :days) + "Default zone expiry time: three days.") + +(export '*default-zone-min-ttl*) +(defvar *default-zone-min-ttl* '(4 :hours) + "Default zone minimum/negative TTL: four hours.") + +(export '*default-zone-ttl*) +(defvar *default-zone-ttl* '(4 :hours) + "Default zone TTL (for records without explicit TTLs): four hours.") + +(export '*default-mx-priority*) (defvar *default-mx-priority* 50 "Default MX priority.") -(defun from-mixed-base (base val) - "BASE is a list of the ranges for the `digits' of a mixed-base -representation. Convert VAL, a list of digits, into an integer." - (do ((base base (cdr base)) - (val (cdr val) (cdr val)) - (a (car val) (+ (* a (car base)) (car val)))) - ((or (null base) (null val)) a))) -(defun to-mixed-base (base val) - "BASE is a list of the ranges for the `digits' of a mixed-base -representation. Convert VAL, an integer, into a list of digits." - (let ((base (reverse base)) - (a nil)) - (loop - (unless base - (push val a) - (return a)) - (multiple-value-bind (q r) (floor val (pop base)) - (push r a) - (setf val q))))) +;;;-------------------------------------------------------------------------- +;;; Zone variables and structures. +(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 ') + ttl + type + (make-ptr-p nil) + data) + +(export 'zone-subdomain) +(defstruct (zone-subdomain (:conc-name zs-)) + "A subdomain. + + Slightly weird. Used internally by `zone-process-records', and shouldn't + escape." + name + ttl + records) + +(export '*zone-output-path*) +(defvar *zone-output-path* nil + "Pathname defaults to merge into output files. + + If this is nil then use the prevailing `*default-pathname-defaults*'. + This is not the same as capturing the `*default-pathname-defaults*' from + load time.") + +(export '*preferred-subnets*) +(defvar *preferred-subnets* nil + "Subnets to prefer when selecting defaults.") + +;;;-------------------------------------------------------------------------- +;;; Zone infrastructure. + +(defun zone-file-name (zone type) + "Choose a file name for a given ZONE and TYPE." + (merge-pathnames (make-pathname :name (string-downcase zone) + :type (string-downcase type)) + (or *zone-output-path* *default-pathname-defaults*))) + +(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) + "Execute a form based on which networks are considered preferred. + + 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))) + (cons (cond ((eq subnets t) + t) + ((listp subnets) + `(or ,@(mapcar (lambda (subnet) + `(zone-preferred-subnet-p + ',subnet)) + subnets))) + (t + `(zone-preferred-subnet-p ',subnets))) + (cdr clause)))) + clauses))) + +(export 'zone-parse-host) +(defun zone-parse-host (form &optional tail) + "Parse a host name FORM from a value in a zone form. + + The underlying parsing is done using `parse-domain-name'. Here, we + interpret various kinds of Lisp object specially. In particular: `nil' + refers to the TAIL zone (just like a plain `@'); and a symbol is downcased + before use." + (let ((name (etypecase form + (null (make-domain-name :labels nil :absolutep nil)) + (domain-name form) + (symbol (parse-domain-name (string-downcase form))) + (string (parse-domain-name form))))) + (if (null tail) name + (domain-name-concat name tail)))) + +(export 'zone-records-sorted) +(defun zone-records-sorted (zone) + "Return the ZONE's records, in a pleasant sorted order." + (sort (copy-seq (zone-records zone)) + (lambda (zr-a zr-b) + (multiple-value-bind (precp follp) + (domain-name< (zr-name zr-a) (zr-name zr-b)) + (cond (precp t) + (follp nil) + (t (string< (zr-type zr-a) (zr-type zr-b)))))))) + +;;;-------------------------------------------------------------------------- +;;; 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." - (let* ((file (format nil "~(~A~).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." + (let* ((file (zone-file-name name :serial)) (last (with-open-file (in file :direction :input :if-does-not-exist nil) @@ -427,40 +462,57 @@ carefully) update a file ZONE.serial in the current directory." (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))))) -(defvar *zones* (make-hash-table :test #'equal) - "Map of known zones.") -(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)) +;;;-------------------------------------------------------------------------- +;;; Zone form parsing. -(defstruct (zone-record (:conc-name zr-)) - "A zone record." - (name ') - ttl - type - (defsubp nil) - data) +(defun zone-process-records (rec ttl func) + "Sort out the list of records in REC, calling FUNC for each one. -(defstruct (zone-subdomain (:conc-name zs-)) - "A subdomain. Slightly weird. Used internally by zone-process-records -below, and shouldn't escape." - name - ttl - records) + TTL is the default time-to-live for records which don't specify one. + + 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). + + 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. + + ((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 + + (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." -(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." (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 @@ -475,218 +527,70 @@ the default time-to-live for records which don't specify one." top)) ((listp r) (dolist (name (listify (car r))) - (collect (make-zone-subdomain :name name - :ttl ttl - :records (cdr r)) + (collect (make-zone-subdomain + :name (zone-parse-host name) + :ttl ttl :records (cdr r)) sub))) (t - (error "Unexpected record form ~A" (car r)))))))) - (process (rec dom ttl defsubp) + (error "Unexpected record form ~A" 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 ((s (pop sub))) - (process (zs-records s) - dom - (zs-ttl s) - defsubp) - (process (zs-records s) - (cons (zs-name s) dom) - (zs-ttl s) - t)) - (let ((name (and dom - (string-downcase - (join-strings #\. (reverse dom)))))) - (dolist (zr top) - (setf (zr-name zr) name) - (setf (zr-defsubp zr) defsubp) - (funcall func zr)))) + (let ((preferred + (or (find-if + (lambda (s) + (let ((ll (domain-name-labels (zs-name s)))) + (and (consp ll) (null (cdr ll)) + (zone-preferred-subnet-p (car ll))))) + sub) + (car sub)))) + (when preferred + (process (zs-records preferred) + dom + (zs-ttl preferred)))) + (let ((name dom)) + (dolist (zr top) + (setf (zr-name zr) name) + (funcall func zr)))) (dolist (s sub) (process (zs-records s) - (cons (zs-name s) dom) - (zs-ttl s) - defsubp))))) - (process rec nil ttl nil))) - -(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." - (setf f (stringify f)) - (cond ((string= f "@") (stringify zname)) - ((and (plusp (length f)) - (char= (char f (1- (length f))) #\.)) - (string-downcase (subseq f 0 (1- (length f))))) - (t (string-downcase (concatenate 'string f "." - (stringify zname)))))) -(defun ipnet-changeable-bytes (mask) - "Answers how many low-order bytes of MASK are (entirely or partially) -changeable. This is used when constructing reverse zones." - (dotimes (i 4 4) - (when (/= (ipaddr-byte mask i) 255) - (return (- 4 i))))) -(defun default-rev-zone (base bytes) - (join-strings #\. (collecting () - (loop for i from (- 3 bytes) downto 0 - do (collect (ipaddr-byte base i))) - (collect "in-addr.arpa")))) - -(defun zone-name-from-net (net &optional bytes) - "Given a NET, and maybe the BYTES to use, convert to the appropriate -subdomain of in-addr.arpa." - (let ((ipn (net-get-as-ipnet net))) - (with-ipnet (net mask) ipn - (unless bytes - (setf bytes (- 4 (ipnet-changeable-bytes mask)))) - (join-strings #\. - (append (loop - for i from (- 4 bytes) below 4 - collect (logand #xff (ash net (* -8 i)))) - (list "in-addr.arpa")))))) - -(defun zone-net-from-name (name) - "Given a NAME in the in-addr.arpa space, convert it to an ipnet." - (let* ((name (string-downcase (stringify name))) - (len (length name)) - (suffix ".in-addr.arpa") - (sufflen (length suffix)) - (addr 0) - (n 0) - (end (- len sufflen))) - (unless (and (> len sufflen) - (string= name suffix :start1 end)) - (error "`~A' not in ~A." name suffix)) - (loop - with start = 0 - for dot = (position #\. name :start start :end end) - for byte = (parse-integer name - :start start - :end (or dot end)) - do (setf addr (logior addr (ash byte (* 8 n)))) - (incf n) - when (>= n 4) - do (error "Can't deduce network from ~A." name) - while dot - do (setf start (1+ dot))) - (setf addr (ash addr (* 8 (- 4 n)))) - (make-ipnet addr (* 8 n)))) - -(defun zone-reverse-records (records net list bytes dom) - "Construct a reverse zone given a forward zone's RECORDS list, the NET that -the reverse zone is to serve, a LIST to collect the records into, how -many BYTES of data need to end up in the zone, and the DOM-ain suffix." - (dolist (zr records) - (when (and (eq (zr-type zr) :a) - (not (zr-defsubp zr)) - (ipaddr-networkp (zr-data zr) net)) - (collect (make-zone-record - :name (string-downcase - (join-strings - #\. - (collecting () - (dotimes (i bytes) - (collect (logand #xff (ash (zr-data zr) - (* -8 i))))) - (collect dom)))) - :type :ptr - :ttl (zr-ttl zr) - :data (zr-name zr)) - list)))) - -(defun zone-reverse (data name list) - "Process a :reverse record's DATA, for a domain called NAME, and add the -records to the LIST." - (destructuring-bind - (net &key bytes zones) - (listify data) - (setf net (zone-parse-net net name)) - (dolist (z (or (listify zones) - (hash-table-keys *zones*))) - (zone-reverse-records (zone-records (zone-find z)) - net - list - (or bytes - (ipnet-changeable-bytes (ipnet-mask net))) - name)))) - -(defun zone-parse-net (net name) - "Given a NET, and the NAME of a domain to guess from if NET is null, -return the ipnet for the network." - (if net - (net-get-as-ipnet net) - (zone-net-from-name name))) - -(defun zone-cidr-delg-default-name (ipn bytes) - "Given a delegated net IPN and the parent's number of changing BYTES, -return the default deletate zone prefix." - (with-ipnet (net mask) ipn - (join-strings #\. - (reverse - (loop - for i from (1- bytes) downto 0 - until (zerop (logand mask (ash #xff (* 8 i)))) - collect (logand #xff (ash net (* -8 i)))))))) - -(defun zone-cidr-delegation (data name ttl list) - "Given :cidr-delegation info DATA, for a record called NAME and the current -TTL, write lots of CNAME records to LIST." - (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 - (setf tdom - (join-strings #\. - (list (zone-cidr-delg-default-name tnet bytes) - 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 - (logand #xff - (ash addr (* 8 i))))))) - (collect (make-zone-record - :name (join-strings #\. - (list tail name)) - :type :cname - :ttl ttl - :data (join-strings #\. (list tail tdom))) - list))))))) - - + (if (null dom) (zs-name s) + (domain-name-concat dom (zs-name s))) + (zs-ttl s)))))) + + ;; Process the records we're given with no prefix. + (process rec nil ttl))) (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." + though a singleton NAME needn't be a list. Returns the default TTL and an + soa structure representing the zone head." (destructuring-bind - (zname + (raw-zname &key (source *default-zone-source*) (admin (or *default-zone-admin* - (format nil "hostmaster@~A" zname))) + (format nil "hostmaster@~A" raw-zname))) (refresh *default-zone-refresh*) (retry *default-zone-retry*) (expire *default-zone-expire*) (min-ttl *default-zone-min-ttl*) - (ttl min-ttl) - (serial (make-zone-serial zname))) + (ttl *default-zone-ttl*) + (serial (make-zone-serial raw-zname)) + &aux + (zname (zone-parse-host raw-zname root-domain))) (listify head) (values zname (timespec-seconds ttl) @@ -698,94 +602,756 @@ soa structure representing the zone head." :min-ttl (timespec-seconds min-ttl) :serial serial)))) -(defun hash-table-keys (ht) - "Return a list of the keys in hashtable HT." - (collecting () - (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht))) - +(export 'defzoneparse) (defmacro defzoneparse (types (name data list - &key (zname (gensym "ZNAME")) - (ttl (gensym "TTL")) - (defsubp (gensym "DEFSUBP"))) + &key (prefix (gensym "PREFIX")) + (zname (gensym "ZNAME")) + (ttl (gensym "TTL"))) &body body) + "Define a new zone record type. + + The arguments are as follows: + + TYPES A singleton type symbol, or a list of aliases. + + NAME The name of the record to be added. + + DATA The content of the record to be added (a single object, + unevaluated). + + LIST A function to add a record to the zone. See below. + + PREFIX The prefix tag used in the original form. + + ZNAME The name of the zone being constructed. + + TTL The TTL for this record. + + You get to choose your own names for these. ZNAME, PREFIX and TTL are + optional: you don't have to accept them if you're not interested. + + The LIST argument names a function to be bound in the body to add a new + low-level record to the zone. It has the prototype + + (LIST &key :name :type :data :ttl :make-ptr-p) + + These (except MAKE-PTR-P, which defaults to nil) default to the above + arguments (even if you didn't accept the arguments)." + (setf types (listify types)) (let* ((type (car types)) (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type)))) - (with-gensyms (col tname ttype tttl tdata tdefsubp i) - `(progn - (dolist (,i ',types) - (setf (get ,i 'zone-parse) ',func)) - (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp) - (declare (ignorable ,zname ,defsubp)) - (flet ((,list (&key ((:name ,tname) ,name) - ((:type ,ttype) ,type) - ((:data ,tdata) ,data) - ((:ttl ,tttl) ,ttl) - ((:defsubp ,tdefsubp) nil)) - (collect (make-zone-record :name ,tname - :type ,ttype - :data ,tdata - :ttl ,tttl - :defsubp ,tdefsubp) - ,col))) - ,@body)) - ',type)))) - -(defun zone-parse-records (zone records) - (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))))) - (if (or (not name) - (string= name "@")) - (setf name zname) - (let ((len (length name))) - (if (or (zerop len) - (char/= (char name (1- len)) #\.)) - (setf name (join-strings #\. - (list name zname)))))) - (funcall func - name - (zr-data zr) - (zr-ttl zr) - rec - zname - (zr-defsubp zr))))) - (zone-process-records records - (zone-default-ttl zone) - #'parse-record )) - (setf (zone-records zone) (nconc (zone-records zone) rec))))) + (with-parsed-body (body decls doc) body + (with-gensyms (col tname ttype tttl tdata tmakeptrp i) + `(progn + (dolist (,i ',types) + (setf (get ,i 'zone-parse) ',func)) + (defun ,func (,prefix ,zname ,data ,ttl ,col) + ,@doc + ,@decls + (let ((,name (if (null ,prefix) ,zname + (domain-name-concat ,prefix ,zname)))) + (flet ((,list (&key ((:name ,tname) ,name) + ((:type ,ttype) ,type) + ((: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 + :ttl ,tttl + :make-ptr-p ,tmakeptrp) + ,col))) + ,@body))) + ',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) (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: + "Parse a ZONE form. + + The syntax of a zone form is as follows: -ZONE-FORM: - ZONE-HEAD ZONE-RECORD* + ZONE-FORM: + ZONE-HEAD ZONE-RECORD* -ZONE-RECORD: - ((NAME*) ZONE-RECORD*) -| SYM ARGS" + ZONE-RECORD: + ((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))) - -(defzoneparse :a (name data rec :defsubp defsubp) + (make-zone :name zname + :default-ttl ttl + :soa soa + :records (zone-parse-records zname ttl (cdr zf))))) + +(export 'zone-create) +(defun zone-create (zf) + "Zone construction function. + + Given a zone form ZF, construct the zone and add it to the table." + (let* ((zone (zone-parse zf)) + (name (zone-text-name zone))) + (setf (zone-find name) zone) + name)) + +(export 'defzone) +(defmacro defzone (soa &body zf) + "Zone definition macro." + `(zone-create '(,soa ,@zf))) + +(export '*address-family*) +(defvar *address-family* t + "The default address family. This is bound by `defrevzone'.") + +(export 'defrevzone) +(defmacro defrevzone (head &body zf) + "Define a reverse zone, with the correct name." + (destructuring-bind (nets &rest args + &key (family '*address-family*) + prefix-bits + &allow-other-keys) + (listify head) + (with-gensyms (ipn) + `(dolist (,ipn (net-parse-to-ipnets ',nets ,family)) + (let ((*address-family* (ipnet-family ,ipn))) + (zone-create `((,(format nil "~A" (reverse-domain ,ipn + ,prefix-bits)) + ,@',(loop for (k v) on args by #'cddr + unless (member k + '(:family :prefix-bits)) + nconc (list k v))) + ,@',zf))))))) + +(export 'map-host-addresses) +(defun map-host-addresses (func addr &key (family *address-family*)) + "Call FUNC for each address denoted by ADDR (a `host-parse' address)." + + (dolist (a (host-addrs (host-parse addr family))) + (funcall func a))) + +(export 'do-host) +(defmacro do-host ((addr spec &key (family *address-family*)) &body body) + "Evaluate BODY, binding ADDR to each address denoted by SPEC." + `(dolist (,addr (host-addrs (host-parse ,spec ,family))) + ,@body)) + +(export 'zone-set-address) +(defun zone-set-address (rec addrspec &rest args + &key (family *address-family*) name ttl make-ptr-p) + "Write records (using REC) defining addresses for ADDRSPEC." + (declare (ignore name ttl make-ptr-p)) + (let ((key-args (loop for (k v) on args by #'cddr + unless (eq k :family) + nconc (list k v)))) + (do-host (addr addrspec :family family) + (apply rec :type (ipaddr-rrtype addr) :data addr key-args)))) + +;;;-------------------------------------------------------------------------- +;;; Building raw record vectors. + +(defvar *record-vector* nil + "The record vector under construction.") + +(defun rec-ensure (n) + "Ensure that at least N octets are spare in the current record." + (let ((want (+ n (fill-pointer *record-vector*))) + (have (array-dimension *record-vector* 0))) + (unless (<= want have) + (adjust-array *record-vector* + (do ((new (* 2 have) (* 2 new))) + ((<= want new) new)))))) + +(export 'rec-octet-vector) +(defun rec-octet-vector (vector &key (start 0) end) + "Copy (part of) the VECTOR to the output." + (let* ((end (or end (length vector))) + (len (- end start))) + (rec-ensure len) + (do ((i start (1+ i))) + ((>= i end)) + (vector-push (aref vector i) *record-vector*)))) + +(export 'rec-byte) +(defun rec-byte (octets value) + "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record." + (rec-ensure octets) + (do ((i (1- octets) (1- i))) + ((minusp i)) + (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*))) + +(export 'rec-u8) +(defun rec-u8 (value) + "Append an 8-bit VALUE to the current record." + (rec-byte 1 value)) + +(export 'rec-u16) +(defun rec-u16 (value) + "Append a 16-bit VALUE to the current record." + (rec-byte 2 value)) + +(export 'rec-u32) +(defun rec-u32 (value) + "Append a 32-bit VALUE to the current record." + (rec-byte 4 value)) + +(export 'rec-raw-string) +(defun rec-raw-string (s &key (start 0) end) + "Append (a substring of) a raw string S to the current record. + + No arrangement is made for reporting the length of the string. That must + be done by the caller, if necessary." + (setf-default end (length s)) + (rec-ensure (- end start)) + (do ((i start (1+ i))) + ((>= i end)) + (vector-push (char-code (char s i)) *record-vector*))) + +(export 'rec-string) +(defun rec-string (s &key (start 0) end (max 255)) + (let* ((end (or end (length s))) + (len (- end start))) + (unless (<= len max) + (error "String `~A' too long" (subseq s start end))) + (rec-u8 (- end start)) + (rec-raw-string s :start start :end end))) + +(export 'rec-name) +(defun rec-name (name) + "Append a domain NAME. + + No attempt is made to perform compression of the name." + (dolist (label (reverse (domain-name-labels name))) + (rec-string label :max 63)) + (rec-u8 0)) + +(export 'build-record) +(defmacro build-record (&body body) + "Build a raw record, and return it as a vector of octets." + `(let ((*record-vector* (make-array 256 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t))) + ,@body + (copy-seq *record-vector*))) + +(export 'zone-record-rrdata) +(defgeneric zone-record-rrdata (type zr) + (:documentation "Emit (using the `build-record' protocol) RRDATA for ZR. + + The TYPE is a keyword naming the record type. Return the numeric RRTYPE + code.")) + +;;;-------------------------------------------------------------------------- +;;; Zone record parsers. + +(defzoneparse :a (name data rec) ":a IPADDR" - (rec :data (parse-ipaddr data) :defsubp defsubp)) + (zone-set-address #'rec data :make-ptr-p t :family :ipv4)) + +(defmethod zone-record-rrdata ((type (eql :a)) zr) + (rec-u32 (ipaddr-addr (zr-data zr))) + 1) + +(defzoneparse :aaaa (name data rec) + ":aaaa IPADDR" + (zone-set-address #'rec data :make-ptr-p t :family :ipv6)) + +(defmethod zone-record-rrdata ((type (eql :aaaa)) zr) + (rec-byte 16 (ipaddr-addr (zr-data zr))) + 28) + +(defzoneparse :addr (name data rec) + ":addr IPADDR" + (zone-set-address #'rec data :make-ptr-p t)) + +(defzoneparse :svc (name data rec) + ":svc IPADDR" + (zone-set-address #'rec data)) + (defzoneparse :ptr (name data rec :zname zname) ":ptr HOST" (rec :data (zone-parse-host data zname))) + +(defmethod zone-record-rrdata ((type (eql :ptr)) zr) + (rec-name (zr-data zr)) + 12) + (defzoneparse :cname (name data rec :zname zname) ":cname HOST" (rec :data (zone-parse-host data zname))) + +(defzoneparse :dname (name data rec :zname zname) + ":dname HOST" + (rec :data (zone-parse-host data zname))) + +(defmethod zone-record-rrdata ((type (eql :cname)) zr) + (rec-name (zr-data zr)) + 5) + +(defun split-txt-data (data) + "Split the string DATA into pieces small enough to fit in a TXT record. + + Return a list of strings L such that (a) (apply #'concatenate 'string L) + is equal to the original string DATA, and (b) (every (lambda (s) (<= + (length s) 255)) L) is true." + (collecting () + (let ((i 0) (n (length data))) + (loop + (let ((end (+ i 255))) + (when (<= n end) (return)) + (let ((split (acond ((position #\; data :from-end t + :start i :end end) + (+ it 1)) + ((position #\space data :from-end t + :start i :end end) + (+ it 1)) + (t end)))) + (loop + (when (or (>= split end) + (char/= (char data split) #\space)) + (return)) + (incf split)) + (collect (subseq data i split)) + (setf i split)))) + (collect (subseq data i))))) + +(defzoneparse :txt (name data rec) + ":txt (TEXT*)" + (rec :data (cond ((stringp data) (split-txt-data data)) + (t + (dolist (piece data) + (unless (<= (length piece) 255) + (error "`:txt' record piece `~A' too long" piece))) + data)))) + +(defmethod zone-record-rrdata ((type (eql :txt)) zr) + (mapc #'rec-string (zr-data zr)) + 16) + +(defzoneparse :spf (name data rec :zname zname) + ":spf ([[ (:version STRING) | + ({:pass | :fail | :soft | :shrug} + {:all | + :include LABEL | + :a [[ :label LABEL | :v4mask MASK | :v6mask MASK ]] | + :ptr [LABEL] | + {:ip | :ip4 | :ip6} {STRING | NET | HOST}}) | + (:redirect LABEL) | + (:exp LABEL) ]])" + (rec :type :txt + :data + (split-txt-data + (with-output-to-string (out) + (let ((firstp t)) + (dolist (item data) + (if firstp (setf firstp nil) + (write-char #\space out)) + (let ((head (car item)) + (tail (cdr item))) + (ecase head + (:version (destructuring-bind (ver) tail + (format out "v=~A" ver))) + ((:pass :fail :soft :shrug) + (let ((qual (ecase head + (:pass #\+) + (:fail #\-) + (:soft #\~) + (:shrug #\?)))) + (setf head (pop tail)) + (ecase head + (:all + (destructuring-bind () tail + (format out "~Aall" qual))) + ((:include :exists) + (destructuring-bind (label) tail + (format out "~A~(~A~):~A" + qual head + (if (stringp label) label + (zone-parse-host label zname))))) + ((:a :mx) + (destructuring-bind (&key label v4mask v6mask) tail + (format out "~A~(~A~)~@[:~A~]~@[/~D~]~@[//~D~]" + qual head + (cond ((null label) nil) + ((stringp label) label) + (t (zone-parse-host label zname))) + v4mask + v6mask))) + (:ptr + (destructuring-bind (&optional label) tail + (format out "~Aptr~@[:~A~]" + qual + (cond ((null label) nil) + ((stringp label) label) + (t (zone-parse-host label zname)))))) + ((:ip :ip4 :ip6) + (let* ((family (ecase head + (:ip t) + (:ip4 :ipv4) + (:ip6 :ipv6))) + (nets + (collecting () + (dolist (net tail) + (acond + ((host-find net) + (let ((any nil)) + (dolist (addr (host-addrs it)) + (when (or (eq family t) + (eq family + (ipaddr-family addr))) + (setf any t) + (collect (make-ipnet + addr + (ipaddr-width addr))))) + (unless any + (error + "No matching addresses for `~A'" + net)))) + (t + (collect-append + (net-parse-to-ipnets net family)))))))) + (setf firstp t) + (dolist (net nets) + (if firstp (setf firstp nil) + (write-char #\space out)) + (let* ((width (ipnet-width net)) + (mask (ipnet-mask net)) + (plen (ipmask-cidr-slash width mask))) + (unless plen + (error "invalid netmask in network ~A" net)) + (format out "~A~A:~A~@[/~D~]" + qual + (ecase (ipnet-family net) + (:ipv4 "ip4") + (:ipv6 "ip6")) + (ipnet-net net) + (and (/= plen width) plen))))))))) + ((:redirect :exp) + (destructuring-bind (label) tail + (format out "~(~A~)=~A" + head + (if (stringp label) label + (zone-parse-host label zname))))))))))))) + + +(export '*dkim-pathname-defaults*) +(defvar *dkim-pathname-defaults* + (make-pathname :directory '(:relative "keys") + :type "dkim")) +(pushnew '*dkim-pathname-defaults* *zone-config*) + +(defzoneparse :dkim (name data rec) + ":dkim (KEYFILE {:TAG VALUE}*)" + (destructuring-bind (file &rest plist) (listify data) + (rec :type :txt + :data + (split-txt-data + (with-output-to-string (out) + (format out "~{~(~A~)=~A; ~}" plist) + (write-string "p=" out) + (when file + (with-open-file + (in (merge-pathnames file *dkim-pathname-defaults*)) + (loop + (when (string= (read-line in) + "-----BEGIN PUBLIC KEY-----") + (return))) + (loop + (let ((line (read-line in))) + (when (string= line "-----END PUBLIC KEY-----") + (return)) + (write-string line out)))))))))) + +(defzoneparse :dmarc (name data rec) + ":dmarc ({:TAG VALUE}*)" + (rec :type :txt + :data (split-txt-data (format nil "~{~(~A~)=~A~^; ~}" data)))) + +(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3) (:ed25519 4)) +(defenum sshfp-type () (:sha-1 1) (:sha-256 2)) + +(export '*sshfp-pathname-defaults*) +(defvar *sshfp-pathname-defaults* + (make-pathname :directory '(:relative "keys") :type "sshfp") + "Default pathname components for SSHFP records.") +(pushnew '*sshfp-pathname-defaults* *zone-config*) + +(defzoneparse :sshfp (name data rec) + ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }" + (typecase data + ((or string pathname) + (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))) + (pop words) + (when (string= (car words) "IN") (pop words)) + (unless (and (string= (car words) "SSHFP") + (= (length words) 4)) + (error "Invalid SSHFP record.")) + (pop words) + (destructuring-bind (alg type fprhex) words + (rec :data (list (parse-integer alg) + (parse-integer type) + (decode-hex fprhex))))))))) + (t + (dolist (item (listify data)) + (destructuring-bind (fprhex &key (alg 'rsa) (type 'sha-1)) + (listify item) + (rec :data (list (lookup-enum alg 'sshfp-algorithm :min 0 :max 255) + (lookup-enum type 'sshfp-type :min 0 :max 255) + (decode-hex fprhex)))))))) + +(defmethod zone-record-rrdata ((type (eql :sshfp)) zr) + (destructuring-bind (alg type fpr) (zr-data zr) + (rec-u8 alg) + (rec-u8 type) + (rec-octet-vector fpr)) + 44) + +(defenum tlsa-usage () + (:ca-constraint 0) + (:service-certificate-constraint 1) + (:trust-anchor-assertion 2) + (:domain-issued-certificate 3)) + +(defenum tlsa-selector () + (:certificate 0) + (:public-key 1)) + +(defenum tlsa-match () + (:exact 0) + (:sha-256 1) + (:sha-512 2)) + +(defparameter tlsa-pem-alist + `(("CERTIFICATE" . ,tlsa-selector/certificate) + ("PUBLIC-KEY" . ,tlsa-selector/public-key))) + +(defgeneric raw-tlsa-assoc-data (have want file context) + (:documentation + "Convert FILE, and strip off PEM encoding. + + The FILE contains PEM-encoded data of type HAVE -- one of the + `tlsa-selector' codes. Return the name of a file containing binary + DER-encoded data of type WANT instead. The CONTEXT is a temporary-files + context.") + + (:method (have want file context) + (declare (ignore context)) + (error "Can't convert `~A' from selector type ~S to type ~S" file + (reverse-enum 'tlsa-selector have) + (reverse-enum 'tlsa-selector want))) + + (:method ((have (eql tlsa-selector/certificate)) + (want (eql tlsa-selector/certificate)) + file context) + (let ((temp (temporary-file context "cert"))) + (run-program (list "openssl" "x509" "-outform" "der") + :input file :output temp) + temp)) + + (:method ((have (eql tlsa-selector/public-key)) + (want (eql tlsa-selector/public-key)) + file context) + (let ((temp (temporary-file context "pubkey-der"))) + (run-program (list "openssl" "pkey" "-pubin" "-outform" "der") + :input file :output temp) + temp)) + + (:method ((have (eql tlsa-selector/certificate)) + (want (eql tlsa-selector/public-key)) + file context) + (let ((temp (temporary-file context "pubkey"))) + (run-program (list "openssl" "x509" "-noout" "-pubkey") + :input file :output temp) + (raw-tlsa-assoc-data want want temp context)))) + +(defgeneric tlsa-match-data-valid-p (match data) + (:documentation + "Check whether the DATA (an octet vector) is valid for the MATCH type.") + + (:method (match data) + (declare (ignore match data)) + ;; We don't know: assume the user knows what they're doing. + t) + + (:method ((match (eql tlsa-match/sha-256)) data) (= (length data) 32)) + (:method ((match (eql tlsa-match/sha-512)) data) (= (length data) 64))) + +(defgeneric read-tlsa-match-data (match file context) + (:documentation + "Read FILE, and return an octet vector for the correct MATCH type. + + CONTEXT is a temporary-files context.") + (:method ((match (eql tlsa-match/exact)) file context) + (declare (ignore context)) + (slurp-file file 'octet)) + (:method ((match (eql tlsa-match/sha-256)) file context) + (hash-file "sha256" file context)) + (:method ((match (eql tlsa-match/sha-512)) file context) + (hash-file "sha512" file context))) + +(defgeneric tlsa-selector-pem-boundary (selector) + (:documentation + "Return the PEM boundary string for objects of the SELECTOR type") + (:method ((selector (eql tlsa-selector/certificate))) "CERTIFICATE") + (:method ((selector (eql tlsa-selector/public-key))) "PUBLIC KEY") + (:method (selector) (declare (ignore selector)) nil)) + +(defun identify-tlsa-selector-file (file) + "Return the selector type for the data stored in a PEM-format FILE." + (with-open-file (in file) + (loop + (let* ((line (read-line in nil)) + (len (length line))) + (unless line + (error "No PEM boundary in `~A'" file)) + (when (and (>= len 11) + (string= line "-----BEGIN " :end1 11) + (string= line "-----" :start1 (- len 5))) + (mapenum (lambda (tag value) + (declare (ignore tag)) + (when (string= line + (tlsa-selector-pem-boundary value) + :start1 11 :end1 (- len 5)) + (return value))) + 'tlsa-selector)))))) + +(export '*tlsa-pathname-defaults*) +(defvar *tlsa-pathname-defaults* + (list (make-pathname :directory '(:relative "certs") :type "cert") + (make-pathname :directory '(:relative "keys") :type "pub")) + "Default pathname components for TLSA records.") +(pushnew '*tlsa-pathname-defaults* *zone-config*) + +(defparameter *tlsa-data-cache* (make-hash-table :test #'equal) + "Cache for TLSA association data; keys are (DATA SELECTOR MATCH).") + +(defun convert-tlsa-selector-data (data selector match) + "Convert certificate association DATA as required by SELECTOR and MATCH. + + If DATA is a hex string, we assume that it's already in the appropriate + form (but if MATCH specifies a hash then we check that it's the right + length). If DATA is a pathname, then it should name a PEM file: we + identify the kind of object stored in the file from the PEM header, and + convert as necessary. + + The output is an octet vector containing the raw certificate association + data to include in rrdata." + + (etypecase data + (string + (let ((bin (decode-hex data))) + (unless (tlsa-match-data-valid-p match bin) + (error "Invalid data for match type ~S" + (reverse-enum 'tlsa-match match))) + bin)) + (pathname + (let ((key (list data selector match))) + (or (gethash key *tlsa-data-cache*) + (with-temporary-files (context :base (make-pathname :type "tmp")) + (let* ((file (or (find-if #'probe-file + (mapcar (lambda (template) + (merge-pathnames data + template)) + *tlsa-pathname-defaults*)) + (error "Couldn't find TLSA file `~A'" data))) + (kind (identify-tlsa-selector-file file)) + (raw (raw-tlsa-assoc-data kind selector file context)) + (binary (read-tlsa-match-data match raw context))) + (setf (gethash key *tlsa-data-cache*) binary)))))))) + +(defzoneparse :tlsa (name data rec) + ":tlsa (((SERVICE|PORT &key :protocol)*) (USAGE SELECTOR MATCH DATA)*)" + + (destructuring-bind (services &rest certinfos) data + + ;; First pass: build the raw-format TLSA record data. + (let ((records nil)) + (dolist (certinfo certinfos) + (destructuring-bind (usage-tag selector-tag match-tag data) certinfo + (let* ((usage (lookup-enum 'tlsa-usage usage-tag :min 0 :max 255)) + (selector (lookup-enum 'tlsa-selector selector-tag + :min 0 :max 255)) + (match (lookup-enum 'tlsa-match match-tag :min 0 :max 255)) + (raw (convert-tlsa-selector-data data selector match))) + (push (list usage selector match raw) records)))) + (setf records (nreverse records)) + + ;; Second pass: attach records for the requested services. + (dolist (service (listify services)) + (destructuring-bind (svc &key (protocol :tcp)) (listify service) + (let* ((port (etypecase svc + (integer svc) + (keyword (let ((serv (serv-by-name svc protocol))) + (unless serv + (error "Unknown service `~A'" svc)) + (serv-port serv))))) + (prefixed (domain-name-concat + (make-domain-name + :labels (list (format nil "_~(~A~)" protocol) + (format nil "_~A" port))) + name))) + (dolist (record records) + (rec :name prefixed :data record)))))))) + +(defmethod zone-record-rrdata ((type (eql :tlsa)) zr) + (destructuring-bind (usage selector match data) (zr-data zr) + (rec-u8 usage) + (rec-u8 selector) + (rec-u8 match) + (rec-octet-vector data)) + 52) + +(defenum dnssec-algorithm () + (:rsamd5 1) + (:dh 2) + (:dsa 3) + (:rsasha1 5) + (:dsa-nsec3-sha1 6) + (:rsasha1-nsec3-sha1 7) + (:rsasha256 8) + (:rsasha512 10) + (:ecc-gost 12) + (:ecdsap256sha256 13) + (:ecdsap384sha384 14)) + +(defenum dnssec-digest () + (:sha1 1) + (:sha256 2)) + +(defzoneparse :ds (name data rec) + ":ds ((TAG ALGORITHM DIGEST-TYPE DIGEST)*)" + (dolist (ds data) + (destructuring-bind (tag alg hashtype hash) ds + (rec :data (list tag + (lookup-enum 'dnssec-algorithm alg :min 0 :max 255) + (lookup-enum 'dnssec-digest hashtype :min 0 :max 255) + (decode-hex hash)))))) + +(defmethod zone-record-rrdata ((type (eql :ds)) zr) + (destructuring-bind (tag alg hashtype hash) zr + (rec-u16 tag) + (rec-u8 alg) + (rec-u8 hashtype) + (rec-octet-vector hash))) + (defzoneparse :mx (name data rec :zname zname) ":mx ((HOST :prio INT :ip IPADDR)*)" (dolist (mx (listify data)) @@ -793,8 +1359,16 @@ ZONE-RECORD: (mxname &key (prio *default-mx-priority*) ip) (listify mx) (let ((host (zone-parse-host mxname zname))) - (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (when ip (zone-set-address #'rec ip :name host)) (rec :data (cons host prio)))))) + +(defmethod zone-record-rrdata ((type (eql :mx)) zr) + (let ((name (car (zr-data zr))) + (prio (cdr (zr-data zr)))) + (rec-u16 prio) + (rec-name name)) + 15) + (defzoneparse :ns (name data rec :zname zname) ":ns ((HOST :ip IPADDR)*)" (dolist (ns (listify data)) @@ -802,199 +1376,260 @@ ZONE-RECORD: (nsname &key ip) (listify ns) (let ((host (zone-parse-host nsname zname))) - (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (when ip (zone-set-address #'rec ip :name host)) (rec :data host))))) + +(defmethod zone-record-rrdata ((type (eql :ns)) zr) + (rec-name (zr-data zr)) + 2) + (defzoneparse :alias (name data rec :zname zname) ":alias (LABEL*)" (dolist (a (listify data)) (rec :name (zone-parse-host a zname) :type :cname :data name))) - + +(defzoneparse :srv (name data rec :zname zname) + ":srv (((SERVICE &key :port :protocol) + (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 (flet ((prepend (tag tail) + (domain-name-concat + (make-domain-name + :labels (list (format nil "_~(~A~)" tag))) + tail))) + (prepend service (prepend 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 (zone-set-address #'rec ip :name host)) + (rec :name rname + :data (list prio weight port host)))))))))) + +(defmethod zone-record-rrdata ((type (eql :srv)) zr) + (destructuring-bind (prio weight port host) (zr-data zr) + (rec-u16 prio) + (rec-u16 weight) + (rec-u16 port) + (rec-name host)) + 33) + +(defenum caa-flag () (:critical 128)) + +(defzoneparse :caa (name data rec) + ":caa ((TAG VALUE FLAG*)*)" + (dolist (prop data) + (destructuring-bind (tag value &rest flags) prop + (setf flags (reduce #'logior + (mapcar (lambda (item) + (lookup-enum 'caa-flag item + :min 0 :max 255)) + flags))) + (ecase tag + ((:issue :issuewild :iodef) + (rec :name name + :data (list flags tag value))))))) + +(defmethod zone-record-rrdata ((type (eql :caa)) zr) + (destructuring-bind (flags tag value) (zr-data zr) + (rec-u8 flags) + (rec-string (string-downcase tag)) + (rec-raw-string value)) + 257) + +(defzoneparse :net (name data rec) + ":net (NETWORK*)" + (dolist (net (listify data)) + (dolist (ipn (net-ipnets (net-must-find net))) + (let* ((base (ipnet-net ipn)) + (rrtype (ipaddr-rrtype base))) + (flet ((frob (kind addr) + (when addr + (rec :name (zone-parse-host kind name) + :type rrtype + :data addr)))) + (frob "net" base) + (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn))) + (frob "bcast" (ipnet-broadcast ipn))))))) + (defzoneparse (:rev :reverse) (name data rec) - ":reverse ((NET :bytes BYTES) ZONE*)" + ":reverse ((NET &key :prefix-bits :family) ZONE*) + + Add a reverse record each host in the ZONEs (or all zones) that lies + within NET." (setf data (listify data)) - (destructuring-bind - (net &key bytes) + (destructuring-bind (net &key prefix-bits (family *address-family*)) (listify (car data)) - (setf net (zone-parse-net net name)) - (unless bytes - (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) - (dolist (z (or (cdr data) - (hash-table-keys *zones*))) - (dolist (zr (zone-records (zone-find z))) - (when (and (eq (zr-type zr) :a) - (not (zr-defsubp zr)) - (ipaddr-networkp (zr-data zr) net)) - (rec :name (string-downcase - (join-strings - #\. - (collecting () - (dotimes (i bytes) - (collect (logand #xff (ash (zr-data zr) - (* -8 i))))) - (collect name)))) - :type :ptr - :ttl (zr-ttl zr) - :data (zr-name zr))))))) - -(defzoneparse (:cidr-delegation :cidr) (name data rec) - ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)" - (destructuring-bind - (net &key bytes) + + (dolist (ipn (net-parse-to-ipnets net family)) + (let* ((seen (make-hash-table :test #'equal)) + (width (ipnet-width ipn)) + (frag-len (if prefix-bits (- width prefix-bits) + (ipnet-changeable-bits width (ipnet-mask ipn))))) + (dolist (z (or (cdr data) (hash-table-keys *zones*))) + (dolist (zr (zone-records (zone-find z))) + (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn))) + (zr-make-ptr-p zr) + (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn)) + (let* ((frag (reverse-domain-fragment (zr-data zr) + 0 frag-len)) + (name (domain-name-concat frag name)) + (name-string (princ-to-string name))) + (unless (gethash name-string seen) + (rec :name name :type :ptr + :ttl (zr-ttl zr) :data (zr-name zr)) + (setf (gethash name-string seen) t)))))))))) + +(defzoneparse :multi (name data rec :zname zname :ttl ttl) + ":multi (((NET*) &key :start :end :family :suffix) . REC) + + Output multiple records covering a portion of the reverse-resolution + namespace corresponding to the particular NETs. The START and END bounds + default to the most significant variable component of the + reverse-resolution domain. + + The REC tail is a sequence of record forms (as handled by + `zone-process-records') to be emitted for each covered address. Within + the bodies of these forms, the symbol `*' will be replaced by the + domain-name fragment corresponding to the current host, optionally + followed by the SUFFIX. + + Examples: + + (:multi ((delegated-subnet :start 8) + :ns (some.ns.delegated.example :ip \"169.254.5.2\"))) + + (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\") + :cname *)) + + Obviously, nested `:multi' records won't work well." + + (destructuring-bind (nets + &key start end ((:suffix raw-suffix)) + (family *address-family*)) (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 - 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 - (logand #xff - (ash addr (* 8 i))))))) - (rec :name (format nil "~A.~A" tail name) - :type :cname - :data (format nil "~A.~A" tail tdom)))))))) + (let ((suffix (if (not raw-suffix) + (make-domain-name :labels nil :absolutep nil) + (zone-parse-host raw-suffix)))) + (dolist (net (listify nets)) + (dolist (ipn (net-parse-to-ipnets net family)) + (let* ((addr (ipnet-net ipn)) + (width (ipaddr-width addr)) + (comp-width (reverse-domain-component-width addr)) + (end (round-up (or end + (ipnet-changeable-bits width + (ipnet-mask ipn))) + comp-width)) + (start (round-down (or start (- end comp-width)) + comp-width)) + (map (ipnet-host-map ipn))) + (multiple-value-bind (host-step host-limit) + (ipnet-index-bounds map start end) + (do ((index 0 (+ index host-step))) + ((> index host-limit)) + (let* ((addr (ipnet-index-host map index)) + (frag (reverse-domain-fragment addr start end)) + (target (reduce #'domain-name-concat + (list frag suffix zname) + :from-end t + :initial-value root-domain))) + (dolist (zr (zone-parse-records (domain-name-concat frag + zname) + ttl + (subst target '* + (cdr data)))) + (rec :name (zr-name zr) + :type (zr-type zr) + :data (zr-data zr) + :ttl (zr-ttl zr) + :make-ptr-p (zr-make-ptr-p zr)))))))))))) -(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." - (multiple-value-bind - (sec min hr day mon yr dow dstp tz) - (decode-universal-time (if (or (null time) (eq time :now)) - (get-universal-time) - time)) - (declare (ignore dow dstp tz)) - (with-output-to-string (s) - (when datep - (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day) - (when timep - (write-char sep s))) - (when timep - (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec))))) +;;;-------------------------------------------------------------------------- +;;; Zone file output. -(defun zone-write (zone &optional (stream *standard-output*)) - "Write a ZONE's records to STREAM." - (labels ((fix-admin (a) - (let ((at (position #\@ a)) - (s (concatenate 'string (string-downcase a) "."))) - (when s - (setf (char s at) #\.)) - s)) - (fix-host (h) - (if (not h) - "@" - (let* ((h (string-downcase (stringify h))) - (hl (length h)) - (r (string-downcase (zone-name zone))) - (rl (length r))) - (cond ((string= r h) "@") - ((and (> hl rl) - (char= (char h (- hl rl 1)) #\.) - (string= h r :start1 (- hl rl))) - (subseq h 0 (- hl rl 1))) - (t (concatenate 'string h ".")))))) - (printrec (zr) - (format stream "~A~20T~@[~8D~]~30TIN ~A~40T" - (fix-host (zr-name zr)) - (and (/= (zr-ttl zr) (zone-default-ttl zone)) - (zr-ttl zr)) - (string-upcase (symbol-name (zr-type zr)))))) - (format stream "~ -;;; Zone file `~(~A~)' -;;; (generated ~A) +(export 'zone-write) +(defgeneric zone-write (format zone stream) + (:documentation "Write ZONE's records to STREAM in the specified FORMAT.")) -$ORIGIN ~@0*~(~A.~) -$TTL ~@2*~D~2%" - (zone-name zone) - (iso-date :now :datep t :timep t) - (zone-default-ttl zone)) - (let ((soa (zone-soa zone))) - (format stream "~ -~A~30TIN SOA~40T~A ~A ( -~45T~10D~60T ;serial -~45T~10D~60T ;refresh -~45T~10D~60T ;retry -~45T~10D~60T ;expire -~45T~10D )~60T ;min-ttl~2%" - (fix-host (zone-name zone)) - (fix-host (soa-source soa)) - (fix-admin (soa-admin soa)) - (soa-serial soa) - (soa-refresh soa) - (soa-retry soa) - (soa-expire soa) - (soa-min-ttl soa))) - (dolist (zr (zone-records zone)) - (case (zr-type zr) - (:a - (printrec zr) - (format stream "~A~%" (ipaddr-string (zr-data zr)))) - ((:ptr :cname) - (printrec zr) - (format stream "~A~%" (fix-host (zr-data zr)))) - (:ns - (printrec zr) - (format stream "~A~%" (fix-host (zr-data zr)))) - (:mx - (printrec zr) - (let ((mx (zr-data zr))) - (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx))))) - (:txt - (printrec zr) - (format stream "~S~%" (stringify (zr-data zr)))))))) +(defvar *writing-zone* nil + "The zone currently being written.") -(defun zone-create (zf) - "Zone construction function. Given a zone form ZF, construct the zone and -add it to the table." - (let* ((zone (zone-parse zf)) - (name (zone-name zone))) - (setf (zone-find name) zone) - name)) -(defmacro defzone (soa &rest zf) - "Zone definition macro." - `(zone-create '(,soa ,@zf))) -(defmacro defrevzone (head &rest zf) - "Define a reverse zone, with the correct name." - (destructuring-bind - (net &rest soa-args) - (listify head) - (let ((bytes nil)) - (when (and soa-args (integerp (car soa-args))) - (setf bytes (pop soa-args))) - `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf))))) - +(defvar *zone-output-stream* nil + "Stream to write zone data on.") + +(export 'zone-write-raw-rrdata) +(defgeneric zone-write-raw-rrdata (format zr type data) + (:documentation "Write an otherwise unsupported record in a given FORMAT. + + ZR gives the record object, which carries the name and TTL; the TYPE is + the numeric RRTYPE code; and DATA is an octet vector giving the RRDATA. + This is used by the default `zone-write-record' method to handle record + types which aren't directly supported by the format driver.")) + +(export 'zone-write-header) +(defgeneric zone-write-header (format zone) + (:documentation "Emit the header for a ZONE, in a given FORMAT. + + The header includes any kind of initial comment, the SOA record, and any + other necessary preamble. There is no default implementation. -(defun zone-save (zones) + This is part of the protocol used by the default method on `zone-write'; + if you override that method.")) + +(export 'zone-write-trailer) +(defgeneric zone-write-trailer (format zone) + (:documentation "Emit the header for a ZONE, in a given FORMAT. + + The footer may be empty, and is so by default. + + This is part of the protocol used by the default method on `zone-write'; + if you override that method.") + (:method (format zone) + (declare (ignore format zone)) + nil)) + +(export 'zone-write-record) +(defgeneric zone-write-record (format type zr) + (:documentation "Emit a record of the given TYPE (a keyword). + + The default implementation builds the raw RRDATA and passes it to + `zone-write-raw-rrdata'.") + (:method (format type zr) + (let* (code + (data (build-record (setf code (zone-record-rrdata type zr))))) + (zone-write-raw-rrdata format zr code data)))) + +(defmethod zone-write (format zone stream) + "This default method calls `zone-write-header', then `zone-write-record' + for each record in the zone, and finally `zone-write-trailer'. While it's + running, `*writing-zone*' is bound to the zone object, and + `*zone-output-stream*' to the output stream." + (let ((*writing-zone* zone) + (*zone-output-stream* stream)) + (zone-write-header format zone) + (dolist (zr (zone-records-sorted zone)) + (zone-write-record format (zr-type zr) zr)) + (zone-write-trailer format zone))) + +(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." + zones." (unless zones (setf zones (hash-table-keys *zones*))) (safely (safe) @@ -1003,8 +1638,242 @@ zones." (unless zz (error "Unknown zone `~A'." z)) (let ((stream (safely-open-output-stream safe - (string-downcase - (stringify z))))) - (zone-write zz stream)))))) + (zone-file-name z :zone)))) + (zone-write format zz stream) + (close stream)))))) + +;;;-------------------------------------------------------------------------- +;;; Bind format output. + +(defvar *bind-last-record-name* nil + "The previously emitted record name. + + Used for eliding record names on output.") + +(export 'bind-hostname) +(defun bind-hostname (hostname) + (let ((zone (domain-name-labels (zone-name *writing-zone*))) + (name (domain-name-labels hostname))) + (loop + (unless (and zone name (string= (car zone) (car name))) + (return)) + (pop zone) (pop name)) + (flet ((stitch (labels absolutep) + (format nil "~{~A~^.~}~@[.~]" + (reverse (mapcar #'quotify-label labels)) + absolutep))) + (cond (zone (stitch (domain-name-labels hostname) t)) + (name (stitch name nil)) + (t "@"))))) + +(export 'bind-output-hostname) +(defun bind-output-hostname (hostname) + (let ((name (bind-hostname hostname))) + (cond ((and *bind-last-record-name* + (string= name *bind-last-record-name*)) + "") + (t + (setf *bind-last-record-name* name) + name)))) + +(defmethod zone-write :around ((format (eql :bind)) zone stream) + (declare (ignorable zone stream)) + (let ((*bind-last-record-name* nil)) + (call-next-method))) + +(defmethod zone-write-header ((format (eql :bind)) zone) + (format *zone-output-stream* "~ +;;; Zone file `~(~A~)' +;;; (generated ~A) + +$ORIGIN ~0@*~(~A.~) +$TTL ~2@*~D~2%" + (zone-name zone) + (iso-date :now :datep t :timep t) + (zone-default-ttl zone)) + (let* ((soa (zone-soa zone)) + (admin (let* ((name (soa-admin soa)) + (at (position #\@ name)) + (copy (format nil "~(~A~)." name))) + (when at + (setf (char copy at) #\.)) + copy))) + (format *zone-output-stream* "~ +~A~30TIN SOA~40T~A ( +~55@A~58T; administrator +~45T~10D~58T; serial +~45T~10D~58T; refresh: ~{~D ~(~A~)~^ ~} +~45T~10D~58T; retry: ~{~D ~(~A~)~^ ~} +~45T~10D~58T; expire: ~{~D ~(~A~)~^ ~} +~45T~10D )~58T; min-ttl: ~{~D ~(~A~)~^ ~}~2%" + (bind-output-hostname (zone-name zone)) + (bind-hostname (soa-source soa)) + admin + (soa-serial soa) + (soa-refresh soa) (seconds-timespec (soa-refresh soa)) + (soa-retry soa) (seconds-timespec (soa-retry soa)) + (soa-expire soa) (seconds-timespec (soa-expire soa)) + (soa-min-ttl soa) (seconds-timespec (soa-min-ttl soa))))) + +(export 'bind-format-record) +(defun bind-format-record (zr format &rest args) + (format *zone-output-stream* + "~A~20T~@[~8D~]~30TIN ~A~40T~?" + (bind-output-hostname (zr-name zr)) + (let ((ttl (zr-ttl zr))) + (and (/= ttl (zone-default-ttl *writing-zone*)) + ttl)) + (string-upcase (symbol-name (zr-type zr))) + format args)) + +(export 'bind-write-hex) +(defun bind-write-hex (vector remain) + "Output the VECTOR as hex, in Bind format. + + If the length (in bytes) is less than REMAIN then it's placed on the + current line; otherwise the Bind line-continuation syntax is used." + (flet ((output-octet (octet) + (format *zone-output-stream* "~(~2,'0X~)" octet))) + (let ((len (length vector))) + (cond ((< len remain) + (dotimes (i len) (output-octet (aref vector i))) + (terpri *zone-output-stream*)) + (t + (format *zone-output-stream* "(") + (let ((i 0)) + (loop + (when (>= i len) (return)) + (let ((limit (min len (+ i 64)))) + (format *zone-output-stream* "~%~8T") + (loop + (when (>= i limit) (return)) + (output-octet (aref vector i)) + (incf i))))) + (format *zone-output-stream* " )~%")))))) + +(defmethod zone-write-raw-rrdata ((format (eql :bind)) zr type data) + (format *zone-output-stream* + "~A~20T~@[~8D~]~30TIN TYPE~A~40T\\# ~A " + (bind-output-hostname (zr-name zr)) + (let ((ttl (zr-ttl zr))) + (and (/= ttl (zone-default-ttl *writing-zone*)) + ttl)) + type + (length data)) + (bind-write-hex data 12)) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :a)) zr) + (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr) + (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr) + (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr) + (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :dname)) zr) + (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr) + (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr) + (bind-format-record zr "~2D ~A~%" + (cdr (zr-data zr)) + (bind-hostname (car (zr-data zr))))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr) + (destructuring-bind (prio weight port host) (zr-data zr) + (bind-format-record zr "~2D ~5D ~5D ~A~%" + prio weight port (bind-hostname host)))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr) + (destructuring-bind (alg type fpr) (zr-data zr) + (bind-format-record zr "~2D ~2D " alg type) + (bind-write-hex fpr 12))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :tlsa)) zr) + (destructuring-bind (usage selector match data) (zr-data zr) + (bind-format-record zr "~2D ~2D ~2D " usage selector match) + (bind-write-hex data 12))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :caa)) zr) + (destructuring-bind (flags tag value) (zr-data zr) + (bind-format-record zr "~3D ~(~A~) ~S~%" flags tag value))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :ds)) zr) + (destructuring-bind (tag alg hashtype hash) (zr-data zr) + (bind-format-record zr "~5D ~2D ~2D " tag alg hashtype) + (bind-write-hex hash 12))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr) + (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}~%" + (zr-data zr))) + +;;;-------------------------------------------------------------------------- +;;; tinydns-data output format. + +(export 'tinydns-output) +(defun tinydns-output (code &rest fields) + (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields)) + +(defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data) + (tinydns-output #\: (zr-name zr) type + (with-output-to-string (out) + (dotimes (i (length data)) + (let ((byte (aref data i))) + (if (or (<= byte 32) + (>= byte 127) + (member byte '(#\: #\\) :key #'char-code)) + (format out "\\~3,'0O" byte) + (write-char (code-char byte) out))))) + (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :a)) zr) + (tinydns-output #\+ (zr-name zr) + (ipaddr-string (zr-data zr)) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :aaaa)) zr) + (tinydns-output #\3 (zr-name zr) + (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr))) + (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ptr)) zr) + (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :cname)) zr) + (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ns)) zr) + (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr))) + +(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :mx)) zr) + (let ((name (car (zr-data zr))) + (prio (cdr (zr-data zr)))) + (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr)))) + +(defmethod zone-write-header ((format (eql :tinydns)) zone) + (format *zone-output-stream* "~ +### Zone file `~(~A~)' +### (generated ~A) +~%" + (zone-name zone) + (iso-date :now :datep t :timep t)) + (let ((soa (zone-soa zone))) + (tinydns-output #\Z + (zone-name zone) + (soa-source soa) + (let* ((name (copy-seq (soa-admin soa))) + (at (position #\@ name))) + (when at (setf (char name at) #\.)) + name) + (soa-serial soa) + (soa-refresh soa) + (soa-expire soa) + (soa-min-ttl soa) + (zone-default-ttl zone)))) ;;;----- That's all, folks --------------------------------------------------