--- /dev/null
+;;; -*-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 '<unnamed>)
+ 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 --------------------------------------------------
~mdw / zone / commitdiff