mdw@git.distorted.org.uk Git - zone/blob - zone.lisp

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