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