X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/800554956d25b239b4a4892cf058d8a13ec54966..476808d8bacf084e6632b3aebbe14c28ec49e09a:/zone.lisp diff --git a/zone.lisp b/zone.lisp index d2a8e47..177ded6 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; DNS zone generation ;;; ;;; (c) 2005 Straylight/Edgeware @@ -13,12 +11,12 @@ ;;; 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. @@ -27,40 +25,13 @@ ;;; Packaging. (defpackage #:zone - (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #: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 - #:defzoneparse #:zone-parse-host - #:timespec-seconds #:make-zone-serial)) + (:use #:common-lisp + #:mdw.base #:mdw.str #:collect #:safely + #:net #:services) + (:import-from #:net #:round-down #:round-up)) (in-package #:zone) -;;;-------------------------------------------------------------------------- -;;; Basic types. - -(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) - ;;;-------------------------------------------------------------------------- ;;; Various random utilities. @@ -70,7 +41,7 @@ (defun to-integer (x) (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." + 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)))) @@ -78,7 +49,7 @@ (defun from-mixed-base (base val) (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." + representation. Convert VAL, an integer, into a list of digits." (let ((base (reverse base)) (a nil)) (loop @@ -89,10 +60,12 @@ (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 time -units." + "Convert a timespec TS to seconds. + + A timespec may be a real count of seconds, or a list (COUNT UNIT). UNIT + may be any of a number of obvious time units." (cond ((null ts) 0) ((realp ts) (floor ts)) ((atom ts) @@ -119,10 +92,11 @@ (defun hash-table-keys (ht) (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht))) (defun iso-date (&optional time &key datep timep (sep #\ )) - "Construct a textual date or time in ISO format. The TIME is the universal -time to convert, which defaults to now; DATEP is whether to emit the date; -TIMEP is whether to emit the time, and SEP (default is space) is how to -separate the two." + "Construct a textual date or time in ISO format. + + The TIME is the universal time to convert, which defaults to now; DATEP is + whether to emit the date; TIMEP is whether to emit the time, and + SEP (default is space) is how to separate the two." (multiple-value-bind (sec min hr day mon yr dow dstp tz) (decode-universal-time (if (or (null time) (eq time :now)) @@ -137,368 +111,114 @@ (defun iso-date (&optional time &key datep timep (sep #\ )) (when timep (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec))))) -(defun count-low-zero-bits (n) - "Return the number of low-order zero bits in the integer N." - (if (zerop n) nil - (loop for i from 0 - until (logbitp i n) - finally (return i)))) - -;;;-------------------------------------------------------------------------- -;;; Simple messing with IP addresses. - -(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)))) - -;;;-------------------------------------------------------------------------- -;;; Netmasks. - -(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)))) - -;;;-------------------------------------------------------------------------- -;;; Networks: pairing an address and netmask. - -(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) - "Construct an IP-network object from the given argument. A number of -forms are acceptable: - - * 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 ((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)) +(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 - (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 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))))) - -;;;-------------------------------------------------------------------------- -;;; Name resolution. - -#+cmu -(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)))) - -#+cmu -(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)))) - -;;;-------------------------------------------------------------------------- -;;; Host names and specifiers. - -(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)) - -;;;-------------------------------------------------------------------------- -;;; Network names and specifiers. - -(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 process-net-form (root addr subnets) - "Unpack a net-form. The return value is a list of entries, each of which -is a list of the form (NAME ADDR MASK). The first entry is merely repeats -the given ROOT and ADDR arguments (unpacking ADDR into separate network -address and mask). The SUBNETS are then processed: they are a list of items -of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet, -NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in -the same form. An error is signalled if a net's subnets use up more hosts -than the net has to start with." - (labels ((frob (subnets limit finger) - (when subnets - (destructuring-bind (name size &rest subs) (car subnets) - (when (> (count-low-zero-bits size) - (count-low-zero-bits finger)) - (error "Bad subnet size for ~A." name)) - (when (> (+ finger size) limit) - (error "Subnet ~A out of range." name)) - (append (and name - (list (list name finger (- (ash 1 32) size)))) - (frob subs (+ finger size) finger) - (frob (cdr subnets) limit (+ finger size))))))) - (let ((ipn (ipnet addr))) - (with-ipnet (net mask) ipn - (unless (ipmask-cidl-slash mask) - (error "Bad mask for subnet form.")) - (cons (list root net mask) - (frob subnets (+ net (ipnet-hosts ipn) 1) net)))))) - -(defun net-create (name net) - "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 (ipnet net))) - (setf (net-find name) - (make-net :name (string-downcase (stringify name)) - :ipnet ipn - :hosts (ipnet-hosts ipn) - :next 1)))) - -(defmacro defnet (name net &rest subnets) - "Main network definition macro. None of the arguments is evaluated." - `(progn - ,@(loop for (name addr mask) in (process-net-form name net subnets) - collect `(net-create ',name '(,addr . ,mask))) - ',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)))) + (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 @@ -509,11 +229,17 @@ (defstruct (soa (:predicate soap)) min-ttl serial) +(export 'zone-text-name) +(defun zone-text-name (zone) + (princ-to-string (zone-name zone))) + +(export 'mx) (defstruct (mx (:predicate mxp)) "Mail-exchange record information." priority domain) +(export 'zone) (defstruct (zone (:predicate zonep)) "Zone information." soa @@ -524,39 +250,159 @@ (defstruct (zone (:predicate zonep)) ;;;-------------------------------------------------------------------------- ;;; 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.") +(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.") +;;;-------------------------------------------------------------------------- +;;; 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) @@ -573,48 +419,57 @@ (defun make-zone-serial (name) (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))))) ;;;-------------------------------------------------------------------------- -;;; Zone variables and structures. +;;; Zone form parsing. -(defvar *zones* (make-hash-table :test #'equal) - "Map of known zones.") +(defun zone-process-records (rec ttl func) + "Sort out the list of records in REC, calling FUNC for each one. -(defun zone-find (name) - "Find a zone given its NAME." - (gethash (string-downcase (stringify name)) *zones*)) + TTL is the default time-to-live for records which don't specify one. -(defun (setf zone-find) (zone name) - "Make the zone NAME map to ZONE." - (setf (gethash (string-downcase (stringify name)) *zones*) zone)) + REC is a list of records of the form -(defstruct (zone-record (:conc-name zr-)) - "A zone record." - (name ') - ttl - type - (defsubp nil) - data) + ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*) -(defstruct (zone-subdomain (:conc-name zs-)) - "A subdomain. Slightly weird. Used internally by zone-process-records -below, and shouldn't escape." - name - ttl - records) + The various kinds of entries have the following meanings. -;;;-------------------------------------------------------------------------- -;;; Zone infrastructure. + :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 @@ -629,215 +484,70 @@ (defun zone-process-records (rec ttl func) 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) + + (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 default-rev-zone (base bytes) - "Return the default reverse-zone name for the given BASE address and number -of fixed leading 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))))))) - -;;;-------------------------------------------------------------------------- -;;; Zone form parsing. + (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))) + (serial (make-zone-serial raw-zname)) + &aux + (zname (zone-parse-host raw-zname root-domain))) (listify head) (values zname (timespec-seconds ttl) @@ -849,142 +559,403 @@ (defun zone-parse-head (head) :min-ttl (timespec-seconds min-ttl) :serial serial)))) +(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 (or TYPES -- a list of synonyms is -permitted). The arguments are as follows: + "Define a new zone record type. + + The arguments are as follows: -NAME The name of the record to be added. + TYPES A singleton type symbol, or a list of aliases. -DATA The content of the record to be added (a single object, unevaluated). + NAME The name of the record to be added. -LIST A function to add a record to the zone. See below. + DATA The content of the record to be added (a single object, + unevaluated). -ZNAME The name of the zone being constructed. + LIST A function to add a record to the zone. See below. -TTL The TTL for this record. + PREFIX The prefix tag used in the original form. -DEFSUBP Whether this is the default subdomain for this entry. + ZNAME The name of the zone being constructed. -You get to choose your own names for these. ZNAME, TTL and DEFSUBP are -optional: you don't have to accept them if you're not interested. + TTL The TTL for this record. -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 + 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. - (LIST &key :name :type :data :ttl :defsubp) + 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)." -Except for defsubp, these 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. -ZONE-FORM: - ZONE-HEAD ZONE-RECORD* + The syntax of a zone form is as follows: -ZONE-RECORD: - ((NAME*) ZONE-RECORD*) -| SYM ARGS" + ZONE-FORM: + ZONE-HEAD ZONE-RECORD* + + 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))) + (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." + "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))) + (name (zone-text-name zone))) (setf (zone-find name) zone) name)) -(defmacro defzone (soa &rest zf) +(export 'defzone) +(defmacro defzone (soa &body zf) "Zone definition macro." `(zone-create '(,soa ,@zf))) -(defmacro defrevzone (head &rest 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 - (net &rest soa-args) + (destructuring-bind (nets &rest args + &key &allow-other-keys + (family '*address-family*) + prefix-bits) (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))))) + (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 :defsubp defsubp) +(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))) +(defmethod zone-record-rrdata ((type (eql :cname)) zr) + (rec-name (zr-data zr)) + 5) + +(defzoneparse :txt (name data rec) + ":txt (TEXT*)" + (rec :data (listify data))) + +(defmethod zone-record-rrdata ((type (eql :txt)) zr) + (mapc #'rec-string (zr-data zr)) + 16) + +(export '*dkim-pathname-defaults*) +(defvar *dkim-pathname-defaults* + (make-pathname :directory '(:relative "keys") + :type "dkim")) + +(defzoneparse :dkim (name data rec) + ":dkim (KEYFILE {:TAG VALUE}*)" + (destructuring-bind (file &rest plist) (listify data) + (let ((things nil) (out nil)) + (labels ((flush () + (when out + (push (get-output-stream-string out) things) + (setf out nil))) + (emit (text) + (let ((len (length text))) + (when (and out (> (+ (file-position out) + (length text)) + 64)) + (flush)) + (when (plusp len) + (cond ((< len 64) + (unless out + (setf out (make-string-output-stream))) + (write-string text out)) + (t + (do ((i 0 j) + (j 64 (+ j 64))) + ((>= i len)) + (push (subseq text i (min j len)) + things)))))))) + (do ((p plist (cddr p))) + ((endp p)) + (emit (format nil "~(~A~)=~A;" (car p) (cadr p)))) + (emit (with-output-to-string (out) + (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))) + (if (string= line "-----END PUBLIC KEY-----") + (return) + (write-string line out))))))))) + (rec :type :txt + :data (nreverse things))))) + +(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3)) +(defenum sshfp-type () (:sha-1 1) (:sha-256 2)) + +(export '*sshfp-pathname-defaults*) +(defvar *sshfp-pathname-defaults* + (make-pathname :directory '(:relative "keys") + :type "sshfp")) + +(defzoneparse :sshfp (name data rec) + ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }" + (if (stringp data) + (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 fpr) words + (rec :data (list (parse-integer alg) + (parse-integer type) + fpr))))))) + (dolist (item (listify data)) + (destructuring-bind (fpr &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) + fpr)))))) + +(defmethod zone-record-rrdata ((type (eql :sshfp)) zr) + (destructuring-bind (alg type fpr) (zr-data zr) + (rec-u8 alg) + (rec-u8 type) + (do ((i 0 (+ i 2)) + (n (length fpr))) + ((>= i n)) + (rec-u8 (parse-integer fpr :start i :end (+ i 2) :radix 16)))) + 44) + (defzoneparse :mx (name data rec :zname zname) ":mx ((HOST :prio INT :ip IPADDR)*)" (dolist (mx (listify data)) @@ -992,9 +963,16 @@ (defzoneparse :mx (name data rec :zname zname) (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)) @@ -1002,9 +980,13 @@ (defzoneparse :ns (name data rec :zname zname) (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)) @@ -1012,178 +994,447 @@ (defzoneparse :alias (name data rec :zname 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) + (defzoneparse :net (name data rec) ":net (NETWORK*)" (dolist (net (listify data)) - (let ((n (net-get-as-ipnet net))) - (rec :name (zone-parse-host "net" name) - :type :a - :data (ipnet-net n)) - (rec :name (zone-parse-host "mask" name) - :type :a - :data (ipnet-mask n)) - (rec :name (zone-parse-host "broadcast" name) - :type :a - :data (ipnet-broadcast n))))) - + (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)))))))))))) ;;;-------------------------------------------------------------------------- ;;; 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 "~ +(export 'zone-write) +(defgeneric zone-write (format zone stream) + (:documentation "Write ZONE's records to STREAM in the specified FORMAT.")) + +(defvar *writing-zone* nil + "The zone currently being written.") + +(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. + + 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." + (unless zones + (setf zones (hash-table-keys *zones*))) + (safely (safe) + (dolist (z zones) + (let ((zz (zone-find z))) + (unless zz + (error "Unknown zone `~A'." z)) + (let ((stream (safely-open-output-stream safe + (zone-file-name z :zone)))) + (zone-write format zz 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%" +$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 ( + (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~60T ;administrator ~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)) + (bind-output-hostname (zone-name zone)) + (bind-hostname (soa-source soa)) + admin (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)))))))) - -(defun zone-save (zones) - "Write the named ZONES to files. If no zones are given, write all the -zones." - (unless zones - (setf zones (hash-table-keys *zones*))) - (safely (safe) - (dolist (z zones) - (let ((zz (zone-find z))) - (unless zz - (error "Unknown zone `~A'." z)) - (let ((stream (safely-open-output-stream safe - (format nil - "~(~A~).zone" - z)))) - (zone-write zz stream)))))) + (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 :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) + (bind-format-record zr "~{~2D ~2D ~A~}~%" (zr-data zr))) + +(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 --------------------------------------------------