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 #:anaphora #: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 (export '*zone-config*)
  39 (defparameter *zone-config* nil
  40   "A list of configuration variables.
  41
  42    This is for the benefit of the frontend, which will dynamically bind them
  43    so that input files can override them independently.  Not intended for use
  44    by users.")
  45
  46 (defun to-integer (x)
  47   "Convert X to an integer in the most straightforward way."
  48   (floor (rational x)))
  49
  50 (defun from-mixed-base (base val)
  51   "BASE is a list of the ranges for the `digits' of a mixed-base
  52    representation.  Convert VAL, a list of digits, into an integer."
  53   (do ((base base (cdr base))
  54        (val (cdr val) (cdr val))
  55        (a (car val) (+ (* a (car base)) (car val))))
  56       ((or (null base) (null val)) a)))
  57
  58 (defun to-mixed-base (base val)
  59   "BASE is a list of the ranges for the `digits' of a mixed-base
  60    representation.  Convert VAL, an integer, into a list of digits."
  61   (let ((base (reverse base))
  62         (a nil))
  63     (loop
  64       (unless base
  65         (push val a)
  66         (return a))
  67       (multiple-value-bind (q r) (floor val (pop base))
  68         (push r a)
  69         (setf val q)))))
  70
  71 (let ((unit-scale (make-hash-table)))
  72
  73   (dolist (item `(((:second :seconds :sec :secs :s) ,1)
  74                   ((:minute :minutes :min :mins :m) ,60)
  75                   ((:hour :hours :hr :hrs :h) ,(* 60 60))
  76                   ((:day :days :dy :dys :d) ,(* 24 60 60))
  77                   ((:week :weeks :wk :wks :w) ,(* 7 24 60 60))))
  78     (destructuring-bind (units scale) item
  79       (dolist (unit units) (setf (gethash unit unit-scale) scale))))
  80
  81   (export 'timespec-seconds)
  82   (defun timespec-seconds (ts)
  83     "Convert a timespec TS to seconds.
  84
  85      A timespec may be a real count of seconds, or a list ({COUNT UNIT}*).
  86      UNIT may be any of a number of obvious time units."
  87     (labels ((convert (acc ts)
  88                (cond ((null ts) acc)
  89                      ((realp ts) (+ acc (floor ts)))
  90                      ((atom ts) (error "Unknown timespec format ~A" ts))
  91                      (t
  92                       (destructuring-bind
  93                           (count &optional unit &rest tail) ts
  94                         (let ((scale
  95                                 (acond ((null unit) 1)
  96                                        ((gethash (intern (string-upcase
  97                                                           (stringify unit))
  98                                                          :keyword)
  99                                                  unit-scale)
 100                                         it)
 101                                        (t
 102                                         (error "Unknown time unit ~S"
 103                                                unit)))))
 104                           (convert (+ acc (to-integer (* count scale)))
 105                                    tail)))))))
 106       (convert 0 ts))))
 107
 108 (defun hash-table-keys (ht)
 109   "Return a list of the keys in hashtable HT."
 110   (collecting ()
 111     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 112
 113 (defun iso-date (&optional time &key datep timep (sep #\ ))
 114   "Construct a textual date or time in ISO format.
 115
 116    The TIME is the universal time to convert, which defaults to now; DATEP is
 117    whether to emit the date; TIMEP is whether to emit the time, and
 118    SEP (default is space) is how to separate the two."
 119   (multiple-value-bind
 120       (sec min hr day mon yr dow dstp tz)
 121       (decode-universal-time (if (or (null time) (eq time :now))
 122                                  (get-universal-time)
 123                                  time))
 124     (declare (ignore dow dstp tz))
 125     (with-output-to-string (s)
 126       (when datep
 127         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 128         (when timep
 129           (write-char sep s)))
 130       (when timep
 131         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 132
 133 (deftype octet () '(unsigned-byte 8))
 134 (deftype octet-vector (&optional n) `(array octet (,n)))
 135
 136 (defun decode-hex (hex &key (start 0) end)
 137   "Decode a hexadecimal-encoded string, returning a vector of octets."
 138   (let* ((end (or end (length hex)))
 139          (len (- end start))
 140          (raw (make-array (floor len 2) :element-type 'octet)))
 141     (unless (evenp len)
 142       (error "Invalid hex string `~A' (odd length)" hex))
 143     (do ((i start (+ i 2)))
 144         ((>= i end) raw)
 145       (let ((high (digit-char-p (char hex i) 16))
 146             (low (digit-char-p (char hex (1+ i)) 16)))
 147         (unless (and high low)
 148           (error "Invalid hex string `~A' (bad digit)" hex))
 149         (setf (aref raw (/ (- i start) 2)) (+ (* 16 high) low))))))
 150
 151 (defun slurp-file (file &optional (element-type 'character))
 152   "Read and return the contents of FILE as a vector."
 153   (with-open-file (in file :element-type element-type)
 154     (let ((buf (make-array 1024 :element-type element-type))
 155           (pos 0))
 156       (loop
 157         (let ((end (read-sequence buf in :start pos)))
 158           (when (< end (length buf))
 159             (return (adjust-array buf end)))
 160           (setf pos end
 161                 buf (adjust-array buf (* 2 pos))))))))
 162
 163 (defmacro defenum (name (&key export) &body values)
 164   "Set up symbol properties for manifest constants.
 165
 166    The VALUES are a list of (TAG VALUE) pairs.  Each TAG is a symbol; we set
 167    the NAME property on TAG to VALUE, and export TAG.  There are also handy
 168    hash-tables mapping in the forward and reverse directions, in the name
 169    symbol's `enum-forward' and `enum-reverse' properties."
 170   `(eval-when (:compile-toplevel :load-toplevel :execute)
 171      ,(let*/gensyms (export)
 172         (with-gensyms (forward reverse valtmp)
 173           `(let ((,forward (make-hash-table))
 174                  (,reverse (make-hash-table)))
 175              (when ,export (export ',name))
 176              ,@(mapcar (lambda (item)
 177                          (destructuring-bind (tag value) item
 178                            (let ((constant
 179                                   (intern (concatenate 'string
 180                                                        (symbol-name name)
 181                                                        "/"
 182                                                        (symbol-name tag)))))
 183                              `(let ((,valtmp ,value))
 184                                 (when ,export
 185                                   (export ',constant)
 186                                   (when (eq (symbol-package ',tag) *package*)
 187                                     (export ',tag)))
 188                                 (defconstant ,constant ,valtmp)
 189                                 (setf (get ',tag ',name) ,value
 190                                       (gethash ',tag ,forward) ,valtmp
 191                                       (gethash ,valtmp ,reverse) ',tag)))))
 192                        values)
 193              (setf (get ',name 'enum-forward) ,forward
 194                    (get ',name 'enum-reverse) ,reverse))))))
 195
 196 (defun lookup-enum (name tag &key min max)
 197   "Look up a TAG in an enumeration.
 198
 199    If TAG is a symbol, check its NAME property; if it's a fixnum then take it
 200    as it is.  Make sure that it's between MIN and MAX, if they're not nil."
 201   (let ((value (etypecase tag
 202                 (fixnum tag)
 203                 (symbol (or (get tag name)
 204                             (error "~S is not a known ~A" tag name))))))
 205     (unless (and (or (null min) (<= min value))
 206                 (or (null max) (<= value max)))
 207       (error "Value ~S out of range for ~A" value name))
 208     value))
 209
 210 (defun reverse-enum (name value)
 211   "Reverse-lookup of a VALUE in enumeration NAME.
 212
 213    If a tag for the VALUE is found, return it and `t'; otherwise return VALUE
 214    unchanged and `nil'."
 215   (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse))
 216     (if foundp
 217         (values tag t)
 218         (values value nil))))
 219
 220 (defun mapenum (func name)
 221   "Call FUNC on TAG/VALUE pairs from the enumeration called NAME."
 222   (maphash func (get name 'enum-forward)))
 223
 224 (defun hash-file (hash file context)
 225   "Hash the FILE using the OpenSSL HASH function, returning an octet string.
 226
 227    CONTEXT is a temporary-files context."
 228   (let ((temp (temporary-file context "hash")))
 229     (run-program (list "openssl" "dgst" (concatenate 'string "-" hash))
 230                  :input file :output temp)
 231     (with-open-file (in temp)
 232       (let ((line (read-line in)))
 233         (assert (and (>= (length line) 9)
 234                      (string= line "(stdin)= " :end1 9)))
 235         (decode-hex line :start 9)))))
 236
 237 ;;;--------------------------------------------------------------------------
 238 ;;; Zone types.
 239
 240 (export 'soa)
 241 (defstruct (soa (:predicate soap))
 242   "Start-of-authority record information."
 243   source
 244   admin
 245   refresh
 246   retry
 247   expire
 248   min-ttl
 249   serial)
 250
 251 (export 'mx)
 252 (defstruct (mx (:predicate mxp))
 253   "Mail-exchange record information."
 254   priority
 255   domain)
 256
 257 (export 'zone)
 258 (defstruct (zone (:predicate zonep))
 259   "Zone information."
 260   soa
 261   default-ttl
 262   name
 263   records)
 264
 265 (export 'zone-text-name)
 266 (defun zone-text-name (zone)
 267   (princ-to-string (zone-name zone)))
 268
 269 ;;;--------------------------------------------------------------------------
 270 ;;; Zone defaults.  It is intended that scripts override these.
 271
 272 (export '*default-zone-source*)
 273 (defvar *default-zone-source*
 274   (let ((hn (gethostname)))
 275     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 276   "The default zone source: the current host's name.")
 277
 278 (export '*default-zone-refresh*)
 279 (defvar *default-zone-refresh* (* 8 60 60)
 280   "Default zone refresh interval: eight hours.")
 281
 282 (export '*default-zone-admin*)
 283 (defvar *default-zone-admin* nil
 284   "Default zone administrator's email address.")
 285
 286 (export '*default-zone-retry*)
 287 (defvar *default-zone-retry* (* 20 60)
 288   "Default zone retry interval: twenty minutes.")
 289
 290 (export '*default-zone-expire*)
 291 (defvar *default-zone-expire* (* 3 24 60 60)
 292   "Default zone expiry time: three days.")
 293
 294 (export '*default-zone-min-ttl*)
 295 (defvar *default-zone-min-ttl* (* 4 60 60)
 296   "Default zone minimum/negative TTL: four hours.")
 297
 298 (export '*default-zone-ttl*)
 299 (defvar *default-zone-ttl* (* 4 60 60)
 300   "Default zone TTL (for records without explicit TTLs): four hours.")
 301
 302 (export '*default-mx-priority*)
 303 (defvar *default-mx-priority* 50
 304   "Default MX priority.")
 305
 306 ;;;--------------------------------------------------------------------------
 307 ;;; Zone variables and structures.
 308
 309 (defvar *zones* (make-hash-table :test #'equal)
 310   "Map of known zones.")
 311
 312 (export 'zone-find)
 313 (defun zone-find (name)
 314   "Find a zone given its NAME."
 315   (gethash (string-downcase (stringify name)) *zones*))
 316 (defun (setf zone-find) (zone name)
 317   "Make the zone NAME map to ZONE."
 318   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 319
 320 (export 'zone-record)
 321 (defstruct (zone-record (:conc-name zr-))
 322   "A zone record."
 323   (name '<unnamed>)
 324   ttl
 325   type
 326   (make-ptr-p nil)
 327   data)
 328
 329 (export 'zone-subdomain)
 330 (defstruct (zone-subdomain (:conc-name zs-))
 331   "A subdomain.
 332
 333    Slightly weird.  Used internally by `zone-process-records', and shouldn't
 334    escape."
 335   name
 336   ttl
 337   records)
 338
 339 (export '*zone-output-path*)
 340 (defvar *zone-output-path* nil
 341   "Pathname defaults to merge into output files.
 342
 343    If this is nil then use the prevailing `*default-pathname-defaults*'.
 344    This is not the same as capturing the `*default-pathname-defaults*' from
 345    load time.")
 346
 347 (export '*preferred-subnets*)
 348 (defvar *preferred-subnets* nil
 349   "Subnets to prefer when selecting defaults.")
 350
 351 ;;;--------------------------------------------------------------------------
 352 ;;; Zone infrastructure.
 353
 354 (defun zone-file-name (zone type)
 355   "Choose a file name for a given ZONE and TYPE."
 356   (merge-pathnames (make-pathname :name (string-downcase zone)
 357                                   :type (string-downcase type))
 358                    (or *zone-output-path* *default-pathname-defaults*)))
 359
 360 (export 'zone-preferred-subnet-p)
 361 (defun zone-preferred-subnet-p (name)
 362   "Answer whether NAME (a string or symbol) names a preferred subnet."
 363   (member name *preferred-subnets* :test #'string-equal))
 364
 365 (export 'preferred-subnet-case)
 366 (defmacro preferred-subnet-case (&body clauses)
 367   "Execute a form based on which networks are considered preferred.
 368
 369    The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
 370    whose SUBNETS (a list or single symbol, not evaluated) are listed in
 371    `*preferred-subnets*'.  If SUBNETS is the symbol `t' then the clause
 372    always matches."
 373   `(cond
 374     ,@(mapcar (lambda (clause)
 375                 (let ((subnets (car clause)))
 376                   (cons (cond ((eq subnets t)
 377                                t)
 378                               ((listp subnets)
 379                                `(or ,@(mapcar (lambda (subnet)
 380                                                 `(zone-preferred-subnet-p
 381                                                   ',subnet))
 382                                               subnets)))
 383                               (t
 384                                `(zone-preferred-subnet-p ',subnets)))
 385                         (cdr clause))))
 386               clauses)))
 387
 388 (export 'zone-parse-host)
 389 (defun zone-parse-host (form &optional tail)
 390   "Parse a host name FORM from a value in a zone form.
 391
 392    The underlying parsing is done using `parse-domain-name'.  Here, we
 393    interpret various kinds of Lisp object specially.  In particular: `nil'
 394    refers to the TAIL zone (just like a plain `@'); and a symbol is downcased
 395    before use."
 396   (let ((name (etypecase form
 397                 (null (make-domain-name :labels nil :absolutep nil))
 398                 (domain-name form)
 399                 (symbol (parse-domain-name (string-downcase form)))
 400                 (string (parse-domain-name form)))))
 401     (if (null tail) name
 402         (domain-name-concat name tail))))
 403
 404 (export 'zone-records-sorted)
 405 (defun zone-records-sorted (zone)
 406   "Return the ZONE's records, in a pleasant sorted order."
 407   (sort (copy-seq (zone-records zone))
 408         (lambda (zr-a zr-b)
 409           (multiple-value-bind (precp follp)
 410               (domain-name< (zr-name zr-a) (zr-name zr-b))
 411             (cond (precp t)
 412                   (follp nil)
 413                   (t (string< (zr-type zr-a) (zr-type zr-b))))))))
 414
 415 ;;;--------------------------------------------------------------------------
 416 ;;; Serial numbering.
 417
 418 (export 'make-zone-serial)
 419 (defun make-zone-serial (name)
 420   "Given a zone NAME, come up with a new serial number.
 421
 422    This will (very carefully) update a file ZONE.serial in the current
 423    directory."
 424   (let* ((file (zone-file-name name :serial))
 425          (last (with-open-file (in file
 426                                    :direction :input
 427                                    :if-does-not-exist nil)
 428                  (if in (read in)
 429                      (list 0 0 0 0))))
 430          (now (multiple-value-bind
 431                   (sec min hr dy mon yr dow dstp tz)
 432                   (get-decoded-time)
 433                 (declare (ignore sec min hr dow dstp tz))
 434                 (list dy mon yr)))
 435          (seq (cond ((not (equal now (cdr last))) 0)
 436                     ((< (car last) 99) (1+ (car last)))
 437                     (t (error "Run out of sequence numbers for ~A" name)))))
 438     (safely-writing (out file)
 439       (format out
 440               ";; Serial number file for zone ~A~%~
 441                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 442                ~S~%"
 443               name
 444               (cons seq now)))
 445     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 446
 447 ;;;--------------------------------------------------------------------------
 448 ;;; Zone form parsing.
 449
 450 (defun zone-process-records (rec ttl func)
 451   "Sort out the list of records in REC, calling FUNC for each one.
 452
 453    TTL is the default time-to-live for records which don't specify one.
 454
 455    REC is a list of records of the form
 456
 457         ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
 458
 459    The various kinds of entries have the following meanings.
 460
 461    :ttl TTL             Set the TTL for subsequent records (at this level of
 462                           nesting only).
 463
 464    TYPE DATA            Define a record with a particular TYPE and DATA.
 465                           Record types are defined using `defzoneparse' and
 466                           the syntax of the data is idiosyncratic.
 467
 468    ((LABEL ...) . REC)  Define records for labels within the zone.  Any
 469                           records defined within REC will have their domains
 470                           prefixed by each of the LABELs.  A singleton list
 471                           of labels may instead be written as a single
 472                           label.  Note, therefore, that
 473
 474                                 (host (sub :a \"169.254.1.1\"))
 475
 476                           defines a record for `host.sub' -- not `sub.host'.
 477
 478    If REC contains no top-level records, but it does define records for a
 479    label listed in `*preferred-subnets*', then the records for the first such
 480    label are also promoted to top-level.
 481
 482    The FUNC is called for each record encountered, represented as a
 483    `zone-record' object.  Zone parsers are not called: you get the record
 484    types and data from the input form; see `zone-parse-records' if you want
 485    the raw output."
 486
 487   (labels ((sift (rec ttl)
 488              ;; Parse the record list REC into lists of `zone-record' and
 489              ;; `zone-subdomain' objects, sorting out TTLs and so on.
 490              ;; Returns them as two values.
 491
 492              (collecting (top sub)
 493                (loop
 494                  (unless rec
 495                    (return))
 496                  (let ((r (pop rec)))
 497                    (cond ((eq r :ttl)
 498                           (setf ttl (pop rec)))
 499                          ((symbolp r)
 500                           (collect (make-zone-record :type r
 501                                                      :ttl ttl
 502                                                      :data (pop rec))
 503                                    top))
 504                          ((listp r)
 505                           (dolist (name (listify (car r)))
 506                             (collect (make-zone-subdomain
 507                                       :name (zone-parse-host name)
 508                                       :ttl ttl :records (cdr r))
 509                                      sub)))
 510                          (t
 511                           (error "Unexpected record form ~A" r)))))))
 512
 513            (process (rec dom ttl)
 514              ;; Recursirvely process the record list REC, with a list DOM of
 515              ;; prefix labels, and a default TTL.  Promote records for a
 516              ;; preferred subnet to toplevel if there are no toplevel records
 517              ;; already.
 518
 519              (multiple-value-bind (top sub) (sift rec ttl)
 520                (if (and dom (null top) sub)
 521                    (let ((preferred
 522                           (or (find-if
 523                                (lambda (s)
 524                                  (let ((ll (domain-name-labels (zs-name s))))
 525                                    (and (consp ll) (null (cdr ll))
 526                                         (zone-preferred-subnet-p (car ll)))))
 527                                sub)
 528                               (car sub))))
 529                      (when preferred
 530                        (process (zs-records preferred)
 531                                 dom
 532                                 (zs-ttl preferred))))
 533                    (let ((name dom))
 534                      (dolist (zr top)
 535                        (setf (zr-name zr) name)
 536                        (funcall func zr))))
 537                (dolist (s sub)
 538                  (process (zs-records s)
 539                           (if (null dom) (zs-name s)
 540                               (domain-name-concat dom (zs-name s)))
 541                           (zs-ttl s))))))
 542
 543     ;; Process the records we're given with no prefix.
 544     (process rec nil ttl)))
 545
 546 (defun zone-parse-head (head)
 547   "Parse the HEAD of a zone form.
 548
 549    This has the form
 550
 551      (NAME &key :source :admin :refresh :retry
 552                 :expire :min-ttl :ttl :serial)
 553
 554    though a singleton NAME needn't be a list.  Returns the default TTL and an
 555    soa structure representing the zone head."
 556   (destructuring-bind
 557       (raw-zname
 558        &key
 559        (source *default-zone-source*)
 560        (admin (or *default-zone-admin*
 561                   (format nil "hostmaster@~A" raw-zname)))
 562        (refresh *default-zone-refresh*)
 563        (retry *default-zone-retry*)
 564        (expire *default-zone-expire*)
 565        (min-ttl *default-zone-min-ttl*)
 566        (ttl *default-zone-ttl*)
 567        (serial (make-zone-serial raw-zname))
 568        &aux
 569        (zname (zone-parse-host raw-zname root-domain)))
 570       (listify head)
 571     (values zname
 572             (timespec-seconds ttl)
 573             (make-soa :admin admin
 574                       :source (zone-parse-host source zname)
 575                       :refresh (timespec-seconds refresh)
 576                       :retry (timespec-seconds retry)
 577                       :expire (timespec-seconds expire)
 578                       :min-ttl (timespec-seconds min-ttl)
 579                       :serial serial))))
 580
 581 (export 'defzoneparse)
 582 (defmacro defzoneparse (types (name data list
 583                                &key (prefix (gensym "PREFIX"))
 584                                     (zname (gensym "ZNAME"))
 585                                     (ttl (gensym "TTL")))
 586                         &body body)
 587   "Define a new zone record type.
 588
 589    The arguments are as follows:
 590
 591    TYPES        A singleton type symbol, or a list of aliases.
 592
 593    NAME         The name of the record to be added.
 594
 595    DATA         The content of the record to be added (a single object,
 596                 unevaluated).
 597
 598    LIST         A function to add a record to the zone.  See below.
 599
 600    PREFIX       The prefix tag used in the original form.
 601
 602    ZNAME        The name of the zone being constructed.
 603
 604    TTL          The TTL for this record.
 605
 606    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 607    optional: you don't have to accept them if you're not interested.
 608
 609    The LIST argument names a function to be bound in the body to add a new
 610    low-level record to the zone.  It has the prototype
 611
 612      (LIST &key :name :type :data :ttl :make-ptr-p)
 613
 614    These (except MAKE-PTR-P, which defaults to nil) default to the above
 615    arguments (even if you didn't accept the arguments)."
 616
 617   (setf types (listify types))
 618   (let* ((type (car types))
 619          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 620     (with-parsed-body (body decls doc) body
 621       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 622         `(progn
 623            (dolist (,i ',types)
 624              (setf (get ,i 'zone-parse) ',func))
 625            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 626              ,@doc
 627              ,@decls
 628              (let ((,name (if (null ,prefix) ,zname
 629                               (domain-name-concat ,prefix ,zname))))
 630                (flet ((,list (&key ((:name ,tname) ,name)
 631                                    ((:type ,ttype) ,type)
 632                                    ((:data ,tdata) ,data)
 633                                    ((:ttl ,tttl) ,ttl)
 634                                    ((:make-ptr-p ,tmakeptrp) nil))
 635                         #+cmu (declare (optimize ext:inhibit-warnings))
 636                         (collect (make-zone-record :name ,tname
 637                                                    :type ,ttype
 638                                                    :data ,tdata
 639                                                    :ttl ,tttl
 640                                                    :make-ptr-p ,tmakeptrp)
 641                                  ,col)))
 642                  ,@body)))
 643            ',type)))))
 644
 645 (export 'zone-parse-records)
 646 (defun zone-parse-records (zname ttl records)
 647   "Parse a sequence of RECORDS and return a list of raw records.
 648
 649    The records are parsed relative to the zone name ZNAME, and using the
 650    given default TTL."
 651   (collecting (rec)
 652     (flet ((parse-record (zr)
 653              (let ((func (or (get (zr-type zr) 'zone-parse)
 654                              (error "No parser for record ~A."
 655                                     (zr-type zr))))
 656                    (name (and (zr-name zr) (zr-name zr))))
 657                (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
 658       (zone-process-records records ttl #'parse-record))))
 659
 660 (export 'zone-parse)
 661 (defun zone-parse (zf)
 662   "Parse a ZONE form.
 663
 664    The syntax of a zone form is as follows:
 665
 666    ZONE-FORM:
 667      ZONE-HEAD ZONE-RECORD*
 668
 669    ZONE-RECORD:
 670      ((NAME*) ZONE-RECORD*)
 671    | SYM ARGS"
 672   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 673     (make-zone :name zname
 674                :default-ttl ttl
 675                :soa soa
 676                :records (zone-parse-records zname ttl (cdr zf)))))
 677
 678 (export 'zone-create)
 679 (defun zone-create (zf)
 680   "Zone construction function.
 681
 682    Given a zone form ZF, construct the zone and add it to the table."
 683   (let* ((zone (zone-parse zf))
 684          (name (zone-text-name zone)))
 685     (setf (zone-find name) zone)
 686     name))
 687
 688 (export 'defzone)
 689 (defmacro defzone (soa &body zf)
 690   "Zone definition macro."
 691   `(zone-create '(,soa ,@zf)))
 692
 693 (export '*address-family*)
 694 (defvar *address-family* t
 695   "The default address family.  This is bound by `defrevzone'.")
 696
 697 (export 'defrevzone)
 698 (defmacro defrevzone (head &body zf)
 699   "Define a reverse zone, with the correct name."
 700   (destructuring-bind (nets &rest args
 701                             &key (family '*address-family*)
 702                                  prefix-bits
 703                                  &allow-other-keys)
 704       (listify head)
 705     (with-gensyms (ipn)
 706       `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
 707          (let ((*address-family* (ipnet-family ,ipn)))
 708            (zone-create `((,(format nil "~A" (reverse-domain ,ipn
 709                                                              ,prefix-bits))
 710                             ,@',(loop for (k v) on args by #'cddr
 711                                       unless (member k
 712                                                      '(:family :prefix-bits))
 713                                       nconc (list k v)))
 714                           ,@',zf)))))))
 715
 716 (export 'map-host-addresses)
 717 (defun map-host-addresses (func addr &key (family *address-family*))
 718   "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
 719
 720   (dolist (a (host-addrs (host-parse addr family)))
 721     (funcall func a)))
 722
 723 (export 'do-host)
 724 (defmacro do-host ((addr spec &key (family *address-family*)) &body body)
 725   "Evaluate BODY, binding ADDR to each address denoted by SPEC."
 726   `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
 727      ,@body))
 728
 729 (export 'zone-set-address)
 730 (defun zone-set-address (rec addrspec &rest args
 731                          &key (family *address-family*) name ttl make-ptr-p)
 732   "Write records (using REC) defining addresses for ADDRSPEC."
 733   (declare (ignore name ttl make-ptr-p))
 734   (let ((key-args (loop for (k v) on args by #'cddr
 735                         unless (eq k :family)
 736                         nconc (list k v))))
 737     (do-host (addr addrspec :family family)
 738       (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
 739
 740 ;;;--------------------------------------------------------------------------
 741 ;;; Building raw record vectors.
 742
 743 (defvar *record-vector* nil
 744   "The record vector under construction.")
 745
 746 (defun rec-ensure (n)
 747   "Ensure that at least N octets are spare in the current record."
 748   (let ((want (+ n (fill-pointer *record-vector*)))
 749         (have (array-dimension *record-vector* 0)))
 750     (unless (<= want have)
 751       (adjust-array *record-vector*
 752                     (do ((new (* 2 have) (* 2 new)))
 753                         ((<= want new) new))))))
 754
 755 (export 'rec-octet-vector)
 756 (defun rec-octet-vector (vector &key (start 0) end)
 757   "Copy (part of) the VECTOR to the output."
 758   (let* ((end (or end (length vector)))
 759          (len (- end start)))
 760     (rec-ensure len)
 761     (do ((i start (1+ i)))
 762         ((>= i end))
 763       (vector-push (aref vector i) *record-vector*))))
 764
 765 (export 'rec-byte)
 766 (defun rec-byte (octets value)
 767   "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
 768   (rec-ensure octets)
 769   (do ((i (1- octets) (1- i)))
 770       ((minusp i))
 771     (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))
 772
 773 (export 'rec-u8)
 774 (defun rec-u8 (value)
 775   "Append an 8-bit VALUE to the current record."
 776   (rec-byte 1 value))
 777
 778 (export 'rec-u16)
 779 (defun rec-u16 (value)
 780   "Append a 16-bit VALUE to the current record."
 781   (rec-byte 2 value))
 782
 783 (export 'rec-u32)
 784 (defun rec-u32 (value)
 785   "Append a 32-bit VALUE to the current record."
 786   (rec-byte 4 value))
 787
 788 (export 'rec-raw-string)
 789 (defun rec-raw-string (s &key (start 0) end)
 790   "Append (a substring of) a raw string S to the current record.
 791
 792    No arrangement is made for reporting the length of the string.  That must
 793    be done by the caller, if necessary."
 794   (setf-default end (length s))
 795   (rec-ensure (- end start))
 796   (do ((i start (1+ i)))
 797       ((>= i end))
 798     (vector-push (char-code (char s i)) *record-vector*)))
 799
 800 (export 'rec-string)
 801 (defun rec-string (s &key (start 0) end (max 255))
 802   (let* ((end (or end (length s)))
 803          (len (- end start)))
 804     (unless (<= len max)
 805       (error "String `~A' too long" (subseq s start end)))
 806     (rec-u8 (- end start))
 807     (rec-raw-string s :start start :end end)))
 808
 809 (export 'rec-name)
 810 (defun rec-name (name)
 811   "Append a domain NAME.
 812
 813    No attempt is made to perform compression of the name."
 814   (dolist (label (reverse (domain-name-labels name)))
 815     (rec-string label :max 63))
 816   (rec-u8 0))
 817
 818 (export 'build-record)
 819 (defmacro build-record (&body body)
 820   "Build a raw record, and return it as a vector of octets."
 821   `(let ((*record-vector* (make-array 256
 822                                       :element-type '(unsigned-byte 8)
 823                                       :fill-pointer 0
 824                                       :adjustable t)))
 825      ,@body
 826      (copy-seq *record-vector*)))
 827
 828 (export 'zone-record-rrdata)
 829 (defgeneric zone-record-rrdata (type zr)
 830   (:documentation "Emit (using the `build-record' protocol) RRDATA for ZR.
 831
 832    The TYPE is a keyword naming the record type.  Return the numeric RRTYPE
 833    code."))
 834
 835 ;;;--------------------------------------------------------------------------
 836 ;;; Zone record parsers.
 837
 838 (defzoneparse :a (name data rec)
 839   ":a IPADDR"
 840   (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
 841
 842 (defmethod zone-record-rrdata ((type (eql :a)) zr)
 843   (rec-u32 (ipaddr-addr (zr-data zr)))
 844   1)
 845
 846 (defzoneparse :aaaa (name data rec)
 847   ":aaaa IPADDR"
 848   (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
 849
 850 (defmethod zone-record-rrdata ((type (eql :aaaa)) zr)
 851   (rec-byte 16 (ipaddr-addr (zr-data zr)))
 852   28)
 853
 854 (defzoneparse :addr (name data rec)
 855   ":addr IPADDR"
 856   (zone-set-address #'rec data :make-ptr-p t))
 857
 858 (defzoneparse :svc (name data rec)
 859   ":svc IPADDR"
 860   (zone-set-address #'rec data))
 861
 862 (defzoneparse :ptr (name data rec :zname zname)
 863   ":ptr HOST"
 864   (rec :data (zone-parse-host data zname)))
 865
 866 (defmethod zone-record-rrdata ((type (eql :ptr)) zr)
 867   (rec-name (zr-data zr))
 868   12)
 869
 870 (defzoneparse :cname (name data rec :zname zname)
 871   ":cname HOST"
 872   (rec :data (zone-parse-host data zname)))
 873
 874 (defzoneparse :dname (name data rec :zname zname)
 875   ":dname HOST"
 876   (rec :data (zone-parse-host data zname)))
 877
 878 (defmethod zone-record-rrdata ((type (eql :cname)) zr)
 879   (rec-name (zr-data zr))
 880   5)
 881
 882 (defun split-txt-data (data)
 883   "Split the string DATA into pieces small enough to fit in a TXT record.
 884
 885    Return a list of strings L such that (a) (apply #'concatenate 'string L)
 886    is equal to the original string DATA, and (b) (every (lambda (s) (<=
 887    (length s) 255)) L) is true."
 888   (collecting ()
 889     (let ((i 0) (n (length data)))
 890       (loop
 891         (let ((end (+ i 255)))
 892           (when (<= n end) (return))
 893           (let ((split (acond ((position #\; data :from-end t
 894                                          :start i :end end)
 895                                (+ it 1))
 896                               ((position #\space data :from-end t
 897                                          :start i :end end)
 898                                (+ it 1))
 899                               (t end))))
 900             (loop
 901               (when (or (>= split end)
 902                         (char/= (char data split) #\space))
 903                 (return))
 904               (incf split))
 905             (collect (subseq data i split))
 906             (setf i split))))
 907       (collect (subseq data i)))))
 908
 909 (defzoneparse :txt (name data rec)
 910   ":txt (TEXT*)"
 911   (rec :data (cond ((stringp data) (split-txt-data data))
 912                    (t
 913                     (dolist (piece data)
 914                       (unless (<= (length piece) 255)
 915                         (error "`:txt' record piece `~A' too long" piece)))
 916                     data))))
 917
 918 (defmethod zone-record-rrdata ((type (eql :txt)) zr)
 919   (mapc #'rec-string (zr-data zr))
 920   16)
 921
 922 (defzoneparse :spf (name data rec :zname zname)
 923   ":spf ([[ (:version STRING) |
 924             ({:pass | :fail | :soft | :shrug}
 925              {:all |
 926               :include LABEL |
 927               :a [[ :label LABEL | :v4mask MASK | :v6mask MASK ]] |
 928               :ptr [LABEL] |
 929               {:ip | :ip4 | :ip6} {STRING | NET | HOST}}) |
 930             (:redirect LABEL) |
 931             (:exp LABEL) ]])"
 932   (rec :type :txt
 933        :data
 934        (split-txt-data
 935         (with-output-to-string (out)
 936           (let ((firstp t))
 937             (dolist (item data)
 938               (if firstp (setf firstp nil)
 939                   (write-char #\space out))
 940               (let ((head (car item))
 941                     (tail (cdr item)))
 942               (ecase head
 943                 (:version (destructuring-bind (ver) tail
 944                             (format out "v=~A" ver)))
 945                 ((:pass :fail :soft :shrug)
 946                  (let ((qual (ecase head
 947                                (:pass #\+)
 948                                (:fail #\-)
 949                                (:soft #\~)
 950                                (:shrug #\?))))
 951                    (setf head (pop tail))
 952                    (ecase head
 953                      (:all
 954                       (destructuring-bind () tail
 955                         (format out "~Aall" qual)))
 956                      ((:include :exists)
 957                       (destructuring-bind (label) tail
 958                         (format out "~A~(~A~):~A"
 959                                 qual head
 960                                 (if (stringp label) label
 961                                     (zone-parse-host label zname)))))
 962                      ((:a :mx)
 963                       (destructuring-bind (&key label v4mask v6mask) tail
 964                         (format out "~A~(~A~)~@[:~A~]~@[/~D~]~@[//~D~]"
 965                                 qual head
 966                                 (cond ((null label) nil)
 967                                       ((stringp label) label)
 968                                       (t (zone-parse-host label zname)))
 969                                 v4mask
 970                                 v6mask)))
 971                      (:ptr
 972                       (destructuring-bind (&optional label) tail
 973                         (format out "~Aptr~@[:~A~]"
 974                                 qual
 975                                 (cond ((null label) nil)
 976                                       ((stringp label) label)
 977                                       (t (zone-parse-host label zname))))))
 978                      ((:ip :ip4 :ip6)
 979                       (let* ((family (ecase head
 980                                        (:ip t)
 981                                        (:ip4 :ipv4)
 982                                        (:ip6 :ipv6)))
 983                              (nets
 984                               (collecting ()
 985                                 (dolist (net tail)
 986                                   (acond
 987                                     ((host-find net)
 988                                      (let ((any nil))
 989                                        (dolist (addr (host-addrs it))
 990                                          (when (or (eq family t)
 991                                                    (eq family
 992                                                        (ipaddr-family addr)))
 993                                            (setf any t)
 994                                            (collect (make-ipnet
 995                                                      addr
 996                                                      (ipaddr-width addr)))))
 997                                        (unless any
 998                                          (error
 999                                           "No matching addresses for `~A'"
1000                                           net))))
1001                                     (t
1002                                      (collect-append
1003                                       (net-parse-to-ipnets net family))))))))
1004                         (setf firstp t)
1005                         (dolist (net nets)
1006                           (if firstp (setf firstp nil)
1007                               (write-char #\space out))
1008                           (let* ((width (ipnet-width net))
1009                                  (mask (ipnet-mask net))
1010                                  (plen (ipmask-cidl-slash width mask)))
1011                             (unless plen
1012                               (error "invalid netmask in network ~A" net))
1013                             (format out "~A~A:~A~@[/~D~]"
1014                                     qual
1015                                     (ecase (ipnet-family net)
1016                                       (:ipv4 "ip4")
1017                                       (:ipv6 "ip6"))
1018                                     (ipnet-net net)
1019                                     (and (/= plen width) plen)))))))))
1020                 ((:redirect :exp)
1021                  (destructuring-bind (label) tail
1022                    (format out "~(~A~)=~A"
1023                            head
1024                            (if (stringp label) label
1025                                (zone-parse-host label zname)))))))))))))
1026
1027
1028 (export '*dkim-pathname-defaults*)
1029 (defvar *dkim-pathname-defaults*
1030   (make-pathname :directory '(:relative "keys")
1031                  :type "dkim"))
1032 (pushnew '*dkim-pathname-defaults* *zone-config*)
1033
1034 (defzoneparse :dkim (name data rec)
1035   ":dkim (KEYFILE {:TAG VALUE}*)"
1036   (destructuring-bind (file &rest plist) (listify data)
1037     (rec :type :txt
1038          :data
1039          (split-txt-data
1040           (with-output-to-string (out)
1041             (format out "~{~(~A~)=~A; ~}" plist)
1042             (write-string "p=" out)
1043             (when file
1044               (with-open-file
1045                   (in (merge-pathnames file *dkim-pathname-defaults*))
1046                 (loop
1047                   (when (string= (read-line in)
1048                                  "-----BEGIN PUBLIC KEY-----")
1049                     (return)))
1050                 (loop
1051                   (let ((line (read-line in)))
1052                     (when (string= line "-----END PUBLIC KEY-----")
1053                       (return))
1054                     (write-string line out))))))))))
1055
1056 (defzoneparse :dmarc (name data rec)
1057   ":dmarc ({:TAG VALUE}*)"
1058   (rec :type :txt
1059        :data (split-txt-data (format nil "~{~(~A~)=~A~^; ~}" data))))
1060
1061 (defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3) (:ed25519 4))
1062 (defenum sshfp-type () (:sha-1 1) (:sha-256 2))
1063
1064 (export '*sshfp-pathname-defaults*)
1065 (defvar *sshfp-pathname-defaults*
1066   (make-pathname :directory '(:relative "keys") :type "sshfp")
1067   "Default pathname components for SSHFP records.")
1068 (pushnew '*sshfp-pathname-defaults* *zone-config*)
1069
1070 (defzoneparse :sshfp (name data rec)
1071   ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
1072   (typecase data
1073     ((or string pathname)
1074      (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
1075        (loop (let ((line (read-line in nil)))
1076                (unless line (return))
1077                (let ((words (str-split-words line)))
1078                  (pop words)
1079                  (when (string= (car words) "IN") (pop words))
1080                  (unless (and (string= (car words) "SSHFP")
1081                               (= (length words) 4))
1082                    (error "Invalid SSHFP record."))
1083                  (pop words)
1084                  (destructuring-bind (alg type fprhex) words
1085                    (rec :data (list (parse-integer alg)
1086                                     (parse-integer type)
1087                                     (decode-hex fprhex)))))))))
1088     (t
1089      (dolist (item (listify data))
1090        (destructuring-bind (fprhex &key (alg 'rsa) (type 'sha-1))
1091            (listify item)
1092          (rec :data (list (lookup-enum alg 'sshfp-algorithm :min 0 :max 255)
1093                           (lookup-enum type 'sshfp-type :min 0 :max 255)
1094                           (decode-hex fprhex))))))))
1095
1096 (defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
1097   (destructuring-bind (alg type fpr) (zr-data zr)
1098     (rec-u8 alg)
1099     (rec-u8 type)
1100     (rec-octet-vector fpr))
1101   44)
1102
1103 (defenum tlsa-usage ()
1104   (:ca-constraint 0)
1105   (:service-certificate-constraint 1)
1106   (:trust-anchor-assertion 2)
1107   (:domain-issued-certificate 3))
1108
1109 (defenum tlsa-selector ()
1110   (:certificate 0)
1111   (:public-key 1))
1112
1113 (defenum tlsa-match ()
1114   (:exact 0)
1115   (:sha-256 1)
1116   (:sha-512 2))
1117
1118 (defparameter tlsa-pem-alist
1119   `(("CERTIFICATE" . ,tlsa-selector/certificate)
1120     ("PUBLIC-KEY" . ,tlsa-selector/public-key)))
1121
1122 (defgeneric raw-tlsa-assoc-data (have want file context)
1123   (:documentation
1124    "Convert FILE, and strip off PEM encoding.
1125
1126    The FILE contains PEM-encoded data of type HAVE -- one of the
1127    `tlsa-selector' codes.  Return the name of a file containing binary
1128    DER-encoded data of type WANT instead.  The CONTEXT is a temporary-files
1129    context.")
1130
1131   (:method (have want file context)
1132     (declare (ignore context))
1133     (error "Can't convert `~A' from selector type ~S to type ~S" file
1134            (reverse-enum 'tlsa-selector have)
1135            (reverse-enum 'tlsa-selector want)))
1136
1137   (:method ((have (eql tlsa-selector/certificate))
1138             (want (eql tlsa-selector/certificate))
1139             file context)
1140     (let ((temp (temporary-file context "cert")))
1141       (run-program (list "openssl" "x509" "-outform" "der")
1142                    :input file :output temp)
1143       temp))
1144
1145   (:method ((have (eql tlsa-selector/public-key))
1146             (want (eql tlsa-selector/public-key))
1147             file context)
1148     (let ((temp (temporary-file context "pubkey-der")))
1149       (run-program (list "openssl" "pkey" "-pubin" "-outform" "der")
1150                    :input file :output temp)
1151       temp))
1152
1153   (:method ((have (eql tlsa-selector/certificate))
1154             (want (eql tlsa-selector/public-key))
1155             file context)
1156     (let ((temp (temporary-file context "pubkey")))
1157       (run-program (list "openssl" "x509" "-noout" "-pubkey")
1158                    :input file :output temp)
1159       (raw-tlsa-assoc-data want want temp context))))
1160
1161 (defgeneric tlsa-match-data-valid-p (match data)
1162   (:documentation
1163    "Check whether the DATA (an octet vector) is valid for the MATCH type.")
1164
1165   (:method (match data)
1166     (declare (ignore match data))
1167     ;; We don't know: assume the user knows what they're doing.
1168     t)
1169
1170   (:method ((match (eql tlsa-match/sha-256)) data) (= (length data) 32))
1171   (:method ((match (eql tlsa-match/sha-512)) data) (= (length data) 64)))
1172
1173 (defgeneric read-tlsa-match-data (match file context)
1174   (:documentation
1175    "Read FILE, and return an octet vector for the correct MATCH type.
1176
1177    CONTEXT is a temporary-files context.")
1178   (:method ((match (eql tlsa-match/exact)) file context)
1179     (declare (ignore context))
1180     (slurp-file file 'octet))
1181   (:method ((match (eql tlsa-match/sha-256)) file context)
1182     (hash-file "sha256" file context))
1183   (:method ((match (eql tlsa-match/sha-512)) file context)
1184     (hash-file "sha512" file context)))
1185
1186 (defgeneric tlsa-selector-pem-boundary (selector)
1187   (:documentation
1188    "Return the PEM boundary string for objects of the SELECTOR type")
1189   (:method ((selector (eql tlsa-selector/certificate))) "CERTIFICATE")
1190   (:method ((selector (eql tlsa-selector/public-key))) "PUBLIC KEY")
1191   (:method (selector) (declare (ignore selector)) nil))
1192
1193 (defun identify-tlsa-selector-file (file)
1194   "Return the selector type for the data stored in a PEM-format FILE."
1195   (with-open-file (in file)
1196     (loop
1197       (let* ((line (read-line in nil))
1198              (len (length line)))
1199         (unless line
1200           (error "No PEM boundary in `~A'" file))
1201         (when (and (>= len 11)
1202                    (string= line "-----BEGIN " :end1 11)
1203                    (string= line "-----" :start1 (- len 5)))
1204           (mapenum (lambda (tag value)
1205                      (declare (ignore tag))
1206                      (when (string= line
1207                                     (tlsa-selector-pem-boundary value)
1208                                     :start1 11 :end1 (- len 5))
1209                        (return value)))
1210                    'tlsa-selector))))))
1211
1212 (export '*tlsa-pathname-defaults*)
1213 (defvar *tlsa-pathname-defaults*
1214   (list (make-pathname :directory '(:relative "certs") :type "cert")
1215         (make-pathname :directory '(:relative "keys") :type "pub"))
1216   "Default pathname components for TLSA records.")
1217 (pushnew '*tlsa-pathname-defaults* *zone-config*)
1218
1219 (defparameter *tlsa-data-cache* (make-hash-table :test #'equal)
1220   "Cache for TLSA association data; keys are (DATA SELECTOR MATCH).")
1221
1222 (defun convert-tlsa-selector-data (data selector match)
1223   "Convert certificate association DATA as required by SELECTOR and MATCH.
1224
1225    If DATA is a hex string, we assume that it's already in the appropriate
1226    form (but if MATCH specifies a hash then we check that it's the right
1227    length).  If DATA is a pathname, then it should name a PEM file: we
1228    identify the kind of object stored in the file from the PEM header, and
1229    convert as necessary.
1230
1231    The output is an octet vector containing the raw certificate association
1232    data to include in rrdata."
1233
1234   (etypecase data
1235     (string
1236      (let ((bin (decode-hex data)))
1237        (unless (tlsa-match-data-valid-p match bin)
1238          (error "Invalid data for match type ~S"
1239                 (reverse-enum 'tlsa-match match)))
1240        bin))
1241     (pathname
1242      (let ((key (list data selector match)))
1243        (or (gethash key *tlsa-data-cache*)
1244            (with-temporary-files (context :base (make-pathname :type "tmp"))
1245              (let* ((file (or (find-if #'probe-file
1246                                        (mapcar (lambda (template)
1247                                                  (merge-pathnames data
1248                                                                   template))
1249                                                *tlsa-pathname-defaults*))
1250                               (error "Couldn't find TLSA file `~A'" data)))
1251                     (kind (identify-tlsa-selector-file file))
1252                     (raw (raw-tlsa-assoc-data kind selector file context))
1253                     (binary (read-tlsa-match-data match raw context)))
1254                (setf (gethash key *tlsa-data-cache*) binary))))))))
1255
1256 (defzoneparse :tlsa (name data rec)
1257   ":tlsa (((SERVICE|PORT &key :protocol)*) (USAGE SELECTOR MATCH DATA)*)"
1258
1259   (destructuring-bind (services &rest certinfos) data
1260
1261     ;; First pass: build the raw-format TLSA record data.
1262     (let ((records nil))
1263       (dolist (certinfo certinfos)
1264         (destructuring-bind (usage-tag selector-tag match-tag data) certinfo
1265           (let* ((usage (lookup-enum 'tlsa-usage usage-tag :min 0 :max 255))
1266                  (selector (lookup-enum 'tlsa-selector selector-tag
1267                                         :min 0 :max 255))
1268                  (match (lookup-enum 'tlsa-match match-tag :min 0 :max 255))
1269                  (raw (convert-tlsa-selector-data data selector match)))
1270             (push (list usage selector match raw) records))))
1271       (setf records (nreverse records))
1272
1273       ;; Second pass: attach records for the requested services.
1274       (dolist (service (listify services))
1275         (destructuring-bind (svc &key (protocol :tcp)) (listify service)
1276           (let* ((port (etypecase svc
1277                          (integer svc)
1278                          (keyword (let ((serv (serv-by-name svc protocol)))
1279                                     (unless serv
1280                                       (error "Unknown service `~A'" svc))
1281                                     (serv-port serv)))))
1282                  (prefixed (domain-name-concat
1283                             (make-domain-name
1284                              :labels (list (format nil "_~(~A~)" protocol)
1285                                            (format nil "_~A" port)))
1286                             name)))
1287             (dolist (record records)
1288               (rec :name prefixed :data record))))))))
1289
1290 (defmethod zone-record-rrdata ((type (eql :tlsa)) zr)
1291   (destructuring-bind (usage selector match data) (zr-data zr)
1292     (rec-u8 usage)
1293     (rec-u8 selector)
1294     (rec-u8 match)
1295     (rec-octet-vector data))
1296   52)
1297
1298 (defenum dnssec-algorithm ()
1299   (:rsamd5 1)
1300   (:dh 2)
1301   (:dsa 3)
1302   (:rsasha1 5)
1303   (:dsa-nsec3-sha1 6)
1304   (:rsasha1-nsec3-sha1 7)
1305   (:rsasha256 8)
1306   (:rsasha512 10)
1307   (:ecc-gost 12)
1308   (:ecdsap256sha256 13)
1309   (:ecdsap384sha384 14))
1310
1311 (defenum dnssec-digest ()
1312   (:sha1 1)
1313   (:sha256 2))
1314
1315 (defzoneparse :ds (name data rec)
1316   ":ds ((TAG ALGORITHM DIGEST-TYPE DIGEST)*)"
1317   (dolist (ds data)
1318     (destructuring-bind (tag alg hashtype hash) ds
1319       (rec :data (list tag
1320                        (lookup-enum 'dnssec-algorithm alg :min 0 :max 255)
1321                        (lookup-enum 'dnssec-digest hashtype :min 0 :max 255)
1322                        (decode-hex hash))))))
1323
1324 (defmethod zone-record-rrdata ((type (eql :ds)) zr)
1325   (destructuring-bind (tag alg hashtype hash) zr
1326     (rec-u16 tag)
1327     (rec-u8 alg)
1328     (rec-u8 hashtype)
1329     (rec-octet-vector hash)))
1330
1331 (defzoneparse :mx (name data rec :zname zname)
1332   ":mx ((HOST :prio INT :ip IPADDR)*)"
1333   (dolist (mx (listify data))
1334     (destructuring-bind
1335         (mxname &key (prio *default-mx-priority*) ip)
1336         (listify mx)
1337       (let ((host (zone-parse-host mxname zname)))
1338         (when ip (zone-set-address #'rec ip :name host))
1339         (rec :data (cons host prio))))))
1340
1341 (defmethod zone-record-rrdata ((type (eql :mx)) zr)
1342   (let ((name (car (zr-data zr)))
1343         (prio (cdr (zr-data zr))))
1344     (rec-u16 prio)
1345     (rec-name name))
1346   15)
1347
1348 (defzoneparse :ns (name data rec :zname zname)
1349   ":ns ((HOST :ip IPADDR)*)"
1350   (dolist (ns (listify data))
1351     (destructuring-bind
1352         (nsname &key ip)
1353         (listify ns)
1354       (let ((host (zone-parse-host nsname zname)))
1355         (when ip (zone-set-address #'rec ip :name host))
1356         (rec :data host)))))
1357
1358 (defmethod zone-record-rrdata ((type (eql :ns)) zr)
1359   (rec-name (zr-data zr))
1360   2)
1361
1362 (defzoneparse :alias (name data rec :zname zname)
1363   ":alias (LABEL*)"
1364   (dolist (a (listify data))
1365     (rec :name (zone-parse-host a zname)
1366          :type :cname
1367          :data name)))
1368
1369 (defzoneparse :srv (name data rec :zname zname)
1370   ":srv (((SERVICE &key :port :protocol)
1371           (PROVIDER &key :port :prio :weight :ip)*)*)"
1372   (dolist (srv data)
1373     (destructuring-bind (servopts &rest providers) srv
1374       (destructuring-bind
1375           (service &key ((:port default-port)) (protocol :tcp))
1376           (listify servopts)
1377         (unless default-port
1378           (let ((serv (serv-by-name service protocol)))
1379             (setf default-port (and serv (serv-port serv)))))
1380         (let ((rname (flet ((prepend (tag tail)
1381                               (domain-name-concat
1382                                (make-domain-name
1383                                 :labels (list (format nil "_~(~A~)" tag)))
1384                                tail)))
1385                        (prepend service (prepend protocol name)))))
1386           (dolist (prov providers)
1387             (destructuring-bind
1388                 (srvname
1389                  &key
1390                  (port default-port)
1391                  (prio *default-mx-priority*)
1392                  (weight 0)
1393                  ip)
1394                 (listify prov)
1395               (let ((host (zone-parse-host srvname zname)))
1396                 (when ip (zone-set-address #'rec ip :name host))
1397                 (rec :name rname
1398                      :data (list prio weight port host))))))))))
1399
1400 (defmethod zone-record-rrdata ((type (eql :srv)) zr)
1401   (destructuring-bind (prio weight port host) (zr-data zr)
1402     (rec-u16 prio)
1403     (rec-u16 weight)
1404     (rec-u16 port)
1405     (rec-name host))
1406   33)
1407
1408 (defenum caa-flag () (:critical 128))
1409
1410 (defzoneparse :caa (name data rec)
1411   ":caa ((TAG VALUE FLAG*)*)"
1412   (dolist (prop data)
1413     (destructuring-bind (tag value &rest flags) prop
1414       (setf flags (reduce #'logior
1415                           (mapcar (lambda (item)
1416                                     (lookup-enum 'caa-flag item
1417                                                  :min 0 :max 255))
1418                                   flags)))
1419       (ecase tag
1420         ((:issue :issuewild :iodef)
1421          (rec :name name
1422               :data (list flags tag value)))))))
1423
1424 (defmethod zone-record-rrdata ((type (eql :caa)) zr)
1425   (destructuring-bind (flags tag value) (zr-data zr)
1426     (rec-u8 flags)
1427     (rec-string (string-downcase tag))
1428     (rec-raw-string value))
1429   257)
1430
1431 (defzoneparse :net (name data rec)
1432   ":net (NETWORK*)"
1433   (dolist (net (listify data))
1434     (dolist (ipn (net-ipnets (net-must-find net)))
1435       (let* ((base (ipnet-net ipn))
1436              (rrtype (ipaddr-rrtype base)))
1437         (flet ((frob (kind addr)
1438                  (when addr
1439                    (rec :name (zone-parse-host kind name)
1440                         :type rrtype
1441                         :data addr))))
1442           (frob "net" base)
1443           (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
1444           (frob "bcast" (ipnet-broadcast ipn)))))))
1445
1446 (defzoneparse (:rev :reverse) (name data rec)
1447   ":reverse ((NET &key :prefix-bits :family) ZONE*)
1448
1449    Add a reverse record each host in the ZONEs (or all zones) that lies
1450    within NET."
1451   (setf data (listify data))
1452   (destructuring-bind (net &key prefix-bits (family *address-family*))
1453       (listify (car data))
1454
1455     (dolist (ipn (net-parse-to-ipnets net family))
1456       (let* ((seen (make-hash-table :test #'equal))
1457              (width (ipnet-width ipn))
1458              (frag-len (if prefix-bits (- width prefix-bits)
1459                            (ipnet-changeable-bits width (ipnet-mask ipn)))))
1460         (dolist (z (or (cdr data) (hash-table-keys *zones*)))
1461           (dolist (zr (zone-records (zone-find z)))
1462             (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
1463                        (zr-make-ptr-p zr)
1464                        (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
1465               (let* ((frag (reverse-domain-fragment (zr-data zr)
1466                                                     0 frag-len))
1467                      (name (domain-name-concat frag name))
1468                      (name-string (princ-to-string name)))
1469                 (unless (gethash name-string seen)
1470                   (rec :name name :type :ptr
1471                        :ttl (zr-ttl zr) :data (zr-name zr))
1472                   (setf (gethash name-string seen) t))))))))))
1473
1474 (defzoneparse :multi (name data rec :zname zname :ttl ttl)
1475   ":multi (((NET*) &key :start :end :family :suffix) . REC)
1476
1477    Output multiple records covering a portion of the reverse-resolution
1478    namespace corresponding to the particular NETs.  The START and END bounds
1479    default to the most significant variable component of the
1480    reverse-resolution domain.
1481
1482    The REC tail is a sequence of record forms (as handled by
1483    `zone-process-records') to be emitted for each covered address.  Within
1484    the bodies of these forms, the symbol `*' will be replaced by the
1485    domain-name fragment corresponding to the current host, optionally
1486    followed by the SUFFIX.
1487
1488    Examples:
1489
1490         (:multi ((delegated-subnet :start 8)
1491                  :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
1492
1493         (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
1494                  :cname *))
1495
1496    Obviously, nested `:multi' records won't work well."
1497
1498   (destructuring-bind (nets
1499                        &key start end ((:suffix raw-suffix))
1500                        (family *address-family*))
1501       (listify (car data))
1502     (let ((suffix (if (not raw-suffix)
1503                       (make-domain-name :labels nil :absolutep nil)
1504                       (zone-parse-host raw-suffix))))
1505       (dolist (net (listify nets))
1506         (dolist (ipn (net-parse-to-ipnets net family))
1507           (let* ((addr (ipnet-net ipn))
1508                  (width (ipaddr-width addr))
1509                  (comp-width (reverse-domain-component-width addr))
1510                  (end (round-up (or end
1511                                     (ipnet-changeable-bits width
1512                                                            (ipnet-mask ipn)))
1513                                 comp-width))
1514                  (start (round-down (or start (- end comp-width))
1515                                     comp-width))
1516                  (map (ipnet-host-map ipn)))
1517             (multiple-value-bind (host-step host-limit)
1518                 (ipnet-index-bounds map start end)
1519               (do ((index 0 (+ index host-step)))
1520                   ((> index host-limit))
1521                 (let* ((addr (ipnet-index-host map index))
1522                        (frag (reverse-domain-fragment addr start end))
1523                        (target (reduce #'domain-name-concat
1524                                        (list frag suffix zname)
1525                                        :from-end t
1526                                        :initial-value root-domain)))
1527                   (dolist (zr (zone-parse-records (domain-name-concat frag
1528                                                                       zname)
1529                                                   ttl
1530                                                   (subst target '*
1531                                                          (cdr data))))
1532                     (rec :name (zr-name zr)
1533                          :type (zr-type zr)
1534                          :data (zr-data zr)
1535                          :ttl (zr-ttl zr)
1536                          :make-ptr-p (zr-make-ptr-p zr))))))))))))
1537
1538 ;;;--------------------------------------------------------------------------
1539 ;;; Zone file output.
1540
1541 (export 'zone-write)
1542 (defgeneric zone-write (format zone stream)
1543   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
1544
1545 (defvar *writing-zone* nil
1546   "The zone currently being written.")
1547
1548 (defvar *zone-output-stream* nil
1549   "Stream to write zone data on.")
1550
1551 (export 'zone-write-raw-rrdata)
1552 (defgeneric zone-write-raw-rrdata (format zr type data)
1553   (:documentation "Write an otherwise unsupported record in a given FORMAT.
1554
1555    ZR gives the record object, which carries the name and TTL; the TYPE is
1556    the numeric RRTYPE code; and DATA is an octet vector giving the RRDATA.
1557    This is used by the default `zone-write-record' method to handle record
1558    types which aren't directly supported by the format driver."))
1559
1560 (export 'zone-write-header)
1561 (defgeneric zone-write-header (format zone)
1562   (:documentation "Emit the header for a ZONE, in a given FORMAT.
1563
1564    The header includes any kind of initial comment, the SOA record, and any
1565    other necessary preamble.  There is no default implementation.
1566
1567    This is part of the protocol used by the default method on `zone-write';
1568    if you override that method."))
1569
1570 (export 'zone-write-trailer)
1571 (defgeneric zone-write-trailer (format zone)
1572   (:documentation "Emit the header for a ZONE, in a given FORMAT.
1573
1574    The footer may be empty, and is so by default.
1575
1576    This is part of the protocol used by the default method on `zone-write';
1577    if you override that method.")
1578   (:method (format zone)
1579     (declare (ignore format zone))
1580     nil))
1581
1582 (export 'zone-write-record)
1583 (defgeneric zone-write-record (format type zr)
1584   (:documentation "Emit a record of the given TYPE (a keyword).
1585
1586    The default implementation builds the raw RRDATA and passes it to
1587    `zone-write-raw-rrdata'.")
1588   (:method (format type zr)
1589     (let* (code
1590            (data (build-record (setf code (zone-record-rrdata type zr)))))
1591       (zone-write-raw-rrdata format zr code data))))
1592
1593 (defmethod zone-write (format zone stream)
1594   "This default method calls `zone-write-header', then `zone-write-record'
1595    for each record in the zone, and finally `zone-write-trailer'.  While it's
1596    running, `*writing-zone*' is bound to the zone object, and
1597   `*zone-output-stream*' to the output stream."
1598   (let ((*writing-zone* zone)
1599         (*zone-output-stream* stream))
1600     (zone-write-header format zone)
1601     (dolist (zr (zone-records-sorted zone))
1602       (zone-write-record format (zr-type zr) zr))
1603     (zone-write-trailer format zone)))
1604
1605 (export 'zone-save)
1606 (defun zone-save (zones &key (format :bind))
1607   "Write the named ZONES to files.  If no zones are given, write all the
1608    zones."
1609   (unless zones
1610     (setf zones (hash-table-keys *zones*)))
1611   (safely (safe)
1612     (dolist (z zones)
1613       (let ((zz (zone-find z)))
1614         (unless zz
1615           (error "Unknown zone `~A'." z))
1616         (let ((stream (safely-open-output-stream safe
1617                                                  (zone-file-name z :zone))))
1618           (zone-write format zz stream)
1619           (close stream))))))
1620
1621 ;;;--------------------------------------------------------------------------
1622 ;;; Bind format output.
1623
1624 (defvar *bind-last-record-name* nil
1625   "The previously emitted record name.
1626
1627    Used for eliding record names on output.")
1628
1629 (export 'bind-hostname)
1630 (defun bind-hostname (hostname)
1631   (let ((zone (domain-name-labels (zone-name *writing-zone*)))
1632         (name (domain-name-labels hostname)))
1633     (loop
1634       (unless (and zone name (string= (car zone) (car name)))
1635         (return))
1636       (pop zone) (pop name))
1637     (flet ((stitch (labels absolutep)
1638              (format nil "~{~A~^.~}~@[.~]"
1639                      (reverse (mapcar #'quotify-label labels))
1640                      absolutep)))
1641       (cond (zone (stitch (domain-name-labels hostname) t))
1642             (name (stitch name nil))
1643             (t "@")))))
1644
1645 (export 'bind-output-hostname)
1646 (defun bind-output-hostname (hostname)
1647   (let ((name (bind-hostname hostname)))
1648     (cond ((and *bind-last-record-name*
1649                 (string= name *bind-last-record-name*))
1650            "")
1651           (t
1652            (setf *bind-last-record-name* name)
1653            name))))
1654
1655 (defmethod zone-write :around ((format (eql :bind)) zone stream)
1656   (declare (ignorable zone stream))
1657   (let ((*bind-last-record-name* nil))
1658     (call-next-method)))
1659
1660 (defmethod zone-write-header ((format (eql :bind)) zone)
1661   (format *zone-output-stream* "~
1662 ;;; Zone file `~(~A~)'
1663 ;;;   (generated ~A)
1664
1665 $ORIGIN ~0@*~(~A.~)
1666 $TTL ~2@*~D~2%"
1667             (zone-name zone)
1668             (iso-date :now :datep t :timep t)
1669             (zone-default-ttl zone))
1670   (let* ((soa (zone-soa zone))
1671          (admin (let* ((name (soa-admin soa))
1672                        (at (position #\@ name))
1673                        (copy (format nil "~(~A~)." name)))
1674                   (when at
1675                     (setf (char copy at) #\.))
1676                   copy)))
1677       (format *zone-output-stream* "~
1678 ~A~30TIN SOA~40T~A (
1679 ~55@A~60T ;administrator
1680 ~45T~10D~60T ;serial
1681 ~45T~10D~60T ;refresh
1682 ~45T~10D~60T ;retry
1683 ~45T~10D~60T ;expire
1684 ~45T~10D )~60T ;min-ttl~2%"
1685               (bind-output-hostname (zone-name zone))
1686               (bind-hostname (soa-source soa))
1687               admin
1688               (soa-serial soa)
1689               (soa-refresh soa)
1690               (soa-retry soa)
1691               (soa-expire soa)
1692               (soa-min-ttl soa))))
1693
1694 (export 'bind-format-record)
1695 (defun bind-format-record (zr format &rest args)
1696   (format *zone-output-stream*
1697           "~A~20T~@[~8D~]~30TIN ~A~40T~?"
1698           (bind-output-hostname (zr-name zr))
1699           (let ((ttl (zr-ttl zr)))
1700             (and (/= ttl (zone-default-ttl *writing-zone*))
1701                  ttl))
1702           (string-upcase (symbol-name (zr-type zr)))
1703           format args))
1704
1705 (export 'bind-write-hex)
1706 (defun bind-write-hex (vector remain)
1707   "Output the VECTOR as hex, in Bind format.
1708
1709    If the length (in bytes) is less than REMAIN then it's placed on the
1710    current line; otherwise the Bind line-continuation syntax is used."
1711   (flet ((output-octet (octet)
1712            (format *zone-output-stream* "~(~2,'0X~)" octet)))
1713     (let ((len (length vector)))
1714       (cond ((< len remain)
1715              (dotimes (i len) (output-octet (aref vector i)))
1716              (terpri *zone-output-stream*))
1717             (t
1718              (format *zone-output-stream* "(")
1719              (let ((i 0))
1720              (loop
1721                (when (>= i len) (return))
1722                (let ((limit (min len (+ i 64))))
1723                  (format *zone-output-stream* "~%~8T")
1724                  (loop
1725                    (when (>= i limit) (return))
1726                    (output-octet (aref vector i))
1727                    (incf i)))))
1728              (format *zone-output-stream* " )~%"))))))
1729
1730 (defmethod zone-write-raw-rrdata ((format (eql :bind)) zr type data)
1731   (format *zone-output-stream*
1732           "~A~20T~@[~8D~]~30TIN TYPE~A~40T\\# ~A "
1733           (bind-output-hostname (zr-name zr))
1734           (let ((ttl (zr-ttl zr)))
1735             (and (/= ttl (zone-default-ttl *writing-zone*))
1736                  ttl))
1737           type
1738           (length data))
1739   (bind-write-hex data 12))
1740
1741 (defmethod zone-write-record ((format (eql :bind)) (type (eql :a)) zr)
1742   (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))
1743
1744 (defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr)
1745   (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))
1746
1747 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr)
1748   (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
1749
1750 (defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr)
1751   (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
1752
1753 (defmethod zone-write-record ((format (eql :bind)) (type (eql :dname)) zr)
1754   (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
1755
1756 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr)
1757   (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
1758
1759 (defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr)
1760   (bind-format-record zr "~2D ~A~%"
1761                       (cdr (zr-data zr))
1762                       (bind-hostname (car (zr-data zr)))))
1763
1764 (defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr)
1765   (destructuring-bind (prio weight port host) (zr-data zr)
1766     (bind-format-record zr "~2D ~5D ~5D ~A~%"
1767                         prio weight port (bind-hostname host))))
1768
1769 (defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr)
1770   (destructuring-bind (alg type fpr) (zr-data zr)
1771     (bind-format-record zr "~2D ~2D " alg type)
1772     (bind-write-hex fpr 12)))
1773
1774 (defmethod zone-write-record ((format (eql :bind)) (type (eql :tlsa)) zr)
1775   (destructuring-bind (usage selector match data) (zr-data zr)
1776     (bind-format-record zr "~2D ~2D ~2D " usage selector match)
1777     (bind-write-hex data 12)))
1778
1779 (defmethod zone-write-record ((format (eql :bind)) (type (eql :caa)) zr)
1780   (destructuring-bind (flags tag value) (zr-data zr)
1781     (bind-format-record zr "~3D ~(~A~) ~S~%" flags tag value)))
1782
1783 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ds)) zr)
1784   (destructuring-bind (tag alg hashtype hash) (zr-data zr)
1785     (bind-format-record zr "~5D ~2D ~2D " tag alg hashtype)
1786     (bind-write-hex hash 12)))
1787
1788 (defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr)
1789   (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}~%"
1790                       (zr-data zr)))
1791
1792 ;;;--------------------------------------------------------------------------
1793 ;;; tinydns-data output format.
1794
1795 (export 'tinydns-output)
1796 (defun tinydns-output (code &rest fields)
1797   (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))
1798
1799 (defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data)
1800   (tinydns-output #\: (zr-name zr) type
1801                   (with-output-to-string (out)
1802                     (dotimes (i (length data))
1803                       (let ((byte (aref data i)))
1804                         (if (or (<= byte 32)
1805                                 (>= byte 127)
1806                                 (member byte '(#\: #\\) :key #'char-code))
1807                             (format out "\\~3,'0O" byte)
1808                             (write-char (code-char byte) out)))))
1809                   (zr-ttl zr)))
1810
1811 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :a)) zr)
1812   (tinydns-output #\+ (zr-name zr)
1813                   (ipaddr-string (zr-data zr)) (zr-ttl zr)))
1814
1815 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :aaaa)) zr)
1816   (tinydns-output #\3 (zr-name zr)
1817                   (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr)))
1818                   (zr-ttl zr)))
1819
1820 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ptr)) zr)
1821   (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr)))
1822
1823 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :cname)) zr)
1824   (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr)))
1825
1826 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ns)) zr)
1827   (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr)))
1828
1829 (defmethod zone-write-record ((format (eql :tinydns)) (type (eql :mx)) zr)
1830   (let ((name (car (zr-data zr)))
1831         (prio (cdr (zr-data zr))))
1832     (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr))))
1833
1834 (defmethod zone-write-header ((format (eql :tinydns)) zone)
1835   (format *zone-output-stream* "~
1836 ### Zone file `~(~A~)'
1837 ###   (generated ~A)
1838 ~%"
1839           (zone-name zone)
1840           (iso-date :now :datep t :timep t))
1841   (let ((soa (zone-soa zone)))
1842     (tinydns-output #\Z
1843                     (zone-name zone)
1844                     (soa-source soa)
1845                     (let* ((name (copy-seq (soa-admin soa)))
1846                            (at (position #\@ name)))
1847                       (when at (setf (char name at) #\.))
1848                       name)
1849                     (soa-serial soa)
1850                     (soa-refresh soa)
1851                     (soa-expire soa)
1852                     (soa-min-ttl soa)
1853                     (zone-default-ttl zone))))
1854
1855 ;;;----- That's all, folks --------------------------------------------------