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