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

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