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

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