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 #:zone-make-name
  39            #:defzoneparse #:zone-parse-host
  40            #:timespec-seconds #:make-zone-serial))
  41
  42 (in-package #:zone)
  43
  44 ;;;--------------------------------------------------------------------------
  45 ;;; Various random utilities.
  46
  47 (defun to-integer (x)
  48   "Convert X to an integer in the most straightforward way."
  49   (floor (rational x)))
  50
  51 (defun from-mixed-base (base val)
  52   "BASE is a list of the ranges for the `digits' of a mixed-base
  53    representation.  Convert VAL, a list of digits, into an integer."
  54   (do ((base base (cdr base))
  55        (val (cdr val) (cdr val))
  56        (a (car val) (+ (* a (car base)) (car val))))
  57       ((or (null base) (null val)) a)))
  58
  59 (defun to-mixed-base (base val)
  60   "BASE is a list of the ranges for the `digits' of a mixed-base
  61    representation.  Convert VAL, an integer, into a list of digits."
  62   (let ((base (reverse base))
  63         (a nil))
  64     (loop
  65       (unless base
  66         (push val a)
  67         (return a))
  68       (multiple-value-bind (q r) (floor val (pop base))
  69         (push r a)
  70         (setf val q)))))
  71
  72 (defun timespec-seconds (ts)
  73   "Convert a timespec TS to seconds.  A timespec may be a real count of
  74    seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
  75    time units."
  76   (cond ((null ts) 0)
  77         ((realp ts) (floor ts))
  78         ((atom ts)
  79          (error "Unknown timespec format ~A" ts))
  80         ((null (cdr ts))
  81          (timespec-seconds (car ts)))
  82         (t (+ (to-integer (* (car ts)
  83                              (case (intern (string-upcase
  84                                             (stringify (cadr ts)))
  85                                            '#:zone)
  86                                ((s sec secs second seconds) 1)
  87                                ((m min mins minute minutes) 60)
  88                                ((h hr hrs hour hours) #.(* 60 60))
  89                                ((d dy dys day days) #.(* 24 60 60))
  90                                ((w wk wks week weeks) #.(* 7 24 60 60))
  91                                ((y yr yrs year years) #.(* 365 24 60 60))
  92                                (t (error "Unknown time unit ~A"
  93                                          (cadr ts))))))
  94               (timespec-seconds (cddr ts))))))
  95
  96 (defun hash-table-keys (ht)
  97   "Return a list of the keys in hashtable HT."
  98   (collecting ()
  99     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 100
 101 (defun iso-date (&optional time &key datep timep (sep #\ ))
 102   "Construct a textual date or time in ISO format.  The TIME is the universal
 103    time to convert, which defaults to now; DATEP is whether to emit the date;
 104    TIMEP is whether to emit the time, and SEP (default is space) is how to
 105    separate the two."
 106   (multiple-value-bind
 107       (sec min hr day mon yr dow dstp tz)
 108       (decode-universal-time (if (or (null time) (eq time :now))
 109                                  (get-universal-time)
 110                                  time))
 111     (declare (ignore dow dstp tz))
 112     (with-output-to-string (s)
 113       (when datep
 114         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 115         (when timep
 116           (write-char sep s)))
 117       (when timep
 118         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 119
 120 ;;;--------------------------------------------------------------------------
 121 ;;; Zone types.
 122
 123 (defstruct (soa (:predicate soap))
 124   "Start-of-authority record information."
 125   source
 126   admin
 127   refresh
 128   retry
 129   expire
 130   min-ttl
 131   serial)
 132
 133 (defstruct (mx (:predicate mxp))
 134   "Mail-exchange record information."
 135   priority
 136   domain)
 137
 138 (defstruct (zone (:predicate zonep))
 139   "Zone information."
 140   soa
 141   default-ttl
 142   name
 143   records)
 144
 145 ;;;--------------------------------------------------------------------------
 146 ;;; Zone defaults.  It is intended that scripts override these.
 147
 148 #+ecl
 149 (cffi:defcfun gethostname :int
 150   (name :pointer)
 151   (len :uint))
 152
 153 (defvar *default-zone-source*
 154   (let ((hn #+cmu (unix:unix-gethostname)
 155             #+clisp (unix:get-host-name)
 156             #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
 157                     (let ((rc (gethostname buffer len)))
 158                       (unless (zerop rc)
 159                         (error "gethostname(2) failed (rc = ~A)." rc))))))
 160     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 161   "The default zone source: the current host's name.")
 162
 163 (defvar *default-zone-refresh* (* 24 60 60)
 164   "Default zone refresh interval: one day.")
 165
 166 (defvar *default-zone-admin* nil
 167   "Default zone administrator's email address.")
 168
 169 (defvar *default-zone-retry* (* 60 60)
 170   "Default znoe retry interval: one hour.")
 171
 172 (defvar *default-zone-expire* (* 14 24 60 60)
 173   "Default zone expiry time: two weeks.")
 174
 175 (defvar *default-zone-min-ttl* (* 4 60 60)
 176   "Default zone minimum TTL/negative TTL: four hours.")
 177
 178 (defvar *default-zone-ttl* (* 8 60 60)
 179   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 180
 181 (defvar *default-mx-priority* 50
 182   "Default MX priority.")
 183
 184 ;;;--------------------------------------------------------------------------
 185 ;;; Zone variables and structures.
 186
 187 (defvar *zones* (make-hash-table :test #'equal)
 188   "Map of known zones.")
 189
 190 (defun zone-find (name)
 191   "Find a zone given its NAME."
 192   (gethash (string-downcase (stringify name)) *zones*))
 193
 194 (defun (setf zone-find) (zone name)
 195   "Make the zone NAME map to ZONE."
 196   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 197
 198 (defstruct (zone-record (:conc-name zr-))
 199   "A zone record."
 200   (name '<unnamed>)
 201   ttl
 202   type
 203   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 (defun zone-make-name (prefix zone-name)
 450   (if (or (not prefix) (string= prefix "@"))
 451       zone-name
 452       (let ((len (length prefix)))
 453         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
 454             (join-strings #\. (list prefix zone-name))
 455             prefix))))
 456
 457 (defmacro defzoneparse (types (name data list
 458                                &key (prefix (gensym "PREFIX"))
 459                                     (zname (gensym "ZNAME"))
 460                                     (ttl (gensym "TTL")))
 461                         &body body)
 462   "Define a new zone record type (or TYPES -- a list of synonyms is
 463    permitted).  The arguments are as follows:
 464
 465    NAME         The name of the record to be added.
 466
 467    DATA         The content of the record to be added (a single object,
 468                 unevaluated).
 469
 470    LIST         A function to add a record to the zone.  See below.
 471
 472    PREFIX       The prefix tag used in the original form.
 473
 474    ZNAME        The name of the zone being constructed.
 475
 476    TTL          The TTL for this record.
 477
 478    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 479    optional: you don't have to accept them if you're not interested.
 480
 481    The LIST argument names a function to be bound in the body to add a new
 482    low-level record to the zone.  It has the prototype
 483
 484      (LIST &key :name :type :data :ttl)
 485
 486    These default to the above arguments (even if you didn't accept the
 487    arguments)."
 488   (setf types (listify types))
 489   (let* ((type (car types))
 490          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 491     (with-parsed-body (body decls doc) body
 492       (with-gensyms (col tname ttype tttl tdata i)
 493         `(progn
 494            (dolist (,i ',types)
 495              (setf (get ,i 'zone-parse) ',func))
 496            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 497              ,@doc
 498              ,@decls
 499              (let ((,name (zone-make-name ,prefix ,zname)))
 500                (flet ((,list (&key ((:name ,tname) ,name)
 501                                    ((:type ,ttype) ,type)
 502                                    ((:data ,tdata) ,data)
 503                                    ((:ttl ,tttl) ,ttl))
 504                         (collect (make-zone-record :name ,tname
 505                                                    :type ,ttype
 506                                                    :data ,tdata
 507                                                    :ttl ,tttl)
 508                                  ,col)))
 509                  ,@body)))
 510           ',type)))))
 511
 512 (defun zone-parse-records (zone records)
 513   (let ((zname (zone-name zone)))
 514     (with-collection (rec)
 515         (flet ((parse-record (zr)
 516                  (let ((func (or (get (zr-type zr) 'zone-parse)
 517                                  (error "No parser for record ~A."
 518                                         (zr-type zr))))
 519                        (name (and (zr-name zr) (stringify (zr-name zr)))))
 520                    (funcall func
 521                             name
 522                             zname
 523                             (zr-data zr)
 524                             (zr-ttl zr)
 525                             rec))))
 526           (zone-process-records records
 527                                 (zone-default-ttl zone)
 528                                 #'parse-record))
 529       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 530
 531 (defun zone-parse (zf)
 532   "Parse a ZONE form.  The syntax of a zone form is as follows:
 533
 534    ZONE-FORM:
 535      ZONE-HEAD ZONE-RECORD*
 536
 537    ZONE-RECORD:
 538      ((NAME*) ZONE-RECORD*)
 539    | SYM ARGS"
 540   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 541     (let ((zone (make-zone :name zname
 542                            :default-ttl ttl
 543                            :soa soa
 544                            :records nil)))
 545       (zone-parse-records zone (cdr zf))
 546       zone)))
 547
 548 (defun zone-create (zf)
 549   "Zone construction function.  Given a zone form ZF, construct the zone and
 550    add it to the table."
 551   (let* ((zone (zone-parse zf))
 552          (name (zone-name zone)))
 553     (setf (zone-find name) zone)
 554     name))
 555
 556 (defmacro defzone (soa &rest zf)
 557   "Zone definition macro."
 558   `(zone-create '(,soa ,@zf)))
 559
 560 (defmacro defrevzone (head &rest zf)
 561   "Define a reverse zone, with the correct name."
 562   (destructuring-bind
 563       (net &rest soa-args)
 564       (listify head)
 565     (let ((bytes nil))
 566       (when (and soa-args (integerp (car soa-args)))
 567         (setf bytes (pop soa-args)))
 568       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 569
 570 ;;;--------------------------------------------------------------------------
 571 ;;; Zone record parsers.
 572
 573 (defzoneparse :a (name data rec)
 574   ":a IPADDR"
 575   (rec :data (parse-ipaddr data)))
 576
 577 (defzoneparse :ptr (name data rec :zname zname)
 578   ":ptr HOST"
 579   (rec :data (zone-parse-host data zname)))
 580
 581 (defzoneparse :cname (name data rec :zname zname)
 582   ":cname HOST"
 583   (rec :data (zone-parse-host data zname)))
 584
 585 (defzoneparse :mx (name data rec :zname zname)
 586   ":mx ((HOST :prio INT :ip IPADDR)*)"
 587   (dolist (mx (listify data))
 588     (destructuring-bind
 589         (mxname &key (prio *default-mx-priority*) ip)
 590         (listify mx)
 591       (let ((host (zone-parse-host mxname zname)))
 592         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 593         (rec :data (cons host prio))))))
 594
 595 (defzoneparse :ns (name data rec :zname zname)
 596   ":ns ((HOST :ip IPADDR)*)"
 597   (dolist (ns (listify data))
 598     (destructuring-bind
 599         (nsname &key ip)
 600         (listify ns)
 601       (let ((host (zone-parse-host nsname zname)))
 602         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 603         (rec :data host)))))
 604
 605 (defzoneparse :alias (name data rec :zname zname)
 606   ":alias (LABEL*)"
 607   (dolist (a (listify data))
 608     (rec :name (zone-parse-host a zname)
 609          :type :cname
 610          :data name)))
 611
 612 (defzoneparse :net (name data rec)
 613   ":net (NETWORK*)"
 614   (dolist (net (listify data))
 615     (let ((n (net-get-as-ipnet net)))
 616       (rec :name (zone-parse-host "net" name)
 617            :type :a
 618            :data (ipnet-net n))
 619       (rec :name (zone-parse-host "mask" name)
 620            :type :a
 621            :data (ipnet-mask n))
 622       (rec :name (zone-parse-host "broadcast" name)
 623            :type :a
 624            :data (ipnet-broadcast n)))))
 625
 626 (defzoneparse (:rev :reverse) (name data rec)
 627   ":reverse ((NET :bytes BYTES) ZONE*)"
 628   (setf data (listify data))
 629   (destructuring-bind
 630       (net &key bytes)
 631       (listify (car data))
 632     (setf net (zone-parse-net net name))
 633     (unless bytes
 634       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 635     (let ((seen (make-hash-table :test #'equal)))
 636       (dolist (z (or (cdr data)
 637                      (hash-table-keys *zones*)))
 638         (dolist (zr (zone-records (zone-find z)))
 639           (when (and (eq (zr-type zr) :a)
 640                      (ipaddr-networkp (zr-data zr) net))
 641             (let ((name (string-downcase
 642                          (join-strings
 643                           #\.
 644                           (collecting ()
 645                             (dotimes (i bytes)
 646                               (collect (logand #xff (ash (zr-data zr)
 647                                                          (* -8 i)))))
 648                             (collect name))))))
 649               (unless (gethash name seen)
 650                 (rec :name name :type :ptr
 651                      :ttl (zr-ttl zr) :data (zr-name zr))
 652                 (setf (gethash name seen) t)))))))))
 653
 654 (defzoneparse (:cidr-delegation :cidr) (name data rec)
 655   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
 656   (destructuring-bind
 657       (net &key bytes)
 658       (listify (car data))
 659     (setf net (zone-parse-net net name))
 660     (unless bytes
 661       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 662     (dolist (map (cdr data))
 663       (destructuring-bind
 664           (tnet &optional tdom)
 665           (listify map)
 666         (setf tnet (zone-parse-net tnet name))
 667         (unless (ipnet-subnetp net tnet)
 668           (error "~A is not a subnet of ~A."
 669                  (ipnet-pretty tnet)
 670                  (ipnet-pretty net)))
 671         (unless tdom
 672           (with-ipnet (net mask) tnet
 673             (setf tdom
 674                   (join-strings
 675                    #\.
 676                    (append (reverse (loop
 677                                        for i from (1- bytes) downto 0
 678                                        until (zerop (logand mask
 679                                                             (ash #xff
 680                                                                  (* 8 i))))
 681                                        collect (logand #xff
 682                                                        (ash net (* -8 i)))))
 683                            (list name))))))
 684         (setf tdom (string-downcase tdom))
 685         (dotimes (i (ipnet-hosts tnet))
 686           (let* ((addr (ipnet-host tnet i))
 687                  (tail (join-strings #\.
 688                                      (loop
 689                                         for i from 0 below bytes
 690                                         collect
 691                                           (logand #xff
 692                                                   (ash addr (* 8 i)))))))
 693             (rec :name (format nil "~A.~A" tail name)
 694                  :type :cname
 695                  :data (format nil "~A.~A" tail tdom))))))))
 696
 697 ;;;--------------------------------------------------------------------------
 698 ;;; Zone file output.
 699
 700 (defun zone-write (zone &optional (stream *standard-output*))
 701   "Write a ZONE's records to STREAM."
 702   (labels ((fix-admin (a)
 703              (let ((at (position #\@ a))
 704                    (s (concatenate 'string (string-downcase a) ".")))
 705                (when s
 706                  (setf (char s at) #\.))
 707                s))
 708            (fix-host (h)
 709              (if (not h)
 710                  "@"
 711                  (let* ((h (string-downcase (stringify h)))
 712                         (hl (length h))
 713                         (r (string-downcase (zone-name zone)))
 714                         (rl (length r)))
 715                    (cond ((string= r h) "@")
 716                          ((and (> hl rl)
 717                                (char= (char h (- hl rl 1)) #\.)
 718                                (string= h r :start1 (- hl rl)))
 719                           (subseq h 0 (- hl rl 1)))
 720                          (t (concatenate 'string h "."))))))
 721            (printrec (zr)
 722              (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
 723                      (fix-host (zr-name zr))
 724                      (and (/= (zr-ttl zr) (zone-default-ttl zone))
 725                           (zr-ttl zr))
 726                      (string-upcase (symbol-name (zr-type zr))))))
 727     (format stream "~
 728 ;;; Zone file `~(~A~)'
 729 ;;;   (generated ~A)
 730
 731 $ORIGIN ~0@*~(~A.~)
 732 $TTL ~2@*~D~2%"
 733             (zone-name zone)
 734             (iso-date :now :datep t :timep t)
 735             (zone-default-ttl zone))
 736     (let ((soa (zone-soa zone)))
 737       (format stream "~
 738 ~A~30TIN SOA~40T~A ~A (
 739 ~45T~10D~60T ;serial
 740 ~45T~10D~60T ;refresh
 741 ~45T~10D~60T ;retry
 742 ~45T~10D~60T ;expire
 743 ~45T~10D )~60T ;min-ttl~2%"
 744               (fix-host (zone-name zone))
 745               (fix-host (soa-source soa))
 746               (fix-admin (soa-admin soa))
 747               (soa-serial soa)
 748               (soa-refresh soa)
 749               (soa-retry soa)
 750               (soa-expire soa)
 751               (soa-min-ttl soa)))
 752     (dolist (zr (zone-records zone))
 753       (ecase (zr-type zr)
 754         (:a
 755          (printrec zr)
 756          (format stream "~A~%" (ipaddr-string (zr-data zr))))
 757         ((:ptr :cname :ns)
 758          (printrec zr)
 759          (format stream "~A~%" (fix-host (zr-data zr))))
 760         (:mx
 761          (printrec zr)
 762          (let ((mx (zr-data zr)))
 763            (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
 764         (:txt
 765          (printrec zr)
 766          (format stream "~S~%" (stringify (zr-data zr))))))))
 767
 768 (defun zone-save (zones)
 769   "Write the named ZONES to files.  If no zones are given, write all the
 770    zones."
 771   (unless zones
 772     (setf zones (hash-table-keys *zones*)))
 773   (safely (safe)
 774     (dolist (z zones)
 775       (let ((zz (zone-find z)))
 776         (unless zz
 777           (error "Unknown zone `~A'." z))
 778         (let ((stream (safely-open-output-stream safe
 779                                                  (zone-file-name z :zone))))
 780           (zone-write zz stream))))))
 781
 782 ;;;----- That's all, folks --------------------------------------------------