;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;;--------------------------------------------------------------------------
+;;; Packaging.
+
(defpackage #:zone
- (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:mdw.safely)
- (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
- #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
- #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
- #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
- #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
- #:host-find# #:host-create #:defhost #:parse-ipaddr
- #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
- #:net-next-host #:net-host
- #:soa #:mx #:zone #:zone-record #:zone-subdomain
+ (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net)
+ (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
#:*default-zone-source* #:*default-zone-refresh*
#:*default-zone-retry* #:*default-zone-expire*
#:*default-zone-min-ttl* #:*default-zone-ttl*
#:*default-mx-priority* #:*default-zone-admin*
#:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
#:defrevzone #:zone-save
+ #:defzoneparse #:zone-parse-host
#: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 canonify-hostname (name)
- "Resolve a hostname to canonical form using the DNS, or return nil."
- (let ((he (ext:lookup-host-entry name)))
- (and he
- (ext:host-entry-name he))))
-(defun parse-ipaddr (addr)
- "Convert the string ADDR into an IP address: tries all sorts of things:
-
- (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
- INDEX is an index or one of the special symbols understood by net-host,
- and defaults to :next
- INTEGER -- an integer IP address
- IPADDR -- an IP address in dotted-quad form
- HOST -- a host name defined by defhost
- DNSNAME -- a name string to look up in the DNS"
- (cond ((listp addr)
- (destructuring-bind
- (net host)
- (pairify addr :next)
- (net-host (or (net-find net)
- (error "Network ~A not found" net))
- host)))
- ((ipaddrp addr) addr)
- (t
- (setf addr (string-downcase (stringify addr)))
- (or (host-find addr)
- (and (plusp (length addr))
- (digit-char-p (char addr 0))
- (string-ipaddr addr))
- (resolve-hostname (stringify addr))
- (error "Host name ~A unresolvable" addr)))))
-
-(defvar *hosts* (make-hash-table :test #'equal)
- "The table of known hostnames.")
-(defun host-find (name)
- "Find a host by NAME."
- (gethash (string-downcase (stringify name)) *hosts*))
-(defun (setf host-find) (addr name)
- "Make NAME map to ADDR (must be an ipaddr in integer form)."
- (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
-(defun host-create (name addr)
- "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
- (setf (host-find name) (parse-ipaddr addr)))
-(defmacro defhost (name addr)
- "Main host definition macro. Neither NAME nor ADDR is evaluated."
- `(progn
- (host-create ',name ',addr)
- ',name))
-
-(defstruct (net (:predicate netp))
- "A network structure. Slots:
-
-NAME The network's name, as a string
-IPNET The network base address and mask
-HOSTS Number of hosts in the network
-NEXT Index of the next unassigned host"
- name
- ipnet
- hosts
- next)
-
-(defvar *networks* (make-hash-table :test #'equal)
- "The table of known networks.")
-(defun net-find (name)
- "Find a network by NAME."
- (gethash (string-downcase (stringify name)) *networks*))
-(defun (setf net-find) (net name)
- "Make NAME map to NET."
- (setf (gethash (string-downcase (stringify name)) *networks*) net))
-(defun net-get-as-ipnet (form)
- "Transform FORM into an ipnet. FORM may be a network name, or something
-acceptable to the ipnet function."
- (let ((net (net-find form)))
- (if net (net-ipnet net)
- (ipnet form))))
-(defun net-create (name &rest args)
- "Construct a new network called NAME and add it to the map. The ARGS
-describe the new network, in a form acceptable to the ipnet function."
- (let ((ipn (apply #'ipnet args)))
- (setf (net-find name)
- (make-net :name (string-downcase (stringify name))
- :ipnet ipn
- :hosts (ipnet-hosts ipn)
- :next 1))))
-(defmacro defnet (name &rest args)
- "Main network definition macro. Neither NAME nor any of the ARGS is
-evaluated."
- `(progn
- (net-create ',name ,@(mapcar (lambda (x) `',x) args))
- ',name))
-(defun net-next-host (net)
- "Given a NET, return the IP address (as integer) of the next available
-address in the network."
- (unless (< (net-next net) (net-hosts net))
- (error "No more hosts left in network ~A" (net-name net)))
- (let ((next (net-next net)))
- (incf (net-next net))
- (net-host net next)))
-(defun net-host (net host)
- "Return the given HOST on the NEXT. HOST may be an index (in range, of
-course), or one of the keywords:
-:NEXT next host, as by net-next-host
-:NET network base address
-:BROADCAST network broadcast address"
- (case host
- (:next (net-next-host net))
- (:net (ipnet-net (net-ipnet net)))
- (:broadcast (ipnet-broadcast (net-ipnet net)))
- (t (ipnet-host (net-ipnet net) host))))
+;;;--------------------------------------------------------------------------
+;;; Various random utilities.
(defun to-integer (x)
"Convert X to an integer in the most straightforward way."
(floor (rational 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."
+ (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 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."
+ 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)
(cadr ts))))))
(timespec-seconds (cddr ts))))))
+(defun hash-table-keys (ht)
+ "Return a list of the keys in hashtable HT."
+ (collecting ()
+ (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
+
+(defun iso-date (&optional time &key datep timep (sep #\ ))
+ "Construct a textual date or time in ISO format. The TIME is the universal
+ time to convert, which defaults to now; DATEP is whether to emit the date;
+ TIMEP is whether to emit the time, and SEP (default is space) is how to
+ separate the two."
+ (multiple-value-bind
+ (sec min hr day mon yr dow dstp tz)
+ (decode-universal-time (if (or (null time) (eq time :now))
+ (get-universal-time)
+ time))
+ (declare (ignore dow dstp tz))
+ (with-output-to-string (s)
+ (when datep
+ (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
+ (when timep
+ (write-char sep s)))
+ (when timep
+ (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
+
+;;;--------------------------------------------------------------------------
+;;; Zone types.
+
(defstruct (soa (:predicate soap))
"Start-of-authority record information."
source
expire
min-ttl
serial)
+
(defstruct (mx (:predicate mxp))
"Mail-exchange record information."
priority
domain)
+
(defstruct (zone (:predicate zonep))
"Zone information."
soa
name
records)
+;;;--------------------------------------------------------------------------
+;;; Zone defaults. It is intended that scripts override these.
+
+#+ecl
+(cffi:defcfun gethostname :int
+ (name :pointer)
+ (len :uint))
+
(defvar *default-zone-source*
- (let ((hn (unix:unix-gethostname)))
+ (let ((hn #+cmu (unix:unix-gethostname)
+ #+clisp (unix:get-host-name)
+ #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
+ (let ((rc (gethostname buffer len)))
+ (unless (zerop rc)
+ (error "gethostname(2) failed (rc = ~A)." rc))))))
(and hn (concatenate 'string (canonify-hostname hn) ".")))
"The default zone source: the current host's name.")
+
(defvar *default-zone-refresh* (* 24 60 60)
"Default zone refresh interval: one day.")
+
(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)))))
+;;;--------------------------------------------------------------------------
+;;; Serial numbering.
(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."
+ 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
(cons seq now)))
(from-mixed-base '(100 100 100) (reverse (cons seq now)))))
+;;;--------------------------------------------------------------------------
+;;; Zone variables and structures.
+
(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-subdomain (:conc-name zs-))
"A subdomain. Slightly weird. Used internally by zone-process-records
-below, and shouldn't escape."
+ below, and shouldn't escape."
name
ttl
records)
+;;;--------------------------------------------------------------------------
+;;; Zone infrastructure.
+
(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."
+ the default time-to-live for records which don't specify one."
(labels ((sift (rec ttl)
(collecting (top sub)
(loop
(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."
+ otherwise it's relative to ZNAME."
(setf f (stringify f))
(cond ((string= f "@") (stringify zname))
((and (plusp (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)
+ "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)))
(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."
+ subdomain of in-addr.arpa."
(let ((ipn (net-get-as-ipnet net)))
(with-ipnet (net mask) ipn
(unless bytes
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)))
(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."
+ 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))
(defun zone-reverse (data name list)
"Process a :reverse record's DATA, for a domain called NAME, and add the
-records to the LIST."
+ records to the LIST."
(destructuring-bind
(net &key bytes zones)
(listify data)
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."
+ "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."
+ return the default deletate zone prefix."
(with-ipnet (net mask) ipn
(join-strings #\.
(reverse
(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."
+ TTL, write lots of CNAME records to LIST."
(destructuring-bind
(net &key bytes)
(listify (car data))
:data (join-strings #\. (list tail tdom)))
list)))))))
-
+;;;--------------------------------------------------------------------------
+;;; Zone form parsing.
(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."
+ 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
: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)
+ "Define a new zone record type (or TYPES -- a list of synonyms is
+ permitted). The arguments are as follows:
+
+ NAME The name of the record to be added.
+
+ DATA The content of the record to be added (a single object,
+ unevaluated).
+
+ LIST A function to add a record to the zone. See below.
+
+ ZNAME The name of the zone being constructed.
+
+ TTL The TTL for this record.
+
+ DEFSUBP Whether this is the default subdomain for this entry.
+
+ 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.
+
+ 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 :defsubp)
+
+ 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))))
+ (with-parsed-body (doc decls body body)
+ (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)
+ ,@doc
+ ,@decls
+ (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)))
(defun zone-parse (zf)
"Parse a ZONE form. The syntax of a zone form is as follows:
-ZONE-FORM:
- ZONE-HEAD ZONE-RECORD*
+ ZONE-FORM:
+ ZONE-HEAD ZONE-RECORD*
-ZONE-RECORD:
- ((NAME*) ZONE-RECORD*)
-| SYM ARGS"
+ ZONE-RECORD:
+ ((NAME*) ZONE-RECORD*)
+ | SYM ARGS"
(multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
(let ((zone (make-zone :name zname
:default-ttl ttl
(zone-parse-records zone (cdr zf))
zone)))
+(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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Zone record parsers.
+
(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))
(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))
(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 :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)))))
(defzoneparse (:rev :reverse) (name data rec)
":reverse ((NET :bytes BYTES) ZONE*)"
: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)))))
+;;;--------------------------------------------------------------------------
+;;; Zone file output.
(defun zone-write (zone &optional (stream *standard-output*))
"Write a ZONE's records to 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))
(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."
+ zones."
(unless zones
(setf zones (hash-table-keys *zones*)))
(safely (safe)
(unless zz
(error "Unknown zone `~A'." z))
(let ((stream (safely-open-output-stream safe
- (string-downcase
- (stringify z)))))
+ (format nil
+ "~(~A~).zone"
+ z))))
(zone-write zz stream))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / zone / blobdiff