chiark - git - mdw - zone/blob - zone.lisp

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