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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; DNS zone generation
   4 ;;;
   5 ;;; (c) 2005 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software Foundation,
  22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 ;;;--------------------------------------------------------------------------
  25 ;;; Packaging.
  26
  27 (defpackage #:zone
  28   (:use #:common-lisp
  29         #:mdw.base #:mdw.str #:collect #:safely
  30         #:net #:net-sys #:services)
  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 (defvar *default-zone-source*
 153   (let ((hn (gethostname)))
 154     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 155   "The default zone source: the current host's name.")
 156
 157 (defvar *default-zone-refresh* (* 24 60 60)
 158   "Default zone refresh interval: one day.")
 159
 160 (defvar *default-zone-admin* nil
 161   "Default zone administrator's email address.")
 162
 163 (defvar *default-zone-retry* (* 60 60)
 164   "Default znoe retry interval: one hour.")
 165
 166 (defvar *default-zone-expire* (* 14 24 60 60)
 167   "Default zone expiry time: two weeks.")
 168
 169 (defvar *default-zone-min-ttl* (* 4 60 60)
 170   "Default zone minimum TTL/negative TTL: four hours.")
 171
 172 (defvar *default-zone-ttl* (* 8 60 60)
 173   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 174
 175 (defvar *default-mx-priority* 50
 176   "Default MX priority.")
 177
 178 ;;;--------------------------------------------------------------------------
 179 ;;; Zone variables and structures.
 180
 181 (defvar *zones* (make-hash-table :test #'equal)
 182   "Map of known zones.")
 183
 184 (defun zone-find (name)
 185   "Find a zone given its NAME."
 186   (gethash (string-downcase (stringify name)) *zones*))
 187
 188 (defun (setf zone-find) (zone name)
 189   "Make the zone NAME map to ZONE."
 190   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 191
 192 (defstruct (zone-record (:conc-name zr-))
 193   "A zone record."
 194   (name '<unnamed>)
 195   ttl
 196   type
 197   (make-ptr-p nil)
 198   data)
 199
 200 (defstruct (zone-subdomain (:conc-name zs-))
 201   "A subdomain.  Slightly weird.  Used internally by zone-process-records
 202    below, and shouldn't escape."
 203   name
 204   ttl
 205   records)
 206
 207 (defvar *zone-output-path* *default-pathname-defaults*
 208   "Pathname defaults to merge into output files.")
 209
 210 (defvar *preferred-subnets* nil
 211   "Subnets to prefer when selecting defaults.")
 212
 213 ;;;--------------------------------------------------------------------------
 214 ;;; Zone infrastructure.
 215
 216 (defun zone-file-name (zone type)
 217   "Choose a file name for a given ZONE and TYPE."
 218   (merge-pathnames (make-pathname :name (string-downcase zone)
 219                                   :type (string-downcase type))
 220                    *zone-output-path*))
 221
 222 (defun zone-preferred-subnet-p (name)
 223   "Answer whether NAME (a string or symbol) names a preferred subnet."
 224   (member name *preferred-subnets* :test #'string-equal))
 225
 226 (defmacro preferred-subnet-case (&body clauses)
 227   "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
 228    SUBNETS (a list or single symbol, not evaluated) are considered preferred
 229    by zone-preferred-subnet-p.  If SUBNETS is the symbol t then the clause
 230    always matches."
 231   `(cond
 232     ,@(mapcar (lambda (clause)
 233                 (let ((subnets (car clause)))
 234                   (cons (cond ((eq subnets t)
 235                                t)
 236                               ((listp subnets)
 237                                `(or ,@(mapcar (lambda (subnet)
 238                                                 `(zone-preferred-subnet-p
 239                                                   ',subnet))
 240                                               subnets)))
 241                               (t
 242                                `(zone-preferred-subnet-p ',subnets)))
 243                         (cdr clause))))
 244               clauses)))
 245
 246 (defun zone-process-records (rec ttl func)
 247   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
 248    the default time-to-live for records which don't specify one."
 249   (labels ((sift (rec ttl)
 250              (collecting (top sub)
 251                (loop
 252                  (unless rec
 253                    (return))
 254                  (let ((r (pop rec)))
 255                    (cond ((eq r :ttl)
 256                           (setf ttl (pop rec)))
 257                          ((symbolp r)
 258                           (collect (make-zone-record :type r
 259                                                      :ttl ttl
 260                                                      :data (pop rec))
 261                                    top))
 262                          ((listp r)
 263                           (dolist (name (listify (car r)))
 264                             (collect (make-zone-subdomain :name name
 265                                                           :ttl ttl
 266                                                           :records (cdr r))
 267                                      sub)))
 268                          (t
 269                           (error "Unexpected record form ~A" (car r))))))))
 270            (process (rec dom ttl)
 271              (multiple-value-bind (top sub) (sift rec ttl)
 272                (if (and dom (null top) sub)
 273                    (let ((preferred nil))
 274                      (dolist (s sub)
 275                        (when (some #'zone-preferred-subnet-p
 276                                    (listify (zs-name s)))
 277                          (setf preferred s)))
 278                      (unless preferred
 279                        (setf preferred (car sub)))
 280                      (when preferred
 281                        (process (zs-records preferred)
 282                                 dom
 283                                 (zs-ttl preferred))))
 284                    (let ((name (and dom
 285                                     (string-downcase
 286                                      (join-strings #\. (reverse dom))))))
 287                      (dolist (zr top)
 288                        (setf (zr-name zr) name)
 289                        (funcall func zr))))
 290                (dolist (s sub)
 291                  (process (zs-records s)
 292                           (cons (zs-name s) dom)
 293                           (zs-ttl s))))))
 294     (process rec nil ttl)))
 295
 296 (defun zone-parse-host (f zname)
 297   "Parse a host name F: if F ends in a dot then it's considered absolute;
 298    otherwise it's relative to ZNAME."
 299   (setf f (stringify f))
 300   (cond ((string= f "@") (stringify zname))
 301         ((and (plusp (length f))
 302               (char= (char f (1- (length f))) #\.))
 303          (string-downcase (subseq f 0 (1- (length f)))))
 304         (t (string-downcase (concatenate 'string f "."
 305                                          (stringify zname))))))
 306 (defun default-rev-zone (base bytes)
 307   "Return the default reverse-zone name for the given BASE address and number
 308    of fixed leading BYTES."
 309   (join-strings #\. (collecting ()
 310                       (loop for i from (- 3 bytes) downto 0
 311                             do (collect (ipaddr-byte base i)))
 312                       (collect "in-addr.arpa"))))
 313
 314 (defun zone-name-from-net (net &optional bytes)
 315   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 316    subdomain of in-addr.arpa."
 317   (let ((ipn (net-get-as-ipnet net)))
 318     (with-ipnet (net mask) ipn
 319       (unless bytes
 320         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 321       (join-strings #\.
 322                     (append (loop
 323                                for i from (- 4 bytes) below 4
 324                                collect (logand #xff (ash net (* -8 i))))
 325                             (list "in-addr.arpa"))))))
 326
 327 (defun zone-net-from-name (name)
 328   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 329   (let* ((name (string-downcase (stringify name)))
 330          (len (length name))
 331          (suffix ".in-addr.arpa")
 332          (sufflen (length suffix))
 333          (addr 0)
 334          (n 0)
 335          (end (- len sufflen)))
 336     (unless (and (> len sufflen)
 337                  (string= name suffix :start1 end))
 338       (error "`~A' not in ~A." name suffix))
 339     (loop
 340        with start = 0
 341        for dot = (position #\. name :start start :end end)
 342        for byte = (parse-integer name
 343                                  :start start
 344                                  :end (or dot end))
 345        do (setf addr (logior addr (ash byte (* 8 n))))
 346           (incf n)
 347        when (>= n 4)
 348        do (error "Can't deduce network from ~A." name)
 349        while dot
 350        do (setf start (1+ dot)))
 351     (setf addr (ash addr (* 8 (- 4 n))))
 352     (make-ipnet addr (* 8 n))))
 353
 354 (defun zone-parse-net (net name)
 355   "Given a NET, and the NAME of a domain to guess from if NET is null, return
 356    the ipnet for the network."
 357   (if net
 358       (net-get-as-ipnet net)
 359       (zone-net-from-name name)))
 360
 361 (defun zone-cidr-delg-default-name (ipn bytes)
 362   "Given a delegated net IPN and the parent's number of changing BYTES,
 363    return the default deletate zone prefix."
 364   (with-ipnet (net mask) ipn
 365     (join-strings #\.
 366                   (reverse
 367                    (loop
 368                       for i from (1- bytes) downto 0
 369                       until (zerop (logand mask (ash #xff (* 8 i))))
 370                       collect (logand #xff (ash net (* -8 i))))))))
 371
 372 ;;;--------------------------------------------------------------------------
 373 ;;; Serial numbering.
 374
 375 (defun make-zone-serial (name)
 376   "Given a zone NAME, come up with a new serial number.  This will (very
 377    carefully) update a file ZONE.serial in the current directory."
 378   (let* ((file (zone-file-name name :serial))
 379          (last (with-open-file (in file
 380                                    :direction :input
 381                                    :if-does-not-exist nil)
 382                  (if in (read in)
 383                      (list 0 0 0 0))))
 384          (now (multiple-value-bind
 385                   (sec min hr dy mon yr dow dstp tz)
 386                   (get-decoded-time)
 387                 (declare (ignore sec min hr dow dstp tz))
 388                 (list dy mon yr)))
 389          (seq (cond ((not (equal now (cdr last))) 0)
 390                     ((< (car last) 99) (1+ (car last)))
 391                     (t (error "Run out of sequence numbers for ~A" name)))))
 392     (safely-writing (out file)
 393       (format out
 394               ";; Serial number file for zone ~A~%~
 395                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 396                ~S~%"
 397               name
 398               (cons seq now)))
 399     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 400
 401 ;;;--------------------------------------------------------------------------
 402 ;;; Zone form parsing.
 403
 404 (defun zone-parse-head (head)
 405   "Parse the HEAD of a zone form.  This has the form
 406
 407      (NAME &key :source :admin :refresh :retry
 408                 :expire :min-ttl :ttl :serial)
 409
 410    though a singleton NAME needn't be a list.  Returns the default TTL and an
 411    soa structure representing the zone head."
 412   (destructuring-bind
 413       (zname
 414        &key
 415        (source *default-zone-source*)
 416        (admin (or *default-zone-admin*
 417                   (format nil "hostmaster@~A" zname)))
 418        (refresh *default-zone-refresh*)
 419        (retry *default-zone-retry*)
 420        (expire *default-zone-expire*)
 421        (min-ttl *default-zone-min-ttl*)
 422        (ttl min-ttl)
 423        (serial (make-zone-serial zname)))
 424       (listify head)
 425     (values zname
 426             (timespec-seconds ttl)
 427             (make-soa :admin admin
 428                       :source (zone-parse-host source zname)
 429                       :refresh (timespec-seconds refresh)
 430                       :retry (timespec-seconds retry)
 431                       :expire (timespec-seconds expire)
 432                       :min-ttl (timespec-seconds min-ttl)
 433                       :serial serial))))
 434
 435 (defun zone-make-name (prefix zone-name)
 436   (if (or (not prefix) (string= prefix "@"))
 437       zone-name
 438       (let ((len (length prefix)))
 439         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
 440             (join-strings #\. (list prefix zone-name))
 441             prefix))))
 442
 443 (defmacro defzoneparse (types (name data list
 444                                &key (prefix (gensym "PREFIX"))
 445                                     (zname (gensym "ZNAME"))
 446                                     (ttl (gensym "TTL")))
 447                         &body body)
 448   "Define a new zone record type (or TYPES -- a list of synonyms is
 449    permitted).  The arguments are as follows:
 450
 451    NAME         The name of the record to be added.
 452
 453    DATA         The content of the record to be added (a single object,
 454                 unevaluated).
 455
 456    LIST         A function to add a record to the zone.  See below.
 457
 458    PREFIX       The prefix tag used in the original form.
 459
 460    ZNAME        The name of the zone being constructed.
 461
 462    TTL          The TTL for this record.
 463
 464    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 465    optional: you don't have to accept them if you're not interested.
 466
 467    The LIST argument names a function to be bound in the body to add a new
 468    low-level record to the zone.  It has the prototype
 469
 470      (LIST &key :name :type :data :ttl :make-ptr-p)
 471
 472    These (except MAKE-PTR-P, which defaults to nil) default to the above
 473    arguments (even if you didn't accept the arguments)."
 474   (setf types (listify types))
 475   (let* ((type (car types))
 476          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 477     (with-parsed-body (body decls doc) body
 478       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 479         `(progn
 480            (dolist (,i ',types)
 481              (setf (get ,i 'zone-parse) ',func))
 482            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 483              ,@doc
 484              ,@decls
 485              (let ((,name (zone-make-name ,prefix ,zname)))
 486                (flet ((,list (&key ((:name ,tname) ,name)
 487                                    ((:type ,ttype) ,type)
 488                                    ((:data ,tdata) ,data)
 489                                    ((:ttl ,tttl) ,ttl)
 490                                    ((:make-ptr-p ,tmakeptrp) nil))
 491                         #+cmu (declare (optimize ext:inhibit-warnings))
 492                         (collect (make-zone-record :name ,tname
 493                                                    :type ,ttype
 494                                                    :data ,tdata
 495                                                    :ttl ,tttl
 496                                                    :make-ptr-p ,tmakeptrp)
 497                                  ,col)))
 498                  ,@body)))
 499           ',type)))))
 500
 501 (defun zone-parse-records (zone records)
 502   (let ((zname (zone-name zone)))
 503     (with-collection (rec)
 504         (flet ((parse-record (zr)
 505                  (let ((func (or (get (zr-type zr) 'zone-parse)
 506                                  (error "No parser for record ~A."
 507                                         (zr-type zr))))
 508                        (name (and (zr-name zr) (stringify (zr-name zr)))))
 509                    (funcall func
 510                             name
 511                             zname
 512                             (zr-data zr)
 513                             (zr-ttl zr)
 514                             rec))))
 515           (zone-process-records records
 516                                 (zone-default-ttl zone)
 517                                 #'parse-record))
 518       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 519
 520 (defun zone-parse (zf)
 521   "Parse a ZONE form.  The syntax of a zone form is as follows:
 522
 523    ZONE-FORM:
 524      ZONE-HEAD ZONE-RECORD*
 525
 526    ZONE-RECORD:
 527      ((NAME*) ZONE-RECORD*)
 528    | SYM ARGS"
 529   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 530     (let ((zone (make-zone :name zname
 531                            :default-ttl ttl
 532                            :soa soa
 533                            :records nil)))
 534       (zone-parse-records zone (cdr zf))
 535       zone)))
 536
 537 (defun zone-create (zf)
 538   "Zone construction function.  Given a zone form ZF, construct the zone and
 539    add it to the table."
 540   (let* ((zone (zone-parse zf))
 541          (name (zone-name zone)))
 542     (setf (zone-find name) zone)
 543     name))
 544
 545 (defmacro defzone (soa &rest zf)
 546   "Zone definition macro."
 547   `(zone-create '(,soa ,@zf)))
 548
 549 (defmacro defrevzone (head &rest zf)
 550   "Define a reverse zone, with the correct name."
 551   (destructuring-bind
 552       (net &rest soa-args)
 553       (listify head)
 554     (let ((bytes nil))
 555       (when (and soa-args (integerp (car soa-args)))
 556         (setf bytes (pop soa-args)))
 557       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 558
 559 ;;;--------------------------------------------------------------------------
 560 ;;; Zone record parsers.
 561
 562 (defzoneparse :a (name data rec)
 563   ":a IPADDR"
 564   (rec :data (parse-ipaddr data) :make-ptr-p t))
 565
 566 (defzoneparse :svc (name data rec)
 567   ":svc IPADDR"
 568   (rec :type :a :data (parse-ipaddr data)))
 569
 570 (defzoneparse :ptr (name data rec :zname zname)
 571   ":ptr HOST"
 572   (rec :data (zone-parse-host data zname)))
 573
 574 (defzoneparse :cname (name data rec :zname zname)
 575   ":cname HOST"
 576   (rec :data (zone-parse-host data zname)))
 577
 578 (defzoneparse :txt (name data rec)
 579   ":txt TEXT"
 580   (rec :data data))
 581
 582 (defzoneparse :mx (name data rec :zname zname)
 583   ":mx ((HOST :prio INT :ip IPADDR)*)"
 584   (dolist (mx (listify data))
 585     (destructuring-bind
 586         (mxname &key (prio *default-mx-priority*) ip)
 587         (listify mx)
 588       (let ((host (zone-parse-host mxname zname)))
 589         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 590         (rec :data (cons host prio))))))
 591
 592 (defzoneparse :ns (name data rec :zname zname)
 593   ":ns ((HOST :ip IPADDR)*)"
 594   (dolist (ns (listify data))
 595     (destructuring-bind
 596         (nsname &key ip)
 597         (listify ns)
 598       (let ((host (zone-parse-host nsname zname)))
 599         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 600         (rec :data host)))))
 601
 602 (defzoneparse :alias (name data rec :zname zname)
 603   ":alias (LABEL*)"
 604   (dolist (a (listify data))
 605     (rec :name (zone-parse-host a zname)
 606          :type :cname
 607          :data name)))
 608
 609 (defzoneparse :srv (name data rec :zname zname)
 610   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
 611   (dolist (srv data)
 612     (destructuring-bind (servopts &rest providers) srv
 613       (destructuring-bind
 614           (service &key ((:port default-port)) (protocol :tcp))
 615           (listify servopts)
 616         (unless default-port
 617           (let ((serv (serv-by-name service protocol)))
 618             (setf default-port (and serv (serv-port serv)))))
 619         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
 620           (dolist (prov providers)
 621             (destructuring-bind
 622                 (srvname
 623                  &key
 624                  (port default-port)
 625                  (prio *default-mx-priority*)
 626                  (weight 0)
 627                  ip)
 628                 (listify prov)
 629               (let ((host (zone-parse-host srvname zname)))
 630                 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 631                 (rec :name rname
 632                      :data (list prio weight port host))))))))))
 633
 634 (defzoneparse :net (name data rec)
 635   ":net (NETWORK*)"
 636   (dolist (net (listify data))
 637     (let ((n (net-get-as-ipnet net)))
 638       (rec :name (zone-parse-host "net" name)
 639            :type :a
 640            :data (ipnet-net n))
 641       (rec :name (zone-parse-host "mask" name)
 642            :type :a
 643            :data (ipnet-mask n))
 644       (rec :name (zone-parse-host "broadcast" name)
 645            :type :a
 646            :data (ipnet-broadcast n)))))
 647
 648 (defzoneparse (:rev :reverse) (name data rec)
 649   ":reverse ((NET :bytes BYTES) ZONE*)"
 650   (setf data (listify data))
 651   (destructuring-bind (net &key bytes) (listify (car data))
 652     (setf net (zone-parse-net net name))
 653     (unless bytes
 654       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 655     (let ((seen (make-hash-table :test #'equal)))
 656       (dolist (z (or (cdr data)
 657                      (hash-table-keys *zones*)))
 658         (dolist (zr (zone-records (zone-find z)))
 659           (when (and (eq (zr-type zr) :a)
 660                      (zr-make-ptr-p zr)
 661                      (ipaddr-networkp (zr-data zr) net))
 662             (let ((name (string-downcase
 663                          (join-strings
 664                           #\.
 665                           (collecting ()
 666                             (dotimes (i bytes)
 667                               (collect (logand #xff (ash (zr-data zr)
 668                                                          (* -8 i)))))
 669                             (collect name))))))
 670               (unless (gethash name seen)
 671                 (rec :name name :type :ptr
 672                      :ttl (zr-ttl zr) :data (zr-name zr))
 673                 (setf (gethash name seen) t)))))))))
 674
 675 (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
 676   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
 677   (setf data (listify data))
 678   (destructuring-bind (net &key bytes) (listify (car data))
 679     (setf net (zone-parse-net net name))
 680     (unless bytes
 681       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 682     (dolist (map (or (cdr data) (list (list net))))
 683       (destructuring-bind (tnet &optional tdom) (listify map)
 684         (setf tnet (zone-parse-net tnet name))
 685         (unless (ipnet-subnetp net tnet)
 686           (error "~A is not a subnet of ~A."
 687                  (ipnet-pretty tnet)
 688                  (ipnet-pretty net)))
 689         (unless tdom
 690           (with-ipnet (net mask) tnet
 691             (setf tdom
 692                   (join-strings
 693                    #\.
 694                    (append (reverse (loop
 695                                      for i from (1- bytes) downto 0
 696                                      until (zerop (logand mask
 697                                                           (ash #xff
 698                                                                (* 8 i))))
 699                                      collect (ldb (byte 8 (* i 8)) net)))
 700                            (list name))))))
 701         (setf tdom (string-downcase (stringify tdom)))
 702         (dotimes (i (ipnet-hosts tnet))
 703           (unless (zerop i)
 704             (let* ((addr (ipnet-host tnet i))
 705                    (tail (join-strings #\.
 706                                        (loop
 707                                         for i from 0 below bytes
 708                                         collect
 709                                         (logand #xff
 710                                                 (ash addr (* 8 i)))))))
 711               (rec :name (format nil "~A.~A" tail name)
 712                    :type :cname
 713                    :data (format nil "~A.~A" tail tdom)))))))))
 714
 715 ;;;--------------------------------------------------------------------------
 716 ;;; Zone file output.
 717
 718 (defgeneric zone-write (format zone stream)
 719   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
 720
 721 (defvar *writing-zone* nil
 722   "The zone currently being written.")
 723
 724 (defvar *zone-output-stream* nil
 725   "Stream to write zone data on.")
 726
 727 (defmethod zone-write :around (format zone stream)
 728   (let ((*writing-zone* zone)
 729         (*zone-output-stream* stream))
 730     (call-next-method)))
 731
 732 (defun zone-save (zones &key (format :bind))
 733   "Write the named ZONES to files.  If no zones are given, write all the
 734    zones."
 735   (unless zones
 736     (setf zones (hash-table-keys *zones*)))
 737   (safely (safe)
 738     (dolist (z zones)
 739       (let ((zz (zone-find z)))
 740         (unless zz
 741           (error "Unknown zone `~A'." z))
 742         (let ((stream (safely-open-output-stream safe
 743                                                  (zone-file-name z :zone))))
 744           (zone-write format zz stream))))))
 745
 746 ;;;--------------------------------------------------------------------------
 747 ;;; Bind format output.
 748
 749 (defun bind-hostname (hostname)
 750   (if (not hostname)
 751       "@"
 752       (let* ((h (string-downcase (stringify hostname)))
 753              (hl (length h))
 754              (r (string-downcase (zone-name *writing-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
 763 (defmethod zone-write ((format (eql :bind)) zone stream)
 764   (format stream "~
 765 ;;; Zone file `~(~A~)'
 766 ;;;   (generated ~A)
 767
 768 $ORIGIN ~0@*~(~A.~)
 769 $TTL ~2@*~D~2%"
 770             (zone-name zone)
 771             (iso-date :now :datep t :timep t)
 772             (zone-default-ttl zone))
 773   (let* ((soa (zone-soa zone))
 774          (admin (let* ((name (soa-admin soa))
 775                        (at (position #\@ name))
 776                        (copy (format nil "~(~A~)." name)))
 777                   (when at
 778                     (setf (char copy at) #\.))
 779                   copy)))
 780       (format stream "~
 781 ~A~30TIN SOA~40T~A ~A (
 782 ~45T~10D~60T ;serial
 783 ~45T~10D~60T ;refresh
 784 ~45T~10D~60T ;retry
 785 ~45T~10D~60T ;expire
 786 ~45T~10D )~60T ;min-ttl~2%"
 787               (bind-hostname (zone-name zone))
 788               (bind-hostname (soa-source soa))
 789               admin
 790               (soa-serial soa)
 791               (soa-refresh soa)
 792               (soa-retry soa)
 793               (soa-expire soa)
 794               (soa-min-ttl soa)))
 795   (dolist (zr (zone-records zone))
 796     (bind-record (zr-type zr) zr)))
 797
 798 (defgeneric bind-record (type zr))
 799
 800 (defun bind-format-record (name ttl type format args)
 801   (format *zone-output-stream*
 802           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
 803           (bind-hostname name)
 804           (and (/= ttl (zone-default-ttl *writing-zone*))
 805                ttl)
 806           (string-upcase (symbol-name type))
 807           format args))
 808
 809 (defmethod bind-record (type zr)
 810   (destructuring-bind (format &rest args)
 811       (bind-record-format-args type (zr-data zr))
 812     (bind-format-record (zr-name zr)
 813                         (zr-ttl zr)
 814                         (bind-record-type type)
 815                         format args)))
 816
 817 (defgeneric bind-record-type (type)
 818   (:method (type) type))
 819
 820 (defgeneric bind-record-format-args (type data)
 821   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
 822   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
 823   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
 824   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
 825   (:method ((type (eql :mx)) data)
 826     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
 827   (:method ((type (eql :srv)) data)
 828     (destructuring-bind (prio weight port host) data
 829       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
 830   (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
 831
 832 ;;;----- That's all, folks --------------------------------------------------