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