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