chiark - git - mdw - zone/blob - zone.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; DNS zone generation
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Packaging.
  28
  29 (defpackage #:zone
  30   (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net)
  31   (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
  32            #:*default-zone-source* #:*default-zone-refresh*
  33              #:*default-zone-retry* #:*default-zone-expire*
  34              #:*default-zone-min-ttl* #:*default-zone-ttl*
  35              #:*default-mx-priority* #:*default-zone-admin*
  36            #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
  37            #:defrevzone #:zone-save
  38            #:defzoneparse #:zone-parse-host
  39            #:timespec-seconds #:make-zone-serial))
  40
  41 (in-package #:zone)
  42
  43 ;;;--------------------------------------------------------------------------
  44 ;;; Various random utilities.
  45
  46 (defun to-integer (x)
  47   "Convert X to an integer in the most straightforward way."
  48   (floor (rational x)))
  49
  50 (defun from-mixed-base (base val)
  51   "BASE is a list of the ranges for the `digits' of a mixed-base
  52    representation.  Convert VAL, a list of digits, into an integer."
  53   (do ((base base (cdr base))
  54        (val (cdr val) (cdr val))
  55        (a (car val) (+ (* a (car base)) (car val))))
  56       ((or (null base) (null val)) a)))
  57
  58 (defun to-mixed-base (base val)
  59   "BASE is a list of the ranges for the `digits' of a mixed-base
  60    representation.  Convert VAL, an integer, into a list of digits."
  61   (let ((base (reverse base))
  62         (a nil))
  63     (loop
  64       (unless base
  65         (push val a)
  66         (return a))
  67       (multiple-value-bind (q r) (floor val (pop base))
  68         (push r a)
  69         (setf val q)))))
  70
  71 (defun timespec-seconds (ts)
  72   "Convert a timespec TS to seconds.  A timespec may be a real count of
  73    seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
  74    time units."
  75   (cond ((null ts) 0)
  76         ((realp ts) (floor ts))
  77         ((atom ts)
  78          (error "Unknown timespec format ~A" ts))
  79         ((null (cdr ts))
  80          (timespec-seconds (car ts)))
  81         (t (+ (to-integer (* (car ts)
  82                              (case (intern (string-upcase
  83                                             (stringify (cadr ts)))
  84                                            '#:zone)
  85                                ((s sec secs second seconds) 1)
  86                                ((m min mins minute minutes) 60)
  87                                ((h hr hrs hour hours) #.(* 60 60))
  88                                ((d dy dys day days) #.(* 24 60 60))
  89                                ((w wk wks week weeks) #.(* 7 24 60 60))
  90                                ((y yr yrs year years) #.(* 365 24 60 60))
  91                                (t (error "Unknown time unit ~A"
  92                                          (cadr ts))))))
  93               (timespec-seconds (cddr ts))))))
  94
  95 (defun hash-table-keys (ht)
  96   "Return a list of the keys in hashtable HT."
  97   (collecting ()
  98     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
  99
 100 (defun iso-date (&optional time &key datep timep (sep #\ ))
 101   "Construct a textual date or time in ISO format.  The TIME is the universal
 102    time to convert, which defaults to now; DATEP is whether to emit the date;
 103    TIMEP is whether to emit the time, and SEP (default is space) is how to
 104    separate the two."
 105   (multiple-value-bind
 106       (sec min hr day mon yr dow dstp tz)
 107       (decode-universal-time (if (or (null time) (eq time :now))
 108                                  (get-universal-time)
 109                                  time))
 110     (declare (ignore dow dstp tz))
 111     (with-output-to-string (s)
 112       (when datep
 113         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 114         (when timep
 115           (write-char sep s)))
 116       (when timep
 117         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 118
 119 ;;;--------------------------------------------------------------------------
 120 ;;; Zone types.
 121
 122 (defstruct (soa (:predicate soap))
 123   "Start-of-authority record information."
 124   source
 125   admin
 126   refresh
 127   retry
 128   expire
 129   min-ttl
 130   serial)
 131
 132 (defstruct (mx (:predicate mxp))
 133   "Mail-exchange record information."
 134   priority
 135   domain)
 136
 137 (defstruct (zone (:predicate zonep))
 138   "Zone information."
 139   soa
 140   default-ttl
 141   name
 142   records)
 143
 144 ;;;--------------------------------------------------------------------------
 145 ;;; Zone defaults.  It is intended that scripts override these.
 146
 147 #+ecl
 148 (cffi:defcfun gethostname :int
 149   (name :pointer)
 150   (len :uint))
 151
 152 (defvar *default-zone-source*
 153   (let ((hn #+cmu (unix:unix-gethostname)
 154             #+clisp (unix:get-host-name)
 155             #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
 156                     (let ((rc (gethostname buffer len)))
 157                       (unless (zerop rc)
 158                         (error "gethostname(2) failed (rc = ~A)." rc))))))
 159     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 160   "The default zone source: the current host's name.")
 161
 162 (defvar *default-zone-refresh* (* 24 60 60)
 163   "Default zone refresh interval: one day.")
 164
 165 (defvar *default-zone-admin* nil
 166   "Default zone administrator's email address.")
 167
 168 (defvar *default-zone-retry* (* 60 60)
 169   "Default znoe retry interval: one hour.")
 170
 171 (defvar *default-zone-expire* (* 14 24 60 60)
 172   "Default zone expiry time: two weeks.")
 173
 174 (defvar *default-zone-min-ttl* (* 4 60 60)
 175   "Default zone minimum TTL/negative TTL: four hours.")
 176
 177 (defvar *default-zone-ttl* (* 8 60 60)
 178   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 179
 180 (defvar *default-mx-priority* 50
 181   "Default MX priority.")
 182
 183 ;;;--------------------------------------------------------------------------
 184 ;;; Serial numbering.
 185
 186 (defun make-zone-serial (name)
 187   "Given a zone NAME, come up with a new serial number.  This will (very
 188    carefully) update a file ZONE.serial in the current directory."
 189   (let* ((file (format nil "~(~A~).serial" name))
 190          (last (with-open-file (in file
 191                                    :direction :input
 192                                    :if-does-not-exist nil)
 193                  (if in (read in)
 194                      (list 0 0 0 0))))
 195          (now (multiple-value-bind
 196                   (sec min hr dy mon yr dow dstp tz)
 197                   (get-decoded-time)
 198                 (declare (ignore sec min hr dow dstp tz))
 199                 (list dy mon yr)))
 200          (seq (cond ((not (equal now (cdr last))) 0)
 201                     ((< (car last) 99) (1+ (car last)))
 202                     (t (error "Run out of sequence numbers for ~A" name)))))
 203     (safely-writing (out file)
 204       (format out
 205               ";; Serial number file for zone ~A~%~
 206                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 207                ~S~%"
 208               name
 209               (cons seq now)))
 210     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 211
 212 ;;;--------------------------------------------------------------------------
 213 ;;; Zone variables and structures.
 214
 215 (defvar *zones* (make-hash-table :test #'equal)
 216   "Map of known zones.")
 217
 218 (defun zone-find (name)
 219   "Find a zone given its NAME."
 220   (gethash (string-downcase (stringify name)) *zones*))
 221
 222 (defun (setf zone-find) (zone name)
 223   "Make the zone NAME map to ZONE."
 224   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 225
 226 (defstruct (zone-record (:conc-name zr-))
 227   "A zone record."
 228   (name '<unnamed>)
 229   ttl
 230   type
 231   (defsubp nil)
 232   data)
 233
 234 (defstruct (zone-subdomain (:conc-name zs-))
 235   "A subdomain.  Slightly weird.  Used internally by zone-process-records
 236    below, and shouldn't escape."
 237   name
 238   ttl
 239   records)
 240
 241 ;;;--------------------------------------------------------------------------
 242 ;;; Zone infrastructure.
 243
 244 (defun zone-process-records (rec ttl func)
 245   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
 246    the default time-to-live for records which don't specify one."
 247   (labels ((sift (rec ttl)
 248              (collecting (top sub)
 249                (loop
 250                  (unless rec
 251                    (return))
 252                  (let ((r (pop rec)))
 253                    (cond ((eq r :ttl)
 254                           (setf ttl (pop rec)))
 255                          ((symbolp r)
 256                           (collect (make-zone-record :type r
 257                                                      :ttl ttl
 258                                                      :data (pop rec))
 259                                    top))
 260                          ((listp r)
 261                           (dolist (name (listify (car r)))
 262                             (collect (make-zone-subdomain :name name
 263                                                           :ttl ttl
 264                                                           :records (cdr r))
 265                                      sub)))
 266                          (t
 267                           (error "Unexpected record form ~A" (car r))))))))
 268            (process (rec dom ttl defsubp)
 269              (multiple-value-bind (top sub) (sift rec ttl)
 270                (if (and dom (null top) sub)
 271                    (let ((s (pop sub)))
 272                      (process (zs-records s)
 273                               dom
 274                               (zs-ttl s)
 275                               defsubp)
 276                      (process (zs-records s)
 277                               (cons (zs-name s) dom)
 278                               (zs-ttl s)
 279                               t))
 280                  (let ((name (and dom
 281                                   (string-downcase
 282                                    (join-strings #\. (reverse dom))))))
 283                    (dolist (zr top)
 284                      (setf (zr-name zr) name)
 285                      (setf (zr-defsubp zr) defsubp)
 286                      (funcall func zr))))
 287                (dolist (s sub)
 288                  (process (zs-records s)
 289                           (cons (zs-name s) dom)
 290                           (zs-ttl s)
 291                           defsubp)))))
 292     (process rec nil ttl nil)))
 293
 294 (defun zone-parse-host (f zname)
 295   "Parse a host name F: if F ends in a dot then it's considered absolute;
 296    otherwise it's relative to ZNAME."
 297   (setf f (stringify f))
 298   (cond ((string= f "@") (stringify zname))
 299         ((and (plusp (length f))
 300               (char= (char f (1- (length f))) #\.))
 301          (string-downcase (subseq f 0 (1- (length f)))))
 302         (t (string-downcase (concatenate 'string f "."
 303                                          (stringify zname))))))
 304 (defun default-rev-zone (base bytes)
 305   "Return the default reverse-zone name for the given BASE address and number
 306    of fixed leading BYTES."
 307   (join-strings #\. (collecting ()
 308                       (loop for i from (- 3 bytes) downto 0
 309                             do (collect (ipaddr-byte base i)))
 310                       (collect "in-addr.arpa"))))
 311
 312 (defun zone-name-from-net (net &optional bytes)
 313   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 314    subdomain of in-addr.arpa."
 315   (let ((ipn (net-get-as-ipnet net)))
 316     (with-ipnet (net mask) ipn
 317       (unless bytes
 318         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 319       (join-strings #\.
 320                     (append (loop
 321                                for i from (- 4 bytes) below 4
 322                                collect (logand #xff (ash net (* -8 i))))
 323                             (list "in-addr.arpa"))))))
 324
 325 (defun zone-net-from-name (name)
 326   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 327   (let* ((name (string-downcase (stringify name)))
 328          (len (length name))
 329          (suffix ".in-addr.arpa")
 330          (sufflen (length suffix))
 331          (addr 0)
 332          (n 0)
 333          (end (- len sufflen)))
 334     (unless (and (> len sufflen)
 335                  (string= name suffix :start1 end))
 336       (error "`~A' not in ~A." name suffix))
 337     (loop
 338        with start = 0
 339        for dot = (position #\. name :start start :end end)
 340        for byte = (parse-integer name
 341                                  :start start
 342                                  :end (or dot end))
 343        do (setf addr (logior addr (ash byte (* 8 n))))
 344           (incf n)
 345        when (>= n 4)
 346        do (error "Can't deduce network from ~A." name)
 347        while dot
 348        do (setf start (1+ dot)))
 349     (setf addr (ash addr (* 8 (- 4 n))))
 350     (make-ipnet addr (* 8 n))))
 351
 352 (defun zone-parse-net (net name)
 353   "Given a NET, and the NAME of a domain to guess from if NET is null, return
 354    the ipnet for the network."
 355   (if net
 356       (net-get-as-ipnet net)
 357       (zone-net-from-name name)))
 358
 359 (defun zone-cidr-delg-default-name (ipn bytes)
 360   "Given a delegated net IPN and the parent's number of changing BYTES,
 361    return the default deletate zone prefix."
 362   (with-ipnet (net mask) ipn
 363     (join-strings #\.
 364                   (reverse
 365                    (loop
 366                       for i from (1- bytes) downto 0
 367                       until (zerop (logand mask (ash #xff (* 8 i))))
 368                       collect (logand #xff (ash net (* -8 i))))))))
 369
 370 (defun zone-cidr-delegation (data name ttl list)
 371   "Given :cidr-delegation info DATA, for a record called NAME and the current
 372    TTL, write lots of CNAME records to LIST."
 373   (destructuring-bind
 374       (net &key bytes)
 375       (listify (car data))
 376     (setf net (zone-parse-net net name))
 377     (unless bytes
 378       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 379     (dolist (map (cdr data))
 380       (destructuring-bind
 381           (tnet &optional tdom)
 382           (listify map)
 383         (setf tnet (zone-parse-net tnet name))
 384         (unless (ipnet-subnetp net tnet)
 385           (error "~A is not a subnet of ~A."
 386                  (ipnet-pretty tnet)
 387                  (ipnet-pretty net)))
 388         (unless tdom
 389           (setf tdom
 390                 (join-strings #\.
 391                               (list (zone-cidr-delg-default-name tnet bytes)
 392                                     name))))
 393         (setf tdom (string-downcase tdom))
 394         (dotimes (i (ipnet-hosts tnet))
 395           (let* ((addr (ipnet-host tnet i))
 396                  (tail (join-strings #\.
 397                                      (loop
 398                                         for i from 0 below bytes
 399                                         collect
 400                                           (logand #xff
 401                                                   (ash addr (* 8 i)))))))
 402             (collect (make-zone-record
 403                       :name (join-strings #\.
 404                                           (list tail name))
 405                       :type :cname
 406                       :ttl ttl
 407                       :data (join-strings #\. (list tail tdom)))
 408                      list)))))))
 409
 410 ;;;--------------------------------------------------------------------------
 411 ;;; Zone form parsing.
 412
 413 (defun zone-parse-head (head)
 414   "Parse the HEAD of a zone form.  This has the form
 415
 416      (NAME &key :source :admin :refresh :retry
 417                 :expire :min-ttl :ttl :serial)
 418
 419    though a singleton NAME needn't be a list.  Returns the default TTL and an
 420    soa structure representing the zone head."
 421   (destructuring-bind
 422       (zname
 423        &key
 424        (source *default-zone-source*)
 425        (admin (or *default-zone-admin*
 426                   (format nil "hostmaster@~A" zname)))
 427        (refresh *default-zone-refresh*)
 428        (retry *default-zone-retry*)
 429        (expire *default-zone-expire*)
 430        (min-ttl *default-zone-min-ttl*)
 431        (ttl min-ttl)
 432        (serial (make-zone-serial zname)))
 433       (listify head)
 434     (values zname
 435             (timespec-seconds ttl)
 436             (make-soa :admin admin
 437                       :source (zone-parse-host source zname)
 438                       :refresh (timespec-seconds refresh)
 439                       :retry (timespec-seconds retry)
 440                       :expire (timespec-seconds expire)
 441                       :min-ttl (timespec-seconds min-ttl)
 442                       :serial serial))))
 443
 444 (defmacro defzoneparse (types (name data list
 445                                &key (zname (gensym "ZNAME"))
 446                                     (ttl (gensym "TTL"))
 447                                     (defsubp (gensym "DEFSUBP")))
 448                         &body body)
 449   "Define a new zone record type (or TYPES -- a list of synonyms is
 450    permitted).  The arguments are as follows:
 451
 452    NAME         The name of the record to be added.
 453
 454    DATA         The content of the record to be added (a single object,
 455                 unevaluated).
 456
 457    LIST         A function to add a record to the zone.  See below.
 458
 459    ZNAME        The name of the zone being constructed.
 460
 461    TTL          The TTL for this record.
 462
 463    DEFSUBP      Whether this is the default subdomain for this entry.
 464
 465    You get to choose your own names for these.  ZNAME, TTL and DEFSUBP are
 466    optional: you don't have to accept them if you're not interested.
 467
 468    The LIST argument names a function to be bound in the body to add a new
 469    low-level record to the zone.  It has the prototype
 470
 471      (LIST &key :name :type :data :ttl :defsubp)
 472
 473    Except for defsubp, these default to the above arguments (even if you
 474    didn't accept the arguments)."
 475   (setf types (listify types))
 476   (let* ((type (car types))
 477          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 478     (with-parsed-body (body decls doc) body
 479       (with-gensyms (col tname ttype tttl tdata tdefsubp i)
 480         `(progn
 481            (dolist (,i ',types)
 482              (setf (get ,i 'zone-parse) ',func))
 483            (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
 484              ,@doc
 485              ,@decls
 486              (declare (ignorable ,zname ,defsubp))
 487              (flet ((,list (&key ((:name ,tname) ,name)
 488                                  ((:type ,ttype) ,type)
 489                                  ((:data ,tdata) ,data)
 490                                  ((:ttl ,tttl) ,ttl)
 491                                  ((:defsubp ,tdefsubp) nil))
 492                       (collect (make-zone-record :name ,tname
 493                                                  :type ,ttype
 494                                                  :data ,tdata
 495                                                  :ttl ,tttl
 496                                                  :defsubp ,tdefsubp)
 497                                ,col)))
 498                ,@body))
 499            ',type)))))
 500
 501 (defun zone-parse-records (zone records)
 502   (let ((zname (zone-name zone)))
 503     (with-collection (rec)
 504         (flet ((parse-record (zr)
 505                  (let ((func (or (get (zr-type zr) 'zone-parse)
 506                                  (error "No parser for record ~A."
 507                                         (zr-type zr))))
 508                        (name (and (zr-name zr)
 509                                   (stringify (zr-name zr)))))
 510                    (if (or (not name)
 511                            (string= name "@"))
 512                        (setf name zname)
 513                        (let ((len (length name)))
 514                          (if (or (zerop len)
 515                                  (char/= (char name (1- len)) #\.))
 516                              (setf name (join-strings #\.
 517                                                       (list name zname))))))
 518                    (funcall func
 519                             name
 520                             (zr-data zr)
 521                             (zr-ttl zr)
 522                             rec
 523                             zname
 524                             (zr-defsubp zr)))))
 525           (zone-process-records records
 526                                 (zone-default-ttl zone)
 527                                 #'parse-record))
 528       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 529
 530 (defun zone-parse (zf)
 531   "Parse a ZONE form.  The syntax of a zone form is as follows:
 532
 533    ZONE-FORM:
 534      ZONE-HEAD ZONE-RECORD*
 535
 536    ZONE-RECORD:
 537      ((NAME*) ZONE-RECORD*)
 538    | SYM ARGS"
 539   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 540     (let ((zone (make-zone :name zname
 541                            :default-ttl ttl
 542                            :soa soa
 543                            :records nil)))
 544       (zone-parse-records zone (cdr zf))
 545       zone)))
 546
 547 (defun zone-create (zf)
 548   "Zone construction function.  Given a zone form ZF, construct the zone and
 549    add it to the table."
 550   (let* ((zone (zone-parse zf))
 551          (name (zone-name zone)))
 552     (setf (zone-find name) zone)
 553     name))
 554
 555 (defmacro defzone (soa &rest zf)
 556   "Zone definition macro."
 557   `(zone-create '(,soa ,@zf)))
 558
 559 (defmacro defrevzone (head &rest zf)
 560   "Define a reverse zone, with the correct name."
 561   (destructuring-bind
 562       (net &rest soa-args)
 563       (listify head)
 564     (let ((bytes nil))
 565       (when (and soa-args (integerp (car soa-args)))
 566         (setf bytes (pop soa-args)))
 567       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 568
 569 ;;;--------------------------------------------------------------------------
 570 ;;; Zone record parsers.
 571
 572 (defzoneparse :a (name data rec :defsubp defsubp)
 573   ":a IPADDR"
 574   (rec :data (parse-ipaddr data) :defsubp defsubp))
 575
 576 (defzoneparse :ptr (name data rec :zname zname)
 577   ":ptr HOST"
 578   (rec :data (zone-parse-host data zname)))
 579
 580 (defzoneparse :cname (name data rec :zname zname)
 581   ":cname HOST"
 582   (rec :data (zone-parse-host data zname)))
 583
 584 (defzoneparse :mx (name data rec :zname zname)
 585   ":mx ((HOST :prio INT :ip IPADDR)*)"
 586   (dolist (mx (listify data))
 587     (destructuring-bind
 588         (mxname &key (prio *default-mx-priority*) ip)
 589         (listify mx)
 590       (let ((host (zone-parse-host mxname zname)))
 591         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 592         (rec :data (cons host prio))))))
 593
 594 (defzoneparse :ns (name data rec :zname zname)
 595   ":ns ((HOST :ip IPADDR)*)"
 596   (dolist (ns (listify data))
 597     (destructuring-bind
 598         (nsname &key ip)
 599         (listify ns)
 600       (let ((host (zone-parse-host nsname zname)))
 601         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 602         (rec :data host)))))
 603
 604 (defzoneparse :alias (name data rec :zname zname)
 605   ":alias (LABEL*)"
 606   (dolist (a (listify data))
 607     (rec :name (zone-parse-host a zname)
 608          :type :cname
 609          :data name)))
 610
 611 (defzoneparse :net (name data rec)
 612   ":net (NETWORK*)"
 613   (dolist (net (listify data))
 614     (let ((n (net-get-as-ipnet net)))
 615       (rec :name (zone-parse-host "net" name)
 616            :type :a
 617            :data (ipnet-net n))
 618       (rec :name (zone-parse-host "mask" name)
 619            :type :a
 620            :data (ipnet-mask n))
 621       (rec :name (zone-parse-host "broadcast" name)
 622            :type :a
 623            :data (ipnet-broadcast n)))))
 624
 625 (defzoneparse (:rev :reverse) (name data rec)
 626   ":reverse ((NET :bytes BYTES) ZONE*)"
 627   (setf data (listify data))
 628   (destructuring-bind
 629       (net &key bytes)
 630       (listify (car data))
 631     (setf net (zone-parse-net net name))
 632     (unless bytes
 633       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 634     (dolist (z (or (cdr data)
 635                    (hash-table-keys *zones*)))
 636       (dolist (zr (zone-records (zone-find z)))
 637         (when (and (eq (zr-type zr) :a)
 638                    (not (zr-defsubp zr))
 639                    (ipaddr-networkp (zr-data zr) net))
 640           (rec :name (string-downcase
 641                       (join-strings
 642                        #\.
 643                        (collecting ()
 644                          (dotimes (i bytes)
 645                            (collect (logand #xff (ash (zr-data zr)
 646                                                       (* -8 i)))))
 647                          (collect name))))
 648                :type :ptr
 649                :ttl (zr-ttl zr)
 650                :data (zr-name zr)))))))
 651
 652 (defzoneparse (:cidr-delegation :cidr) (name data rec)
 653   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
 654   (destructuring-bind
 655       (net &key bytes)
 656       (listify (car data))
 657     (setf net (zone-parse-net net name))
 658     (unless bytes
 659       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 660     (dolist (map (cdr data))
 661       (destructuring-bind
 662           (tnet &optional tdom)
 663           (listify map)
 664         (setf tnet (zone-parse-net tnet name))
 665         (unless (ipnet-subnetp net tnet)
 666           (error "~A is not a subnet of ~A."
 667                  (ipnet-pretty tnet)
 668                  (ipnet-pretty net)))
 669         (unless tdom
 670           (with-ipnet (net mask) tnet
 671             (setf tdom
 672                   (join-strings
 673                    #\.
 674                    (append (reverse (loop
 675                                        for i from (1- bytes) downto 0
 676                                        until (zerop (logand mask
 677                                                             (ash #xff
 678                                                                  (* 8 i))))
 679                                        collect (logand #xff
 680                                                        (ash net (* -8 i)))))
 681                            (list name))))))
 682         (setf tdom (string-downcase tdom))
 683         (dotimes (i (ipnet-hosts tnet))
 684           (let* ((addr (ipnet-host tnet i))
 685                  (tail (join-strings #\.
 686                                      (loop
 687                                         for i from 0 below bytes
 688                                         collect
 689                                           (logand #xff
 690                                                   (ash addr (* 8 i)))))))
 691             (rec :name (format nil "~A.~A" tail name)
 692                  :type :cname
 693                  :data (format nil "~A.~A" tail tdom))))))))
 694
 695 ;;;--------------------------------------------------------------------------
 696 ;;; Zone file output.
 697
 698 (defun zone-write (zone &optional (stream *standard-output*))
 699   "Write a ZONE's records to STREAM."
 700   (labels ((fix-admin (a)
 701              (let ((at (position #\@ a))
 702                    (s (concatenate 'string (string-downcase a) ".")))
 703                (when s
 704                  (setf (char s at) #\.))
 705                s))
 706            (fix-host (h)
 707              (if (not h)
 708                  "@"
 709                  (let* ((h (string-downcase (stringify h)))
 710                         (hl (length h))
 711                         (r (string-downcase (zone-name zone)))
 712                         (rl (length r)))
 713                    (cond ((string= r h) "@")
 714                          ((and (> hl rl)
 715                                (char= (char h (- hl rl 1)) #\.)
 716                                (string= h r :start1 (- hl rl)))
 717                           (subseq h 0 (- hl rl 1)))
 718                          (t (concatenate 'string h "."))))))
 719            (printrec (zr)
 720              (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
 721                      (fix-host (zr-name zr))
 722                      (and (/= (zr-ttl zr) (zone-default-ttl zone))
 723                           (zr-ttl zr))
 724                      (string-upcase (symbol-name (zr-type zr))))))
 725     (format stream "~
 726 ;;; Zone file `~(~A~)'
 727 ;;;   (generated ~A)
 728
 729 $ORIGIN ~0@*~(~A.~)
 730 $TTL ~2@*~D~2%"
 731             (zone-name zone)
 732             (iso-date :now :datep t :timep t)
 733             (zone-default-ttl zone))
 734     (let ((soa (zone-soa zone)))
 735       (format stream "~
 736 ~A~30TIN SOA~40T~A ~A (
 737 ~45T~10D~60T ;serial
 738 ~45T~10D~60T ;refresh
 739 ~45T~10D~60T ;retry
 740 ~45T~10D~60T ;expire
 741 ~45T~10D )~60T ;min-ttl~2%"
 742               (fix-host (zone-name zone))
 743               (fix-host (soa-source soa))
 744               (fix-admin (soa-admin soa))
 745               (soa-serial soa)
 746               (soa-refresh soa)
 747               (soa-retry soa)
 748               (soa-expire soa)
 749               (soa-min-ttl soa)))
 750     (dolist (zr (zone-records zone))
 751       (ecase (zr-type zr)
 752         (:a
 753          (printrec zr)
 754          (format stream "~A~%" (ipaddr-string (zr-data zr))))
 755         ((:ptr :cname :ns)
 756          (printrec zr)
 757          (format stream "~A~%" (fix-host (zr-data zr))))
 758         (:mx
 759          (printrec zr)
 760          (let ((mx (zr-data zr)))
 761            (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
 762         (:txt
 763          (printrec zr)
 764          (format stream "~S~%" (stringify (zr-data zr))))))))
 765
 766 (defun zone-save (zones)
 767   "Write the named ZONES to files.  If no zones are given, write all the
 768    zones."
 769   (unless zones
 770     (setf zones (hash-table-keys *zones*)))
 771   (safely (safe)
 772     (dolist (z zones)
 773       (let ((zz (zone-find z)))
 774         (unless zz
 775           (error "Unknown zone `~A'." z))
 776         (let ((stream (safely-open-output-stream safe
 777                                                  (format nil
 778                                                          "~(~A~).zone"
 779                                                          z))))
 780           (zone-write zz stream))))))
 781
 782 ;;;----- That's all, folks --------------------------------------------------