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-output-path*
  37            #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
  38            #:defrevzone #:zone-save #:zone-make-name
  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   (make-ptr-p 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)
 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                      (process (zs-records s)
 257                               (cons (zs-name s) dom)
 258                               (zs-ttl s)))
 259                  (let ((name (and dom
 260                                   (string-downcase
 261                                    (join-strings #\. (reverse dom))))))
 262                    (dolist (zr top)
 263                      (setf (zr-name zr) name)
 264                      (funcall func zr))))
 265                (dolist (s sub)
 266                  (process (zs-records s)
 267                           (cons (zs-name s) dom)
 268                           (zs-ttl s))))))
 269     (process rec nil ttl)))
 270
 271 (defun zone-parse-host (f zname)
 272   "Parse a host name F: if F ends in a dot then it's considered absolute;
 273    otherwise it's relative to ZNAME."
 274   (setf f (stringify f))
 275   (cond ((string= f "@") (stringify zname))
 276         ((and (plusp (length f))
 277               (char= (char f (1- (length f))) #\.))
 278          (string-downcase (subseq f 0 (1- (length f)))))
 279         (t (string-downcase (concatenate 'string f "."
 280                                          (stringify zname))))))
 281 (defun default-rev-zone (base bytes)
 282   "Return the default reverse-zone name for the given BASE address and number
 283    of fixed leading BYTES."
 284   (join-strings #\. (collecting ()
 285                       (loop for i from (- 3 bytes) downto 0
 286                             do (collect (ipaddr-byte base i)))
 287                       (collect "in-addr.arpa"))))
 288
 289 (defun zone-name-from-net (net &optional bytes)
 290   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 291    subdomain of in-addr.arpa."
 292   (let ((ipn (net-get-as-ipnet net)))
 293     (with-ipnet (net mask) ipn
 294       (unless bytes
 295         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 296       (join-strings #\.
 297                     (append (loop
 298                                for i from (- 4 bytes) below 4
 299                                collect (logand #xff (ash net (* -8 i))))
 300                             (list "in-addr.arpa"))))))
 301
 302 (defun zone-net-from-name (name)
 303   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 304   (let* ((name (string-downcase (stringify name)))
 305          (len (length name))
 306          (suffix ".in-addr.arpa")
 307          (sufflen (length suffix))
 308          (addr 0)
 309          (n 0)
 310          (end (- len sufflen)))
 311     (unless (and (> len sufflen)
 312                  (string= name suffix :start1 end))
 313       (error "`~A' not in ~A." name suffix))
 314     (loop
 315        with start = 0
 316        for dot = (position #\. name :start start :end end)
 317        for byte = (parse-integer name
 318                                  :start start
 319                                  :end (or dot end))
 320        do (setf addr (logior addr (ash byte (* 8 n))))
 321           (incf n)
 322        when (>= n 4)
 323        do (error "Can't deduce network from ~A." name)
 324        while dot
 325        do (setf start (1+ dot)))
 326     (setf addr (ash addr (* 8 (- 4 n))))
 327     (make-ipnet addr (* 8 n))))
 328
 329 (defun zone-parse-net (net name)
 330   "Given a NET, and the NAME of a domain to guess from if NET is null, return
 331    the ipnet for the network."
 332   (if net
 333       (net-get-as-ipnet net)
 334       (zone-net-from-name name)))
 335
 336 (defun zone-cidr-delg-default-name (ipn bytes)
 337   "Given a delegated net IPN and the parent's number of changing BYTES,
 338    return the default deletate zone prefix."
 339   (with-ipnet (net mask) ipn
 340     (join-strings #\.
 341                   (reverse
 342                    (loop
 343                       for i from (1- bytes) downto 0
 344                       until (zerop (logand mask (ash #xff (* 8 i))))
 345                       collect (logand #xff (ash net (* -8 i))))))))
 346
 347 (defun zone-cidr-delegation (data name ttl list)
 348   "Given :cidr-delegation info DATA, for a record called NAME and the current
 349    TTL, write lots of CNAME records to LIST."
 350   (destructuring-bind
 351       (net &key bytes)
 352       (listify (car data))
 353     (setf net (zone-parse-net net name))
 354     (unless bytes
 355       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 356     (dolist (map (cdr data))
 357       (destructuring-bind
 358           (tnet &optional tdom)
 359           (listify map)
 360         (setf tnet (zone-parse-net tnet name))
 361         (unless (ipnet-subnetp net tnet)
 362           (error "~A is not a subnet of ~A."
 363                  (ipnet-pretty tnet)
 364                  (ipnet-pretty net)))
 365         (unless tdom
 366           (setf tdom
 367                 (join-strings #\.
 368                               (list (zone-cidr-delg-default-name tnet bytes)
 369                                     name))))
 370         (setf tdom (string-downcase tdom))
 371         (dotimes (i (ipnet-hosts tnet))
 372           (let* ((addr (ipnet-host tnet i))
 373                  (tail (join-strings #\.
 374                                      (loop
 375                                         for i from 0 below bytes
 376                                         collect
 377                                           (logand #xff
 378                                                   (ash addr (* 8 i)))))))
 379             (collect (make-zone-record
 380                       :name (join-strings #\.
 381                                           (list tail name))
 382                       :type :cname
 383                       :ttl ttl
 384                       :data (join-strings #\. (list tail tdom)))
 385                      list)))))))
 386
 387 ;;;--------------------------------------------------------------------------
 388 ;;; Serial numbering.
 389
 390 (defun make-zone-serial (name)
 391   "Given a zone NAME, come up with a new serial number.  This will (very
 392    carefully) update a file ZONE.serial in the current directory."
 393   (let* ((file (zone-file-name name :serial))
 394          (last (with-open-file (in file
 395                                    :direction :input
 396                                    :if-does-not-exist nil)
 397                  (if in (read in)
 398                      (list 0 0 0 0))))
 399          (now (multiple-value-bind
 400                   (sec min hr dy mon yr dow dstp tz)
 401                   (get-decoded-time)
 402                 (declare (ignore sec min hr dow dstp tz))
 403                 (list dy mon yr)))
 404          (seq (cond ((not (equal now (cdr last))) 0)
 405                     ((< (car last) 99) (1+ (car last)))
 406                     (t (error "Run out of sequence numbers for ~A" name)))))
 407     (safely-writing (out file)
 408       (format out
 409               ";; Serial number file for zone ~A~%~
 410                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 411                ~S~%"
 412               name
 413               (cons seq now)))
 414     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 415
 416 ;;;--------------------------------------------------------------------------
 417 ;;; Zone form parsing.
 418
 419 (defun zone-parse-head (head)
 420   "Parse the HEAD of a zone form.  This has the form
 421
 422      (NAME &key :source :admin :refresh :retry
 423                 :expire :min-ttl :ttl :serial)
 424
 425    though a singleton NAME needn't be a list.  Returns the default TTL and an
 426    soa structure representing the zone head."
 427   (destructuring-bind
 428       (zname
 429        &key
 430        (source *default-zone-source*)
 431        (admin (or *default-zone-admin*
 432                   (format nil "hostmaster@~A" zname)))
 433        (refresh *default-zone-refresh*)
 434        (retry *default-zone-retry*)
 435        (expire *default-zone-expire*)
 436        (min-ttl *default-zone-min-ttl*)
 437        (ttl min-ttl)
 438        (serial (make-zone-serial zname)))
 439       (listify head)
 440     (values zname
 441             (timespec-seconds ttl)
 442             (make-soa :admin admin
 443                       :source (zone-parse-host source zname)
 444                       :refresh (timespec-seconds refresh)
 445                       :retry (timespec-seconds retry)
 446                       :expire (timespec-seconds expire)
 447                       :min-ttl (timespec-seconds min-ttl)
 448                       :serial serial))))
 449
 450 (defun zone-make-name (prefix zone-name)
 451   (if (or (not prefix) (string= prefix "@"))
 452       zone-name
 453       (let ((len (length prefix)))
 454         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
 455             (join-strings #\. (list prefix zone-name))
 456             prefix))))
 457
 458 (defmacro defzoneparse (types (name data list
 459                                &key (prefix (gensym "PREFIX"))
 460                                     (zname (gensym "ZNAME"))
 461                                     (ttl (gensym "TTL")))
 462                         &body body)
 463   "Define a new zone record type (or TYPES -- a list of synonyms is
 464    permitted).  The arguments are as follows:
 465
 466    NAME         The name of the record to be added.
 467
 468    DATA         The content of the record to be added (a single object,
 469                 unevaluated).
 470
 471    LIST         A function to add a record to the zone.  See below.
 472
 473    PREFIX       The prefix tag used in the original form.
 474
 475    ZNAME        The name of the zone being constructed.
 476
 477    TTL          The TTL for this record.
 478
 479    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 480    optional: you don't have to accept them if you're not interested.
 481
 482    The LIST argument names a function to be bound in the body to add a new
 483    low-level record to the zone.  It has the prototype
 484
 485      (LIST &key :name :type :data :ttl :make-ptr-p)
 486
 487    These (except MAKE-PTR-P, which defaults to nil) default to the above
 488    arguments (even if you didn't accept the arguments)."
 489   (setf types (listify types))
 490   (let* ((type (car types))
 491          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 492     (with-parsed-body (body decls doc) body
 493       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 494         `(progn
 495            (dolist (,i ',types)
 496              (setf (get ,i 'zone-parse) ',func))
 497            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 498              ,@doc
 499              ,@decls
 500              (let ((,name (zone-make-name ,prefix ,zname)))
 501                (flet ((,list (&key ((:name ,tname) ,name)
 502                                    ((:type ,ttype) ,type)
 503                                    ((:data ,tdata) ,data)
 504                                    ((:ttl ,tttl) ,ttl)
 505                                    ((:make-ptr-p ,tmakeptrp) nil))
 506                         (collect (make-zone-record :name ,tname
 507                                                    :type ,ttype
 508                                                    :data ,tdata
 509                                                    :ttl ,tttl
 510                                                    :make-ptr-p ,tmakeptrp)
 511                                  ,col)))
 512                  ,@body)))
 513           ',type)))))
 514
 515 (defun zone-parse-records (zone records)
 516   (let ((zname (zone-name zone)))
 517     (with-collection (rec)
 518         (flet ((parse-record (zr)
 519                  (let ((func (or (get (zr-type zr) 'zone-parse)
 520                                  (error "No parser for record ~A."
 521                                         (zr-type zr))))
 522                        (name (and (zr-name zr) (stringify (zr-name zr)))))
 523                    (funcall func
 524                             name
 525                             zname
 526                             (zr-data zr)
 527                             (zr-ttl zr)
 528                             rec))))
 529           (zone-process-records records
 530                                 (zone-default-ttl zone)
 531                                 #'parse-record))
 532       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 533
 534 (defun zone-parse (zf)
 535   "Parse a ZONE form.  The syntax of a zone form is as follows:
 536
 537    ZONE-FORM:
 538      ZONE-HEAD ZONE-RECORD*
 539
 540    ZONE-RECORD:
 541      ((NAME*) ZONE-RECORD*)
 542    | SYM ARGS"
 543   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 544     (let ((zone (make-zone :name zname
 545                            :default-ttl ttl
 546                            :soa soa
 547                            :records nil)))
 548       (zone-parse-records zone (cdr zf))
 549       zone)))
 550
 551 (defun zone-create (zf)
 552   "Zone construction function.  Given a zone form ZF, construct the zone and
 553    add it to the table."
 554   (let* ((zone (zone-parse zf))
 555          (name (zone-name zone)))
 556     (setf (zone-find name) zone)
 557     name))
 558
 559 (defmacro defzone (soa &rest zf)
 560   "Zone definition macro."
 561   `(zone-create '(,soa ,@zf)))
 562
 563 (defmacro defrevzone (head &rest zf)
 564   "Define a reverse zone, with the correct name."
 565   (destructuring-bind
 566       (net &rest soa-args)
 567       (listify head)
 568     (let ((bytes nil))
 569       (when (and soa-args (integerp (car soa-args)))
 570         (setf bytes (pop soa-args)))
 571       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 572
 573 ;;;--------------------------------------------------------------------------
 574 ;;; Zone record parsers.
 575
 576 (defzoneparse :a (name data rec)
 577   ":a IPADDR"
 578   (rec :data (parse-ipaddr data) :make-ptr-p t))
 579
 580 (defzoneparse :svc (name data rec)
 581   ":svc IPADDR"
 582   (rec :type :a :data (parse-ipaddr data)))
 583
 584 (defzoneparse :ptr (name data rec :zname zname)
 585   ":ptr HOST"
 586   (rec :data (zone-parse-host data zname)))
 587
 588 (defzoneparse :cname (name data rec :zname zname)
 589   ":cname HOST"
 590   (rec :data (zone-parse-host data zname)))
 591
 592 (defzoneparse :mx (name data rec :zname zname)
 593   ":mx ((HOST :prio INT :ip IPADDR)*)"
 594   (dolist (mx (listify data))
 595     (destructuring-bind
 596         (mxname &key (prio *default-mx-priority*) ip)
 597         (listify mx)
 598       (let ((host (zone-parse-host mxname zname)))
 599         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 600         (rec :data (cons host prio))))))
 601
 602 (defzoneparse :ns (name data rec :zname zname)
 603   ":ns ((HOST :ip IPADDR)*)"
 604   (dolist (ns (listify data))
 605     (destructuring-bind
 606         (nsname &key ip)
 607         (listify ns)
 608       (let ((host (zone-parse-host nsname zname)))
 609         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 610         (rec :data host)))))
 611
 612 (defzoneparse :alias (name data rec :zname zname)
 613   ":alias (LABEL*)"
 614   (dolist (a (listify data))
 615     (rec :name (zone-parse-host a zname)
 616          :type :cname
 617          :data name)))
 618
 619 (defzoneparse :net (name data rec)
 620   ":net (NETWORK*)"
 621   (dolist (net (listify data))
 622     (let ((n (net-get-as-ipnet net)))
 623       (rec :name (zone-parse-host "net" name)
 624            :type :a
 625            :data (ipnet-net n))
 626       (rec :name (zone-parse-host "mask" name)
 627            :type :a
 628            :data (ipnet-mask n))
 629       (rec :name (zone-parse-host "broadcast" name)
 630            :type :a
 631            :data (ipnet-broadcast n)))))
 632
 633 (defzoneparse (:rev :reverse) (name data rec)
 634   ":reverse ((NET :bytes BYTES) ZONE*)"
 635   (setf data (listify data))
 636   (destructuring-bind
 637       (net &key bytes)
 638       (listify (car data))
 639     (setf net (zone-parse-net net name))
 640     (unless bytes
 641       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 642     (let ((seen (make-hash-table :test #'equal)))
 643       (dolist (z (or (cdr data)
 644                      (hash-table-keys *zones*)))
 645         (dolist (zr (zone-records (zone-find z)))
 646           (when (and (eq (zr-type zr) :a)
 647                      (zr-make-ptr-p zr)
 648                      (ipaddr-networkp (zr-data zr) net))
 649             (let ((name (string-downcase
 650                          (join-strings
 651                           #\.
 652                           (collecting ()
 653                             (dotimes (i bytes)
 654                               (collect (logand #xff (ash (zr-data zr)
 655                                                          (* -8 i)))))
 656                             (collect name))))))
 657               (unless (gethash name seen)
 658                 (rec :name name :type :ptr
 659                      :ttl (zr-ttl zr) :data (zr-name zr))
 660                 (setf (gethash name seen) t)))))))))
 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 --------------------------------------------------