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