chiark - git - mdw - 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 #:services)
  31   (:import-from #:net #:round-down #:round-up))
  32
  33 (in-package #:zone)
  34
  35 ;;;--------------------------------------------------------------------------
  36 ;;; Various random utilities.
  37
  38 (defun to-integer (x)
  39   "Convert X to an integer in the most straightforward way."
  40   (floor (rational x)))
  41
  42 (defun from-mixed-base (base val)
  43   "BASE is a list of the ranges for the `digits' of a mixed-base
  44    representation.  Convert VAL, a list of digits, into an integer."
  45   (do ((base base (cdr base))
  46        (val (cdr val) (cdr val))
  47        (a (car val) (+ (* a (car base)) (car val))))
  48       ((or (null base) (null val)) a)))
  49
  50 (defun to-mixed-base (base val)
  51   "BASE is a list of the ranges for the `digits' of a mixed-base
  52    representation.  Convert VAL, an integer, into a list of digits."
  53   (let ((base (reverse base))
  54         (a nil))
  55     (loop
  56       (unless base
  57         (push val a)
  58         (return a))
  59       (multiple-value-bind (q r) (floor val (pop base))
  60         (push r a)
  61         (setf val q)))))
  62
  63 (export 'timespec-seconds)
  64 (defun timespec-seconds (ts)
  65   "Convert a timespec TS to seconds.
  66
  67    A timespec may be a real count of seconds, or a list (COUNT UNIT).  UNIT
  68    may be any of a number of obvious time units."
  69   (cond ((null ts) 0)
  70         ((realp ts) (floor ts))
  71         ((atom ts)
  72          (error "Unknown timespec format ~A" ts))
  73         ((null (cdr ts))
  74          (timespec-seconds (car ts)))
  75         (t (+ (to-integer (* (car ts)
  76                              (case (intern (string-upcase
  77                                             (stringify (cadr ts)))
  78                                            '#:zone)
  79                                ((s sec secs second seconds) 1)
  80                                ((m min mins minute minutes) 60)
  81                                ((h hr hrs hour hours) #.(* 60 60))
  82                                ((d dy dys day days) #.(* 24 60 60))
  83                                ((w wk wks week weeks) #.(* 7 24 60 60))
  84                                ((y yr yrs year years) #.(* 365 24 60 60))
  85                                (t (error "Unknown time unit ~A"
  86                                          (cadr ts))))))
  87               (timespec-seconds (cddr ts))))))
  88
  89 (defun hash-table-keys (ht)
  90   "Return a list of the keys in hashtable HT."
  91   (collecting ()
  92     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
  93
  94 (defun iso-date (&optional time &key datep timep (sep #\ ))
  95   "Construct a textual date or time in ISO format.
  96
  97    The TIME is the universal time to convert, which defaults to now; DATEP is
  98    whether to emit the date; TIMEP is whether to emit the time, and
  99    SEP (default is space) is how to separate the two."
 100   (multiple-value-bind
 101       (sec min hr day mon yr dow dstp tz)
 102       (decode-universal-time (if (or (null time) (eq time :now))
 103                                  (get-universal-time)
 104                                  time))
 105     (declare (ignore dow dstp tz))
 106     (with-output-to-string (s)
 107       (when datep
 108         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 109         (when timep
 110           (write-char sep s)))
 111       (when timep
 112         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 113
 114 ;;;--------------------------------------------------------------------------
 115 ;;; Zone types.
 116
 117 (export 'soa)
 118 (defstruct (soa (:predicate soap))
 119   "Start-of-authority record information."
 120   source
 121   admin
 122   refresh
 123   retry
 124   expire
 125   min-ttl
 126   serial)
 127
 128 (export 'zone-text-name)
 129 (defun zone-text-name (zone)
 130   (princ-to-string (zone-name zone)))
 131
 132 (export 'mx)
 133 (defstruct (mx (:predicate mxp))
 134   "Mail-exchange record information."
 135   priority
 136   domain)
 137
 138 (export 'zone)
 139 (defstruct (zone (:predicate zonep))
 140   "Zone information."
 141   soa
 142   default-ttl
 143   name
 144   records)
 145
 146 ;;;--------------------------------------------------------------------------
 147 ;;; Zone defaults.  It is intended that scripts override these.
 148
 149 (export '*default-zone-source*)
 150 (defvar *default-zone-source*
 151   (let ((hn (gethostname)))
 152     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 153   "The default zone source: the current host's name.")
 154
 155 (export '*default-zone-refresh*)
 156 (defvar *default-zone-refresh* (* 24 60 60)
 157   "Default zone refresh interval: one day.")
 158
 159 (export '*default-zone-admin*)
 160 (defvar *default-zone-admin* nil
 161   "Default zone administrator's email address.")
 162
 163 (export '*default-zone-retry*)
 164 (defvar *default-zone-retry* (* 60 60)
 165   "Default znoe retry interval: one hour.")
 166
 167 (export '*default-zone-expire*)
 168 (defvar *default-zone-expire* (* 14 24 60 60)
 169   "Default zone expiry time: two weeks.")
 170
 171 (export '*default-zone-min-ttl*)
 172 (defvar *default-zone-min-ttl* (* 4 60 60)
 173   "Default zone minimum TTL/negative TTL: four hours.")
 174
 175 (export '*default-zone-ttl*)
 176 (defvar *default-zone-ttl* (* 8 60 60)
 177   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 178
 179 (export '*default-mx-priority*)
 180 (defvar *default-mx-priority* 50
 181   "Default MX priority.")
 182
 183 ;;;--------------------------------------------------------------------------
 184 ;;; Zone variables and structures.
 185
 186 (defvar *zones* (make-hash-table :test #'equal)
 187   "Map of known zones.")
 188
 189 (export 'zone-find)
 190 (defun zone-find (name)
 191   "Find a zone given its NAME."
 192   (gethash (string-downcase (stringify name)) *zones*))
 193 (defun (setf zone-find) (zone name)
 194   "Make the zone NAME map to ZONE."
 195   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 196
 197 (export 'zone-record)
 198 (defstruct (zone-record (:conc-name zr-))
 199   "A zone record."
 200   (name '<unnamed>)
 201   ttl
 202   type
 203   (make-ptr-p nil)
 204   data)
 205
 206 (export 'zone-subdomain)
 207 (defstruct (zone-subdomain (:conc-name zs-))
 208   "A subdomain.
 209
 210    Slightly weird.  Used internally by `zone-process-records', and shouldn't
 211    escape."
 212   name
 213   ttl
 214   records)
 215
 216 (export '*zone-output-path*)
 217 (defvar *zone-output-path* nil
 218   "Pathname defaults to merge into output files.
 219
 220    If this is nil then use the prevailing `*default-pathname-defaults*'.
 221    This is not the same as capturing the `*default-pathname-defaults*' from
 222    load time.")
 223
 224 (export '*preferred-subnets*)
 225 (defvar *preferred-subnets* nil
 226   "Subnets to prefer when selecting defaults.")
 227
 228 ;;;--------------------------------------------------------------------------
 229 ;;; Zone infrastructure.
 230
 231 (defun zone-file-name (zone type)
 232   "Choose a file name for a given ZONE and TYPE."
 233   (merge-pathnames (make-pathname :name (string-downcase zone)
 234                                   :type (string-downcase type))
 235                    (or *zone-output-path* *default-pathname-defaults*)))
 236
 237 (export 'zone-preferred-subnet-p)
 238 (defun zone-preferred-subnet-p (name)
 239   "Answer whether NAME (a string or symbol) names a preferred subnet."
 240   (member name *preferred-subnets* :test #'string-equal))
 241
 242 (export 'preferred-subnet-case)
 243 (defmacro preferred-subnet-case (&body clauses)
 244   "Execute a form based on which networks are considered preferred.
 245
 246    The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
 247    whose SUBNETS (a list or single symbol, not evaluated) are listed in
 248    `*preferred-subnets*'.  If SUBNETS is the symbol `t' then the clause
 249    always matches."
 250   `(cond
 251     ,@(mapcar (lambda (clause)
 252                 (let ((subnets (car clause)))
 253                   (cons (cond ((eq subnets t)
 254                                t)
 255                               ((listp subnets)
 256                                `(or ,@(mapcar (lambda (subnet)
 257                                                 `(zone-preferred-subnet-p
 258                                                   ',subnet))
 259                                               subnets)))
 260                               (t
 261                                `(zone-preferred-subnet-p ',subnets)))
 262                         (cdr clause))))
 263               clauses)))
 264
 265 (export 'zone-parse-host)
 266 (defun zone-parse-host (form &optional tail)
 267   "Parse a host name FORM from a value in a zone form.
 268
 269    The underlying parsing is done using `parse-domain-name'.  Here, we
 270    interpret various kinds of Lisp object specially.  In particular: `nil'
 271    refers to the TAIL zone (just like a plain `@'); and a symbol is downcased
 272    before use."
 273   (let ((name (etypecase form
 274                 (null (make-domain-name :labels nil :absolutep nil))
 275                 (domain-name form)
 276                 (symbol (parse-domain-name (string-downcase form)))
 277                 (string (parse-domain-name form)))))
 278     (if (null tail) name
 279         (domain-name-concat name tail))))
 280
 281 (export 'zone-records-sorted)
 282 (defun zone-records-sorted (zone)
 283   "Return the ZONE's records, in a pleasant sorted order."
 284   (sort (copy-seq (zone-records zone))
 285         (lambda (zr-a zr-b)
 286           (multiple-value-bind (precp follp)
 287               (domain-name< (zr-name zr-a) (zr-name zr-b))
 288             (cond (precp t)
 289                   (follp nil)
 290                   (t (string< (zr-type zr-a) (zr-type zr-b))))))))
 291
 292 ;;;--------------------------------------------------------------------------
 293 ;;; Serial numbering.
 294
 295 (export 'make-zone-serial)
 296 (defun make-zone-serial (name)
 297   "Given a zone NAME, come up with a new serial number.
 298
 299    This will (very carefully) update a file ZONE.serial in the current
 300    directory."
 301   (let* ((file (zone-file-name name :serial))
 302          (last (with-open-file (in file
 303                                    :direction :input
 304                                    :if-does-not-exist nil)
 305                  (if in (read in)
 306                      (list 0 0 0 0))))
 307          (now (multiple-value-bind
 308                   (sec min hr dy mon yr dow dstp tz)
 309                   (get-decoded-time)
 310                 (declare (ignore sec min hr dow dstp tz))
 311                 (list dy mon yr)))
 312          (seq (cond ((not (equal now (cdr last))) 0)
 313                     ((< (car last) 99) (1+ (car last)))
 314                     (t (error "Run out of sequence numbers for ~A" name)))))
 315     (safely-writing (out file)
 316       (format out
 317               ";; Serial number file for zone ~A~%~
 318                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 319                ~S~%"
 320               name
 321               (cons seq now)))
 322     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 323
 324 ;;;--------------------------------------------------------------------------
 325 ;;; Zone form parsing.
 326
 327 (defun zone-process-records (rec ttl func)
 328   "Sort out the list of records in REC, calling FUNC for each one.
 329
 330    TTL is the default time-to-live for records which don't specify one.
 331
 332    REC is a list of records of the form
 333
 334         ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
 335
 336    The various kinds of entries have the following meanings.
 337
 338    :ttl TTL             Set the TTL for subsequent records (at this level of
 339                           nesting only).
 340
 341    TYPE DATA            Define a record with a particular TYPE and DATA.
 342                           Record types are defined using `defzoneparse' and
 343                           the syntax of the data is idiosyncratic.
 344
 345    ((LABEL ...) . REC)  Define records for labels within the zone.  Any
 346                           records defined within REC will have their domains
 347                           prefixed by each of the LABELs.  A singleton list
 348                           of labels may instead be written as a single
 349                           label.  Note, therefore, that
 350
 351                                 (host (sub :a \"169.254.1.1\"))
 352
 353                           defines a record for `host.sub' -- not `sub.host'.
 354
 355    If REC contains no top-level records, but it does define records for a
 356    label listed in `*preferred-subnets*', then the records for the first such
 357    label are also promoted to top-level.
 358
 359    The FUNC is called for each record encountered, represented as a
 360    `zone-record' object.  Zone parsers are not called: you get the record
 361    types and data from the input form; see `zone-parse-records' if you want
 362    the raw output."
 363
 364   (labels ((sift (rec ttl)
 365              ;; Parse the record list REC into lists of `zone-record' and
 366              ;; `zone-subdomain' objects, sorting out TTLs and so on.
 367              ;; Returns them as two values.
 368
 369              (collecting (top sub)
 370                (loop
 371                  (unless rec
 372                    (return))
 373                  (let ((r (pop rec)))
 374                    (cond ((eq r :ttl)
 375                           (setf ttl (pop rec)))
 376                          ((symbolp r)
 377                           (collect (make-zone-record :type r
 378                                                      :ttl ttl
 379                                                      :data (pop rec))
 380                                    top))
 381                          ((listp r)
 382                           (dolist (name (listify (car r)))
 383                             (collect (make-zone-subdomain
 384                                       :name (zone-parse-host name)
 385                                       :ttl ttl :records (cdr r))
 386                                      sub)))
 387                          (t
 388                           (error "Unexpected record form ~A" (car r))))))))
 389
 390            (process (rec dom ttl)
 391              ;; Recursirvely process the record list REC, with a list DOM of
 392              ;; prefix labels, and a default TTL.  Promote records for a
 393              ;; preferred subnet to toplevel if there are no toplevel records
 394              ;; already.
 395
 396              (multiple-value-bind (top sub) (sift rec ttl)
 397                (if (and dom (null top) sub)
 398                    (let ((preferred
 399                           (or (find-if
 400                                (lambda (s)
 401                                  (let ((ll (domain-name-labels (zs-name s))))
 402                                    (and (consp ll) (null (cdr ll))
 403                                         (zone-preferred-subnet-p (car ll)))))
 404                                sub)
 405                               (car sub))))
 406                      (when preferred
 407                        (process (zs-records preferred)
 408                                 dom
 409                                 (zs-ttl preferred))))
 410                    (let ((name dom))
 411                      (dolist (zr top)
 412                        (setf (zr-name zr) name)
 413                        (funcall func zr))))
 414                (dolist (s sub)
 415                  (process (zs-records s)
 416                           (if (null dom) (zs-name s)
 417                               (domain-name-concat dom (zs-name s)))
 418                           (zs-ttl s))))))
 419
 420     ;; Process the records we're given with no prefix.
 421     (process rec nil ttl)))
 422
 423 (defun zone-parse-head (head)
 424   "Parse the HEAD of a zone form.
 425
 426    This has the form
 427
 428      (NAME &key :source :admin :refresh :retry
 429                 :expire :min-ttl :ttl :serial)
 430
 431    though a singleton NAME needn't be a list.  Returns the default TTL and an
 432    soa structure representing the zone head."
 433   (destructuring-bind
 434       (raw-zname
 435        &key
 436        (source *default-zone-source*)
 437        (admin (or *default-zone-admin*
 438                   (format nil "hostmaster@~A" raw-zname)))
 439        (refresh *default-zone-refresh*)
 440        (retry *default-zone-retry*)
 441        (expire *default-zone-expire*)
 442        (min-ttl *default-zone-min-ttl*)
 443        (ttl min-ttl)
 444        (serial (make-zone-serial raw-zname))
 445        &aux
 446        (zname (zone-parse-host raw-zname root-domain)))
 447       (listify head)
 448     (values zname
 449             (timespec-seconds ttl)
 450             (make-soa :admin admin
 451                       :source (zone-parse-host source zname)
 452                       :refresh (timespec-seconds refresh)
 453                       :retry (timespec-seconds retry)
 454                       :expire (timespec-seconds expire)
 455                       :min-ttl (timespec-seconds min-ttl)
 456                       :serial serial))))
 457
 458 (export 'defzoneparse)
 459 (defmacro defzoneparse (types (name data list
 460                                &key (prefix (gensym "PREFIX"))
 461                                     (zname (gensym "ZNAME"))
 462                                     (ttl (gensym "TTL")))
 463                         &body body)
 464   "Define a new zone record type.
 465
 466    The arguments are as follows:
 467
 468    TYPES        A singleton type symbol, or a list of aliases.
 469
 470    NAME         The name of the record to be added.
 471
 472    DATA         The content of the record to be added (a single object,
 473                 unevaluated).
 474
 475    LIST         A function to add a record to the zone.  See below.
 476
 477    PREFIX       The prefix tag used in the original form.
 478
 479    ZNAME        The name of the zone being constructed.
 480
 481    TTL          The TTL for this record.
 482
 483    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 484    optional: you don't have to accept them if you're not interested.
 485
 486    The LIST argument names a function to be bound in the body to add a new
 487    low-level record to the zone.  It has the prototype
 488
 489      (LIST &key :name :type :data :ttl :make-ptr-p)
 490
 491    These (except MAKE-PTR-P, which defaults to nil) default to the above
 492    arguments (even if you didn't accept the arguments)."
 493
 494   (setf types (listify types))
 495   (let* ((type (car types))
 496          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 497     (with-parsed-body (body decls doc) body
 498       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 499         `(progn
 500            (dolist (,i ',types)
 501              (setf (get ,i 'zone-parse) ',func))
 502            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 503              ,@doc
 504              ,@decls
 505              (let ((,name (if (null ,prefix) ,zname
 506                               (domain-name-concat ,prefix ,zname))))
 507                (flet ((,list (&key ((:name ,tname) ,name)
 508                                    ((:type ,ttype) ,type)
 509                                    ((:data ,tdata) ,data)
 510                                    ((:ttl ,tttl) ,ttl)
 511                                    ((:make-ptr-p ,tmakeptrp) nil))
 512                         #+cmu (declare (optimize ext:inhibit-warnings))
 513                         (collect (make-zone-record :name ,tname
 514                                                    :type ,ttype
 515                                                    :data ,tdata
 516                                                    :ttl ,tttl
 517                                                    :make-ptr-p ,tmakeptrp)
 518                                  ,col)))
 519                  ,@body)))
 520            ',type)))))
 521
 522 (export 'zone-parse-records)
 523 (defun zone-parse-records (zname ttl records)
 524   "Parse a sequence of RECORDS and return a list of raw records.
 525
 526    The records are parsed relative to the zone name ZNAME, and using the
 527    given default TTL."
 528   (collecting (rec)
 529     (flet ((parse-record (zr)
 530              (let ((func (or (get (zr-type zr) 'zone-parse)
 531                              (error "No parser for record ~A."
 532                                     (zr-type zr))))
 533                    (name (and (zr-name zr) (zr-name zr))))
 534                (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
 535       (zone-process-records records ttl #'parse-record))))
 536
 537 (export 'zone-parse)
 538 (defun zone-parse (zf)
 539   "Parse a ZONE form.
 540
 541    The syntax of a zone form is as follows:
 542
 543    ZONE-FORM:
 544      ZONE-HEAD ZONE-RECORD*
 545
 546    ZONE-RECORD:
 547      ((NAME*) ZONE-RECORD*)
 548    | SYM ARGS"
 549   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 550     (make-zone :name zname
 551                :default-ttl ttl
 552                :soa soa
 553                :records (zone-parse-records zname ttl (cdr zf)))))
 554
 555 (export 'zone-create)
 556 (defun zone-create (zf)
 557   "Zone construction function.
 558
 559    Given a zone form ZF, construct the zone and add it to the table."
 560   (let* ((zone (zone-parse zf))
 561          (name (zone-text-name zone)))
 562     (setf (zone-find name) zone)
 563     name))
 564
 565 (export 'defzone)
 566 (defmacro defzone (soa &body zf)
 567   "Zone definition macro."
 568   `(zone-create '(,soa ,@zf)))
 569
 570 (export '*address-family*)
 571 (defvar *address-family* t
 572   "The default address family.  This is bound by `defrevzone'.")
 573
 574 (export 'defrevzone)
 575 (defmacro defrevzone (head &body zf)
 576   "Define a reverse zone, with the correct name."
 577   (destructuring-bind (nets &rest args
 578                             &key &allow-other-keys
 579                                  (family '*address-family*)
 580                                  prefix-bits)
 581       (listify head)
 582     (with-gensyms (ipn)
 583       `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
 584          (let ((*address-family* (ipnet-family ,ipn)))
 585            (zone-create `((,(format nil "~A." (reverse-domain ,ipn
 586                                                               ,prefix-bits))
 587                             ,@',(loop for (k v) on args by #'cddr
 588                                       unless (member k
 589                                                      '(:family :prefix-bits))
 590                                       nconc (list k v)))
 591                           ,@',zf)))))))
 592
 593 (export 'map-host-addresses)
 594 (defun map-host-addresses (func addr &key (family *address-family*))
 595   "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
 596
 597   (dolist (a (host-addrs (host-parse addr family)))
 598     (funcall func a)))
 599
 600 (export 'do-host)
 601 (defmacro do-host ((addr spec &key (family *address-family*)) &body body)
 602   "Evaluate BODY, binding ADDR to each address denoted by SPEC."
 603   `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
 604      ,@body))
 605
 606 (export 'zone-set-address)
 607 (defun zone-set-address (rec addrspec &rest args
 608                          &key (family *address-family*) name ttl make-ptr-p)
 609   "Write records (using REC) defining addresses for ADDRSPEC."
 610   (declare (ignore name ttl make-ptr-p))
 611   (let ((key-args (loop for (k v) on args by #'cddr
 612                         unless (eq k :family)
 613                         nconc (list k v))))
 614     (do-host (addr addrspec :family family)
 615       (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
 616
 617 ;;;--------------------------------------------------------------------------
 618 ;;; Building raw record vectors.
 619
 620 (defvar *record-vector* nil
 621   "The record vector under construction.")
 622
 623 (defun rec-ensure (n)
 624   "Ensure that at least N octets are spare in the current record."
 625   (let ((want (+ n (fill-pointer *record-vector*)))
 626         (have (array-dimension *record-vector* 0)))
 627     (unless (<= want have)
 628       (adjust-array *record-vector*
 629                     (do ((new (* 2 have) (* 2 new)))
 630                         ((<= want new) new))))))
 631
 632 (export 'rec-byte)
 633 (defun rec-byte (octets value)
 634   "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
 635   (rec-ensure octets)
 636   (do ((i (1- octets) (1- i)))
 637       ((minusp i))
 638     (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))
 639
 640 (export 'rec-u8)
 641 (defun rec-u8 (value)
 642   "Append an 8-bit VALUE to the current record."
 643   (rec-byte 1 value))
 644
 645 (export 'rec-u16)
 646 (defun rec-u16 (value)
 647   "Append a 16-bit VALUE to the current record."
 648   (rec-byte 2 value))
 649
 650 (export 'rec-u32)
 651 (defun rec-u32 (value)
 652   "Append a 32-bit VALUE to the current record."
 653   (rec-byte 4 value))
 654
 655 (export 'rec-raw-string)
 656 (defun rec-raw-string (s &key (start 0) end)
 657   "Append (a (substring of) a raw string S to the current record.
 658
 659    No arrangement is made for reporting the length of the string.  That must
 660    be done by the caller, if necessary."
 661   (setf-default end (length s))
 662   (rec-ensure (- end start))
 663   (do ((i start (1+ i)))
 664       ((>= i end))
 665     (vector-push (char-code (char s i)) *record-vector*)))
 666
 667 (export 'rec-string)
 668 (defun rec-string (s &key (start 0) end (max 255))
 669   (let* ((end (or end (length s)))
 670          (len (- end start)))
 671     (unless (<= len max)
 672       (error "String `~A' too long" (subseq s start end)))
 673     (rec-u8 (- end start))
 674     (rec-raw-string s :start start :end end)))
 675
 676 (export 'rec-name)
 677 (defun rec-name (name)
 678   "Append a domain NAME.
 679
 680    No attempt is made to perform compression of the name."
 681   (dolist (label (reverse (domain-name-labels name)))
 682     (rec-string label :max 63))
 683   (rec-u8 0))
 684
 685 (export 'build-record)
 686 (defmacro build-record (&body body)
 687   "Build a raw record, and return it as a vector of octets."
 688   `(let ((*record-vector* (make-array 256
 689                                       :element-type '(unsigned-byte 8)
 690                                       :fill-pointer 0
 691                                       :adjustable t)))
 692      ,@body
 693      (copy-seq *record-vector*)))
 694
 695 (export 'zone-record-rrdata)
 696 (defgeneric zone-record-rrdata (type zr)
 697   (:documentation "Emit (using the `build-record' protocol) RRDATA for ZR.
 698
 699    The TYPE is a keyword naming the record type.  Return the numeric RRTYPE
 700    code."))
 701
 702 ;;;--------------------------------------------------------------------------
 703 ;;; Zone record parsers.
 704
 705 (defzoneparse :a (name data rec)
 706   ":a IPADDR"
 707   (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
 708
 709 (defmethod zone-record-rrdata ((type (eql :a)) zr)
 710   (rec-u32 (ipaddr-addr (zr-data zr)))
 711   1)
 712
 713 (defzoneparse :aaaa (name data rec)
 714   ":aaaa IPADDR"
 715   (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
 716
 717 (defmethod zone-record-rrdata ((type (eql :aaaa)) zr)
 718   (rec-byte 16 (ipaddr-addr (zr-data zr)))
 719   28)
 720
 721 (defzoneparse :addr (name data rec)
 722   ":addr IPADDR"
 723   (zone-set-address #'rec data :make-ptr-p t))
 724
 725 (defzoneparse :svc (name data rec)
 726   ":svc IPADDR"
 727   (zone-set-address #'rec data))
 728
 729 (defzoneparse :ptr (name data rec :zname zname)
 730   ":ptr HOST"
 731   (rec :data (zone-parse-host data zname)))
 732
 733 (defmethod zone-record-rrdata ((type (eql :ptr)) zr)
 734   (rec-name (zr-data zr))
 735   12)
 736
 737 (defzoneparse :cname (name data rec :zname zname)
 738   ":cname HOST"
 739   (rec :data (zone-parse-host data zname)))
 740
 741 (defmethod zone-record-rrdata ((type (eql :cname)) zr)
 742   (rec-name (zr-data zr))
 743   5)
 744
 745 (defzoneparse :txt (name data rec)
 746   ":txt (TEXT*)"
 747   (rec :data (listify data)))
 748
 749 (defmethod zone-record-rrdata ((type (eql :txt)) zr)
 750   (mapc #'rec-string (zr-data zr))
 751   16)
 752
 753 (export '*dkim-pathname-defaults*)
 754 (defvar *dkim-pathname-defaults*
 755   (make-pathname :directory '(:relative "keys")
 756                  :type "dkim"))
 757
 758 (defzoneparse :dkim (name data rec)
 759   ":dkim (KEYFILE {:TAG VALUE}*)"
 760   (destructuring-bind (file &rest plist) (listify data)
 761     (let ((things nil) (out nil))
 762       (labels ((flush ()
 763                  (when out
 764                    (push (get-output-stream-string out) things)
 765                    (setf out nil)))
 766                (emit (text)
 767                  (let ((len (length text)))
 768                    (when (and out (> (+ (file-position out)
 769                                         (length text))
 770                                      64))
 771                      (flush))
 772                    (when (plusp len)
 773                      (cond ((< len 64)
 774                             (unless out (setf out (make-string-output-stream)))
 775                             (write-string text out))
 776                            (t
 777                             (do ((i 0 j)
 778                                  (j 64 (+ j 64)))
 779                                 ((>= i len))
 780                               (push (subseq text i (min j len)) things))))))))
 781         (do ((p plist (cddr p)))
 782             ((endp p))
 783           (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
 784         (emit (with-output-to-string (out)
 785                 (write-string "p=" out)
 786                 (when file
 787                   (with-open-file
 788                       (in (merge-pathnames file *dkim-pathname-defaults*))
 789                     (loop
 790                       (when (string= (read-line in)
 791                                      "-----BEGIN PUBLIC KEY-----")
 792                         (return)))
 793                     (loop
 794                       (let ((line (read-line in)))
 795                         (if (string= line "-----END PUBLIC KEY-----")
 796                             (return)
 797                             (write-string line out)))))))))
 798       (rec :type :txt
 799            :data (nreverse things)))))
 800
 801 (eval-when (:load-toplevel :execute)
 802   (dolist (item '((sshfp-algorithm rsa 1)
 803                   (sshfp-algorithm dsa 2)
 804                   (sshfp-algorithm ecdsa 3)
 805                   (sshfp-type sha-1 1)
 806                   (sshfp-type sha-256 2)))
 807     (destructuring-bind (prop sym val) item
 808       (setf (get sym prop) val)
 809       (export sym))))
 810
 811 (export '*sshfp-pathname-defaults*)
 812 (defvar *sshfp-pathname-defaults*
 813   (make-pathname :directory '(:relative "keys")
 814                  :type "sshfp"))
 815
 816 (defzoneparse :sshfp (name data rec)
 817   ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
 818   (if (stringp data)
 819       (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
 820         (loop (let ((line (read-line in nil)))
 821                 (unless line (return))
 822                 (let ((words (str-split-words line)))
 823                   (pop words)
 824                   (when (string= (car words) "IN") (pop words))
 825                   (unless (and (string= (car words) "SSHFP")
 826                                (= (length words) 4))
 827                     (error "Invalid SSHFP record."))
 828                   (pop words)
 829                   (destructuring-bind (alg type fpr) words
 830                     (rec :data (list (parse-integer alg)
 831                                      (parse-integer type)
 832                                      fpr)))))))
 833       (flet ((lookup (what prop)
 834                (etypecase what
 835                  (fixnum what)
 836                  (symbol (or (get what prop)
 837                              (error "~S is not a known ~A" what prop))))))
 838         (dolist (item (listify data))
 839           (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
 840               (listify item)
 841             (rec :data (list (lookup alg 'sshfp-algorithm)
 842                              (lookup type 'sshfp-type)
 843                              fpr)))))))
 844
 845 (defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
 846   (destructuring-bind (alg type fpr) (zr-data zr)
 847     (rec-u8 alg)
 848     (rec-u8 type)
 849     (do ((i 0 (+ i 2))
 850          (n (length fpr)))
 851         ((>= i n))
 852       (rec-u8 (parse-integer fpr :start i :end (+ i 2) :radix 16))))
 853   44)
 854
 855 (defzoneparse :mx (name data rec :zname zname)
 856   ":mx ((HOST :prio INT :ip IPADDR)*)"
 857   (dolist (mx (listify data))
 858     (destructuring-bind
 859         (mxname &key (prio *default-mx-priority*) ip)
 860         (listify mx)
 861       (let ((host (zone-parse-host mxname zname)))
 862         (when ip (zone-set-address #'rec ip :name host))
 863         (rec :data (cons host prio))))))
 864
 865 (defmethod zone-record-rrdata ((type (eql :mx)) zr)
 866   (let ((name (car (zr-data zr)))
 867         (prio (cdr (zr-data zr))))
 868     (rec-u16 prio)
 869     (rec-name name))
 870   15)
 871
 872 (defzoneparse :ns (name data rec :zname zname)
 873   ":ns ((HOST :ip IPADDR)*)"
 874   (dolist (ns (listify data))
 875     (destructuring-bind
 876         (nsname &key ip)
 877         (listify ns)
 878       (let ((host (zone-parse-host nsname zname)))
 879         (when ip (zone-set-address #'rec ip :name host))
 880         (rec :data host)))))
 881
 882 (defmethod zone-record-rrdata ((type (eql :ns)) zr)
 883   (rec-name (zr-data zr))
 884   2)
 885
 886 (defzoneparse :alias (name data rec :zname zname)
 887   ":alias (LABEL*)"
 888   (dolist (a (listify data))
 889     (rec :name (zone-parse-host a zname)
 890          :type :cname
 891          :data name)))
 892
 893 (defzoneparse :srv (name data rec :zname zname)
 894   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
 895   (dolist (srv data)
 896     (destructuring-bind (servopts &rest providers) srv
 897       (destructuring-bind
 898           (service &key ((:port default-port)) (protocol :tcp))
 899           (listify servopts)
 900         (unless default-port
 901           (let ((serv (serv-by-name service protocol)))
 902             (setf default-port (and serv (serv-port serv)))))
 903         (let ((rname (flet ((prepend (tag tail)
 904                               (domain-name-concat
 905                                (make-domain-name
 906                                 :labels (list (format nil "_~(~A~)" tag)))
 907                                tail)))
 908                        (prepend service (prepend protocol name)))))
 909           (dolist (prov providers)
 910             (destructuring-bind
 911                 (srvname
 912                  &key
 913                  (port default-port)
 914                  (prio *default-mx-priority*)
 915                  (weight 0)
 916                  ip)
 917                 (listify prov)
 918               (let ((host (zone-parse-host srvname zname)))
 919                 (when ip (zone-set-address #'rec ip :name host))
 920                 (rec :name rname
 921                      :data (list prio weight port host))))))))))
 922
 923 (defmethod zone-record-rrdata ((type (eql :srv)) zr)
 924   (destructuring-bind (prio weight port host) (zr-data zr)
 925     (rec-u16 prio)
 926     (rec-u16 weight)
 927     (rec-u16 port)
 928     (rec-name host))
 929   33)
 930
 931 (defzoneparse :net (name data rec)
 932   ":net (NETWORK*)"
 933   (dolist (net (listify data))
 934     (dolist (ipn (net-ipnets (net-must-find net)))
 935       (let* ((base (ipnet-net ipn))
 936              (rrtype (ipaddr-rrtype base)))
 937         (flet ((frob (kind addr)
 938                  (when addr
 939                    (rec :name (zone-parse-host kind name)
 940                         :type rrtype
 941                         :data addr))))
 942           (frob "net" base)
 943           (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
 944           (frob "bcast" (ipnet-broadcast ipn)))))))
 945
 946 (defzoneparse (:rev :reverse) (name data rec)
 947   ":reverse ((NET &key :prefix-bits :family) ZONE*)
 948
 949    Add a reverse record each host in the ZONEs (or all zones) that lies
 950    within NET."
 951   (setf data (listify data))
 952   (destructuring-bind (net &key prefix-bits (family *address-family*))
 953       (listify (car data))
 954
 955     (dolist (ipn (net-parse-to-ipnets net family))
 956       (let* ((seen (make-hash-table :test #'equal))
 957              (width (ipnet-width ipn))
 958              (frag-len (if prefix-bits (- width prefix-bits)
 959                            (ipnet-changeable-bits width (ipnet-mask ipn)))))
 960         (dolist (z (or (cdr data) (hash-table-keys *zones*)))
 961           (dolist (zr (zone-records (zone-find z)))
 962             (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
 963                        (zr-make-ptr-p zr)
 964                        (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
 965               (let* ((frag (reverse-domain-fragment (zr-data zr)
 966                                                     0 frag-len))
 967                      (name (domain-name-concat frag name))
 968                      (name-string (princ-to-string name)))
 969                 (unless (gethash name-string seen)
 970                   (rec :name name :type :ptr
 971                        :ttl (zr-ttl zr) :data (zr-name zr))
 972                   (setf (gethash name-string seen) t))))))))))
 973
 974 (defzoneparse :multi (name data rec :zname zname :ttl ttl)
 975   ":multi (((NET*) &key :start :end :family :suffix) . REC)
 976
 977    Output multiple records covering a portion of the reverse-resolution
 978    namespace corresponding to the particular NETs.  The START and END bounds
 979    default to the most significant variable component of the
 980    reverse-resolution domain.
 981
 982    The REC tail is a sequence of record forms (as handled by
 983    `zone-process-records') to be emitted for each covered address.  Within
 984    the bodies of these forms, the symbol `*' will be replaced by the
 985    domain-name fragment corresponding to the current host, optionally
 986    followed by the SUFFIX.
 987
 988    Examples:
 989
 990         (:multi ((delegated-subnet :start 8)
 991                  :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
 992
 993         (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
 994                  :cname *))
 995
 996    Obviously, nested `:multi' records won't work well."
 997
 998   (destructuring-bind (nets
 999                        &key start end ((:suffix raw-suffix))
1000                        (family *address-family*))
1001       (listify (car data))
1002     (let ((suffix (if (not raw-suffix)
1003                       (make-domain-name :labels nil :absolutep nil)
1004                       (zone-parse-host raw-suffix))))
1005       (dolist (net (listify nets))
1006         (dolist (ipn (net-parse-to-ipnets net family))
1007           (let* ((addr (ipnet-net ipn))
1008                  (width (ipaddr-width addr))
1009                  (comp-width (reverse-domain-component-width addr))
1010                  (end (round-up (or end
1011                                     (ipnet-changeable-bits width
1012                                                            (ipnet-mask ipn)))
1013                                 comp-width))
1014                  (start (round-down (or start (- end comp-width))
1015                                     comp-width))
1016                  (map (ipnet-host-map ipn)))
1017             (multiple-value-bind (host-step host-limit)
1018                 (ipnet-index-bounds map start end)
1019               (do ((index 0 (+ index host-step)))
1020                   ((> index host-limit))
1021                 (let* ((addr (ipnet-index-host map index))
1022                        (frag (reverse-domain-fragment addr start end))
1023                        (target (reduce #'domain-name-concat
1024                                        (list frag suffix zname)
1025                                        :from-end t
1026                                        :initial-value root-domain)))
1027                   (dolist (zr (zone-parse-records (domain-name-concat frag
1028                                                                       zname)
1029                                                   ttl
1030                                                   (subst target '*
1031                                                          (cdr data))))
1032                     (rec :name (zr-name zr)
1033                          :type (zr-type zr)
1034                          :data (zr-data zr)
1035                          :ttl (zr-ttl zr)
1036                          :make-ptr-p (zr-make-ptr-p zr))))))))))))
1037
1038 ;;;--------------------------------------------------------------------------
1039 ;;; Zone file output.
1040
1041 (export 'zone-write)
1042 (defgeneric zone-write (format zone stream)
1043   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
1044
1045 (defvar *writing-zone* nil
1046   "The zone currently being written.")
1047
1048 (defvar *zone-output-stream* nil
1049   "Stream to write zone data on.")
1050
1051 (export 'zone-write-raw-rrdata)
1052 (defgeneric zone-write-raw-rrdata (format zr type data)
1053   (:documentation "Write an otherwise unsupported record in a given FORMAT.
1054
1055    ZR gives the record object, which carries the name and TTL; the TYPE is
1056    the numeric RRTYPE code; and DATA is an octet vector giving the RRDATA.
1057    This is used by the default `zone-write-record' method to handle record
1058    types which aren't directly supported by the format driver."))
1059
1060 (export 'zone-write-header)
1061 (defgeneric zone-write-header (format zone)
1062   (:documentation "Emit the header for a ZONE, in a given FORMAT.
1063
1064    The header includes any kind of initial comment, the SOA record, and any
1065    other necessary preamble.  There is no default implementation.
1066
1067    This is part of the protocol used by the default method on `zone-write';
1068    if you override that method."))
1069
1070 (export 'zone-write-trailer)
1071 (defgeneric zone-write-trailer (format zone)
1072   (:documentation "Emit the header for a ZONE, in a given FORMAT.
1073
1074    The footer may be empty, and is so by default.
1075
1076    This is part of the protocol used by the default method on `zone-write';
1077    if you override that method.")
1078   (:method (format zone)
1079     (declare (ignore format zone))
1080     nil))
1081
1082 (export 'zone-write-record)
1083 (defgeneric zone-write-record (format type zr)
1084   (:documentation "Emit a record of the given TYPE (a keyword).
1085
1086    The default implementation builds the raw RRDATA and passes it to
1087    `zone-write-raw-rrdata'.")
1088   (:method (format type zr)
1089     (let* (code
1090            (data (build-record (setf code (zone-record-rrdata type zr)))))
1091       (zone-write-raw-rrdata format zr code data))))
1092
1093 (defmethod zone-write (format zone stream)
1094   "This default method calls `zone-write-header', then `zone-write-record'
1095    for each record in the zone, and finally `zone-write-trailer'.  While it's
1096    running, `*writing-zone*' is bound to the zone object, and
1097   `*zone-output-stream*' to the output stream."
1098   (let ((*writing-zone* zone)
1099         (*zone-output-stream* stream))
1100     (zone-write-header format zone)
1101     (dolist (zr (zone-records-sorted zone))
1102       (zone-write-record format (zr-type zr) zr))
1103     (zone-write-trailer format zone)))
1104
1105 (export 'zone-save)
1106 (defun zone-save (zones &key (format :bind))
1107   "Write the named ZONES to files.  If no zones are given, write all the
1108    zones."
1109   (unless zones
1110     (setf zones (hash-table-keys *zones*)))
1111   (safely (safe)
1112     (dolist (z zones)
1113       (let ((zz (zone-find z)))
1114         (unless zz
1115           (error "Unknown zone `~A'." z))
1116         (let ((stream (safely-open-output-stream safe
1117                                                  (zone-file-name z :zone))))
1118           (zone-write format zz stream))))))
1119
1120 ;;;--------------------------------------------------------------------------
1121 ;;; Bind format output.
1122
1123 (defvar *bind-last-record-name* nil
1124   "The previously emitted record name.
1125
1126    Used for eliding record names on output.")
1127
1128 (export 'bind-hostname)
1129 (defun bind-hostname (hostname)
1130   (let ((zone (domain-name-labels (zone-name *writing-zone*)))
1131         (name (domain-name-labels hostname)))
1132     (loop
1133       (unless (and zone name (string= (car zone) (car name)))
1134         (return))
1135       (pop zone) (pop name))
1136     (flet ((stitch (labels absolutep)
1137              (format nil "~{~A~^.~}~@[.~]"
1138                      (reverse (mapcar #'quotify-label labels))
1139                      absolutep)))
1140       (cond (zone (stitch (domain-name-labels hostname) t))
1141             (name (stitch name nil))
1142             (t "@")))))
1143
1144 (export 'bind-output-hostname)
1145 (defun bind-output-hostname (hostname)
1146   (let ((name (bind-hostname hostname)))
1147     (cond ((and *bind-last-record-name*
1148                 (string= name *bind-last-record-name*))
1149            "")
1150           (t
1151            (setf *bind-last-record-name* name)
1152            name))))
1153
1154 (defmethod zone-write :around ((format (eql :bind)) zone stream)
1155   (declare (ignorable zone stream))
1156   (let ((*bind-last-record-name* nil))
1157     (call-next-method)))
1158
1159 (defmethod zone-write-header ((format (eql :bind)) zone)
1160   (format *zone-output-stream* "~
1161 ;;; Zone file `~(~A~)'
1162 ;;;   (generated ~A)
1163
1164 $ORIGIN ~0@*~(~A.~)
1165 $TTL ~2@*~D~2%"
1166             (zone-name zone)
1167             (iso-date :now :datep t :timep t)
1168             (zone-default-ttl zone))
1169   (let* ((soa (zone-soa zone))
1170          (admin (let* ((name (soa-admin soa))
1171                        (at (position #\@ name))
1172                        (copy (format nil "~(~A~)." name)))
1173                   (when at
1174                     (setf (char copy at) #\.))
1175                   copy)))
1176       (format *zone-output-stream* "~
1177 ~A~30TIN SOA~40T~A (
1178 ~55@A~60T ;administrator
1179 ~45T~10D~60T ;serial
1180 ~45T~10D~60T ;refresh
1181 ~45T~10D~60T ;retry
1182 ~45T~10D~60T ;expire
1183 ~45T~10D )~60T ;min-ttl~2%"
1184               (bind-output-hostname (zone-name zone))
1185               (bind-hostname (soa-source soa))
1186               admin
1187               (soa-serial soa)
1188               (soa-refresh soa)
1189               (soa-retry soa)
1190               (soa-expire soa)
1191               (soa-min-ttl soa))))
1192
1193 (export 'bind-format-record)
1194 (defun bind-format-record (zr format &rest args)
1195   (format *zone-output-stream*
1196           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
1197           (bind-output-hostname (zr-name zr))
1198           (let ((ttl (zr-ttl zr)))
1199             (and (/= ttl (zone-default-ttl *writing-zone*))
1200                  ttl))
1201           (string-upcase (symbol-name (zr-type zr)))
1202           format args))
1203
1204 (defmethod zone-write-raw-rrdata ((format (eql :bind)) zr type data)
1205   (format *zone-output-stream*
1206           "~A~20T~@[~8D~]~30TIN TYPE~A~40T\\# ~A"
1207           (bind-output-hostname (zr-name zr))
1208           (let ((ttl (zr-ttl zr)))
1209             (and (/= ttl (zone-default-ttl *writing-zone*))
1210                  ttl))
1211           type
1212           (length data))
1213   (let* ((hex (with-output-to-string (out)
1214                (dotimes (i (length data))
1215                  (format out "~(~2,'0X~)" (aref data i)))))
1216          (len (length hex)))
1217     (cond ((< len 24)
1218            (format *zone-output-stream* " ~A~%" hex))
1219           (t
1220            (format *zone-output-stream* " (")
1221            (let ((i 0))
1222              (loop
1223                (when (>= i len) (return))
1224                (let ((j (min (+ i 64) len)))
1225                  (format *zone-output-stream* "~%~8T~A" (subseq hex i j))
1226                  (setf i j))))
1227            (format *zone-output-stream* " )~%")))))
1228
1229 (defmethod zone-write-record ((format (eql :bind)) (type (eql :a)) zr)
1230   (bind-format-record zr "~A" (ipaddr-string (zr-data zr))))
1231
1232 (defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr)
1233   (bind-format-record zr "~A" (ipaddr-string (zr-data zr))))
1234
1235 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr)
1236   (bind-format-record zr "~A" (bind-hostname (zr-data zr))))
1237
1238 (defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr)
1239   (bind-format-record zr "~A" (bind-hostname (zr-data zr))))
1240
1241 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr)
1242   (bind-format-record zr "~A" (bind-hostname (zr-data zr))))
1243
1244 (defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr)
1245   (bind-format-record zr "~2D ~A"
1246                       (cdr (zr-data zr))
1247                       (bind-hostname (car (zr-data zr)))))
1248
1249 (defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr)
1250   (destructuring-bind (prio weight port host) (zr-data zr)
1251     (bind-format-record zr "~2D ~5D ~5D ~A"
1252                         prio weight port (bind-hostname host))))
1253
1254 (defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr)
1255   (bind-format-record zr "~{~2D ~2D ~A~}" (zr-data zr)))
1256
1257 (defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr)
1258   (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}" (zr-data zr)))
1259
1260 ;;;--------------------------------------------------------------------------
1261 ;;; tinydns-data output format.
1262
1263 (export 'tinydns-output)
1264 (defun tinydns-output (code &rest fields)
1265   (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))
1266
1267 (defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data)
1268   (tinydns-output #\: (zr-name zr) type
1269                   (with-output-to-string (out)
1270                     (dotimes (i (length data))
1271                       (let ((byte (aref data i)))
1272                         (if (or (<= byte 32)
1273                                 (>= byte 128)
1274                                 (member byte '(#\: #\\) :key #'char-code))
1275                             (format out "\\~3,'0O" byte)
1276                             (write-char (code-char byte) out)))))
1277                   (zr-ttl zr)))
1278
1279 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :a)) zr)
1280   (tinydns-output #\+ (zr-name zr)
1281                   (ipaddr-string (zr-data zr)) (zr-ttl zr)))
1282
1283 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :aaaa)) zr)
1284   (tinydns-output #\3 (zr-name zr)
1285                   (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr)))
1286                   (zr-ttl zr)))
1287
1288 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ptr)) zr)
1289   (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr)))
1290
1291 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :cname)) zr)
1292   (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr)))
1293
1294 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ns)) zr)
1295   (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr)))
1296
1297 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :mx)) zr)
1298   (let ((name (car (zr-data zr)))
1299         (prio (cdr (zr-data zr))))
1300     (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr))))
1301
1302 (defmethod zone-write-header ((format (eql :tinydns)) zone)
1303   (format *zone-output-stream* "~
1304 ### Zone file `~(~A~)'
1305 ###   (generated ~A)
1306 ~%"
1307           (zone-name zone)
1308           (iso-date :now :datep t :timep t))
1309   (let ((soa (zone-soa zone)))
1310     (tinydns-output #\Z
1311                     (zone-name zone)
1312                     (soa-source soa)
1313                     (let* ((name (copy-seq (soa-admin soa)))
1314                            (at (position #\@ name)))
1315                       (when at (setf (char name at) #\.))
1316                       name)
1317                     (soa-serial soa)
1318                     (soa-refresh soa)
1319                     (soa-expire soa)
1320                     (soa-min-ttl soa)
1321                     (zone-default-ttl zone))))
1322
1323 ;;;----- That's all, folks --------------------------------------------------