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