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