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