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