From: mdw Date: Thu, 25 Aug 2005 08:46:39 +0000 (+0000) Subject: Initial checkin. X-Git-Url: https://git.distorted.org.uk/~mdw/zone/commitdiff_plain/7e282fb5afd9b871063614a3e442d2d599757862?ds=sidebyside Initial checkin. --- 7e282fb5afd9b871063614a3e442d2d599757862 diff --git a/6.18.10.in-addr.arpa b/6.18.10.in-addr.arpa new file mode 100644 index 0000000..8e63785 --- /dev/null +++ b/6.18.10.in-addr.arpa @@ -0,0 +1,22 @@ +;;; Zone file `6.18.10.in-addr.arpa' +;;; (generated 2005-08-15 17:22:57) + +$ORIGIN 6.18.10.in-addr.arpa. +$TTL 14400 + +@ IN SOA boyle.nsict.org. hostmaster.distorted.org.uk. ( + 2005081509 ;serial + 86400 ;refresh + 3600 ;retry + 1209600 ;expire + 14400 ) ;min-ttl + +@ IN NS foo.ns +boyle.ns IN A 85.158.42.162 +@ IN NS boyle.ns +chiark.ns IN A 193.201.200.170 +@ IN NS chiark.ns +0 IN PTR net.internal.distorted.org.uk. +1 IN PTR abc.distorted.org.uk. +2 IN PTR xyz.distorted.org.uk. +255 IN PTR broadcast.internal.distorted.org.uk. diff --git a/6.18.10.in-addr.arpa.serial b/6.18.10.in-addr.arpa.serial new file mode 100644 index 0000000..015945d --- /dev/null +++ b/6.18.10.in-addr.arpa.serial @@ -0,0 +1,3 @@ +;; Serial number file for zone 6.18.10.in-addr.arpa +;; (LAST-SEQ DAY MONTH YEAR) +(9 15 8 2005) diff --git a/distorted.org.uk b/distorted.org.uk new file mode 100644 index 0000000..dea16f1 --- /dev/null +++ b/distorted.org.uk @@ -0,0 +1,38 @@ +;;; Zone file `distorted.org.uk' +;;; (generated 2005-08-15 17:22:57) + +$ORIGIN distorted.org.uk. +$TTL 14400 + +@ IN SOA boyle.nsict.org. hostmaster.distorted.org.uk. ( + 2005081517 ;serial + 86400 ;refresh + 3600 ;retry + 1209600 ;expire + 14400 ) ;min-ttl + +@ IN NS foo.ns +boyle.ns IN A 85.158.42.162 +@ IN NS boyle.ns +chiark.ns IN A 193.201.200.170 +@ IN NS chiark.ns +@ IN MX 10 foo.mx +@ IN MX 50 boyle.mx +lists IN MX 10 foo.mx +lists IN MX 50 boyle.mx +boyle.mx IN A 85.158.42.162 +www IN A 85.158.42.162 +wiki IN A 85.158.42.162 +ftp IN A 85.158.42.162 +cvs IN A 85.158.42.162 +svn IN A 85.158.42.162 +foo IN A 158.152.170.219 +gate IN A 158.152.170.219 +foo.ns IN A 158.152.170.219 +foo.mx IN A 158.152.170.219 +net.internal IN A 10.18.6.0 +abc IN A 10.18.6.1 +abc.internal IN A 10.18.6.1 +xyz IN A 10.18.6.2 +xyz.internal IN A 10.18.6.2 +broadcast.internal IN A 10.18.6.255 diff --git a/distorted.org.uk.lisp b/distorted.org.uk.lisp new file mode 100644 index 0000000..2cd56b3 --- /dev/null +++ b/distorted.org.uk.lisp @@ -0,0 +1,40 @@ +;;; distorted.org.uk + +(setf *default-zone-source* "boyle.nsict.org") +(setf *default-zone-admin* "hostmaster@distorted.org.uk") + +(defnet internal 10.18.6.0/24) ;Address chosen at random + +(defzone distorted.org.uk + ;; + ;; Nameservers + :ns ((foo.ns) + (boyle.ns :ip boyle.nsict.org) + (chiark.ns :ip chiark.greenend.org.uk)) + ;; + ;; Mail servers + ((@ lists) :mx ((foo.mx :prio 10) + (boyle.mx :prio 50))) + (boyle.mx :a boyle.nsict.org) + ;; + ;; Other colocated services + ((www wiki ftp cvs svn) :a boyle.nsict.org) + ;; + ;; Externally visible addresses + ((foo gate foo.ns foo.mx) :a excessus.demon.co.uk) + ;; + ;; Internal network + (net.internal :a (internal :net)) + (abc (internal :a (internal 1))) + (xyz (internal :a (internal 2))) + (broadcast.internal :a (internal :broadcast))) + +(defrevzone internal + ;; + ;; Nameservers + :ns ((foo.ns) + (boyle.ns :ip boyle.nsict.org) + (chiark.ns :ip chiark.greenend.org.uk)) + ;; + ;; Main contents + :reverse internal) diff --git a/distorted.org.uk.serial b/distorted.org.uk.serial new file mode 100644 index 0000000..be5dbba --- /dev/null +++ b/distorted.org.uk.serial @@ -0,0 +1,3 @@ +;; Serial number file for zone DISTORTED.ORG.UK +;; (LAST-SEQ DAY MONTH YEAR) +(17 15 8 2005) diff --git a/frontend.lisp b/frontend.lisp new file mode 100644 index 0000000..bd00ff4 --- /dev/null +++ b/frontend.lisp @@ -0,0 +1,90 @@ +;;; -*-lisp-*- +;;; +;;; $Id$ +;;; +;;; Zone generator frontend +;;; +;;; (c) 2005 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; 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. + +(defpackage #:zone.frontend + (:use #:common-lisp #:mdw.optparse #:zone) + (:export #:main)) +(in-package #:zone.frontend) + +(defconstant version "1.0.0") + +(defvar opt-zones nil + "Which zones to be emitted.") + +(defvar options nil) +(defvar usage nil) +(defun help (arg) + (declare (ignore arg)) + (show-help *program-name* version usage options) + (exit 0)) +(defun version (arg) + (declare (ignore arg)) + (format t "~A, version ~A~%" *program-name* version) + (exit 0)) +(defun do-usage (&optional (stream *standard-output*)) + (show-usage *program-name* usage stream)) +(defun usage (arg) + (declare (ignore arg)) + (do-usage) + (exit 0)) +(setf options + (options + "Help options" + (#\h "help" #'help + "Show this help message.") + (#\v "version" #'version + ("Show the `~A' program's version number." *program-name*)) + (#\u "usage" #'usage + ("Show a very brief usage summary for `~A'." *program-name*)) + + "Output options" + (#\z "zone" (:arg "NAME") (list opt-zones) + "Write information about zone NAME."))) +(setf usage (simple-usage options "ZONEDEF...")) + +(defun main () + (with-unix-error-reporting () + (let ((seq 54) + (files nil) + (op (make-option-parser (cdr *command-line-strings*) options))) + (unless (option-parse-try + (loop + (multiple-value-bind (opt arg) (option-parse-next op) + (declare (ignore arg)) + (unless opt + (return)))) + (setf files (option-parse-remainder op)) + (when (zerop (length files)) + (option-parse-error "no files to read"))) + (do-usage *error-output*) + (exit 1)) + (dolist (f files) + (let ((*package* (make-package (format nil "zone.scratch-~A" + (incf seq)) + :use '(#:common-lisp #:zone)))) + (load f :verbose nil :print nil :if-does-not-exist :error))) + (zone-save opt-zones)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/hibachidealers.com b/hibachidealers.com new file mode 100644 index 0000000..95376c1 --- /dev/null +++ b/hibachidealers.com @@ -0,0 +1,21 @@ +;;; Zone file `hibachidealers.com' +;;; (generated 2005-08-13 10:15:12) + +$ORIGIN hibachidealers.com. +$TTL 14400 + +@ IN SOA boyle.nsict.org. mdw.nsict.org. ( + 2005081302 ;serial + 86400 ;refresh + 3600 ;retry + 1209600 ;expire + 14400 ) ;min-ttl + +boyle.ns IN A 85.158.42.162 +@ IN NS boyle.ns +chiark.ns IN A 193.201.200.170 +@ IN NS chiark.ns +mccoy.ns IN A 195.8.181.31 +@ IN NS mccoy.ns +@ IN A 85.158.42.162 +www IN A 85.158.42.162 diff --git a/hibachidealers.com.lisp b/hibachidealers.com.lisp new file mode 100644 index 0000000..f8649fc --- /dev/null +++ b/hibachidealers.com.lisp @@ -0,0 +1,14 @@ +;;; hibachidealers.com + +(setf *default-zone-source* "boyle.nsict.org") +(setf *default-zone-admin* "mdw@nsict.org") + +(defzone hibachidealers.com + ;; + ;; Nameservers + :ns ((boyle.ns :ip boyle.nsict.org) + (chiark.ns :ip chiark.greenend.org.uk) + (mccoy.ns :ip mccoy.flatline.org.uk)) + ;; + ;; Colocated services + ((@ www) :a boyle.nsict.org)) diff --git a/hibachidealers.com.serial b/hibachidealers.com.serial new file mode 100644 index 0000000..5b0f24e --- /dev/null +++ b/hibachidealers.com.serial @@ -0,0 +1,3 @@ +;; Serial number file for zone HIBACHIDEALERS.COM +;; (LAST-SEQ DAY MONTH YEAR) +(2 13 8 2005) diff --git a/zone b/zone new file mode 100755 index 0000000..6757186 --- /dev/null +++ b/zone @@ -0,0 +1,6 @@ +#! /usr/local/bin/runlisp +;;; -*-lisp-*- + +(asdf:operate 'asdf:load-op "mdw" :verbose nil) +(asdf:operate 'asdf:load-op "zone" :verbose nil) +(zone.frontend:main) diff --git a/zone.asd b/zone.asd new file mode 100644 index 0000000..56c40e1 --- /dev/null +++ b/zone.asd @@ -0,0 +1,11 @@ +;;; -*-lisp-*- + +(defpackage #:zone.asdf + (:use #:common-lisp #:asdf)) +(in-package #:zone.asdf) + +(operate 'load-op "mdw") +(defsystem "zone" + :components ((:file "zone") + (:file "frontend")) + :serial t) diff --git a/zone.lisp b/zone.lisp new file mode 100644 index 0000000..153ce71 --- /dev/null +++ b/zone.lisp @@ -0,0 +1,1005 @@ +;;; -*-lisp-*- +;;; +;;; $Id$ +;;; +;;; DNS zone generation +;;; +;;; (c) 2005 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; 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. + +(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)) +(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 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)))) + +(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)))))) + +(defstruct (soa (:predicate soap)) + "Start-of-authority record information." + source + admin + refresh + retry + expire + min-ttl + serial) +(defstruct (mx (:predicate mxp)) + "Mail-exchange record information." + priority + domain) +(defstruct (zone (:predicate zonep)) + "Zone information." + soa + default-ttl + name + records) + +(defvar *default-zone-source* + (let ((hn (unix:unix-gethostname))) + (and hn (resolve-hostname hn))) + "The default zone source: the current host's name.") +(defvar *default-zone-refresh* (* 24 60 60) + "Default zone refresh interval: one day.") +(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.") +(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))))) + +(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)) + (last (with-open-file (in file + :direction :input + :if-does-not-exist nil) + (if in (read in) + (list 0 0 0 0)))) + (now (multiple-value-bind + (sec min hr dy mon yr dow dstp tz) + (get-decoded-time) + (declare (ignore sec min hr dow dstp tz)) + (list dy mon yr))) + (seq (cond ((not (equal now (cdr last))) 0) + ((< (car last) 99) (1+ (car last))) + (t (error "Run out of sequence numbers for ~A" name))))) + (safely-writing (out file) + (format out + ";; Serial number file for zone ~A~%~ + ;; (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)) + +(defstruct (zone-record (:conc-name zr-)) + "A zone record." + (name ') + ttl + type + (defsubp nil) + data) + +(defstruct (zone-subdomain (:conc-name zs-)) + "A subdomain. Slightly weird. Used internally by zone-process-records +below, and shouldn't escape." + name + ttl + records) + +(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) + (collecting (top sub) + (loop + (unless rec + (return)) + (let ((r (pop rec))) + (cond ((eq r :ttl) + (setf ttl (pop rec))) + ((symbolp r) + (collect (make-zone-record :type r + :ttl ttl + :data (pop rec)) + top)) + ((listp r) + (dolist (name (listify (car r))) + (collect (make-zone-subdomain :name name + :ttl ttl + :records (cdr r)) + sub))) + (t + (error "Unexpected record form ~A" (car r)))))))) + (process (rec dom ttl defsubp) + (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)))) + (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))))))) + + + +(defun zone-parse-head (head) + "Parse the HEAD of a zone form. This has the form + + (NAME &key :source :admin :refresh :retry + :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." + (destructuring-bind + (zname + &key + (source (concatenate 'string *default-zone-source* ".")) + (admin (or *default-zone-admin* + (format nil "hostmaster@~A" 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))) + (listify head) + (values zname + (timespec-seconds ttl) + (make-soa :admin admin + :source (zone-parse-host source zname) + :refresh (timespec-seconds refresh) + :retry (timespec-seconds retry) + :expire (timespec-seconds expire) + :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))) + +(defmacro defzoneparse (types (name data list + &key (zname (gensym "ZNAME")) + (ttl (gensym "TTL")) + (defsubp (gensym "DEFSUBP"))) + &body body) + (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))))) + +(defun zone-parse (zf) + "Parse a ZONE form. The syntax of a zone form is as follows: + +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))) + +(defzoneparse :a (name data rec :defsubp defsubp) + ":a IPADDR" + (rec :data (parse-ipaddr data) :defsubp defsubp)) +(defzoneparse :ptr (name data rec :zname zname) + ":ptr HOST" + (rec :data (zone-parse-host data zname))) +(defzoneparse :cname (name data rec :zname zname) + ":cname HOST" + (rec :data (zone-parse-host data zname))) +(defzoneparse :mx (name data rec :zname zname) + ":mx ((HOST :prio INT :ip IPADDR)*)" + (dolist (mx (listify data)) + (destructuring-bind + (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))) + (rec :data (cons host prio)))))) +(defzoneparse :ns (name data rec :zname zname) + ":ns ((HOST :ip IPADDR)*)" + (dolist (ns (listify data)) + (destructuring-bind + (nsname &key ip) + (listify ns) + (let ((host (zone-parse-host nsname zname))) + (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (rec :data host))))) +(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 (:rev :reverse) (name data rec) + ":reverse ((NET :bytes BYTES) ZONE*)" + (setf data (listify data)) + (destructuring-bind + (net &key bytes) + (listify (car data)) + (setf net (zone-parse-net net name)) + (unless bytes + (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) + (dolist (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) + (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)))))))) + +(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))))) + +(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) + +$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)))))))) + +(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))))) + + +(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 + (string-downcase + (stringify z))))) + (zone-write zz stream)))))) + +;;;----- That's all, folks --------------------------------------------------