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