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
  32 (in-package #:zone)
  33
  34 ;;;--------------------------------------------------------------------------
  35 ;;; Various random utilities.
  36
  37 (defun to-integer (x)
  38   "Convert X to an integer in the most straightforward way."
  39   (floor (rational x)))
  40
  41 (defun from-mixed-base (base val)
  42   "BASE is a list of the ranges for the `digits' of a mixed-base
  43    representation.  Convert VAL, a list of digits, into an integer."
  44   (do ((base base (cdr base))
  45        (val (cdr val) (cdr val))
  46        (a (car val) (+ (* a (car base)) (car val))))
  47       ((or (null base) (null val)) a)))
  48
  49 (defun to-mixed-base (base val)
  50   "BASE is a list of the ranges for the `digits' of a mixed-base
  51    representation.  Convert VAL, an integer, into a list of digits."
  52   (let ((base (reverse base))
  53         (a nil))
  54     (loop
  55       (unless base
  56         (push val a)
  57         (return a))
  58       (multiple-value-bind (q r) (floor val (pop base))
  59         (push r a)
  60         (setf val q)))))
  61
  62 (export 'timespec-seconds)
  63 (defun timespec-seconds (ts)
  64   "Convert a timespec TS to seconds.
  65
  66    A timespec may be a real count of seconds, or a list (COUNT UNIT): UNIT
  67    may be any of a number of obvious time units."
  68   (cond ((null ts) 0)
  69         ((realp ts) (floor ts))
  70         ((atom ts)
  71          (error "Unknown timespec format ~A" ts))
  72         ((null (cdr ts))
  73          (timespec-seconds (car ts)))
  74         (t (+ (to-integer (* (car ts)
  75                              (case (intern (string-upcase
  76                                             (stringify (cadr ts)))
  77                                            '#:zone)
  78                                ((s sec secs second seconds) 1)
  79                                ((m min mins minute minutes) 60)
  80                                ((h hr hrs hour hours) #.(* 60 60))
  81                                ((d dy dys day days) #.(* 24 60 60))
  82                                ((w wk wks week weeks) #.(* 7 24 60 60))
  83                                ((y yr yrs year years) #.(* 365 24 60 60))
  84                                (t (error "Unknown time unit ~A"
  85                                          (cadr ts))))))
  86               (timespec-seconds (cddr ts))))))
  87
  88 (defun hash-table-keys (ht)
  89   "Return a list of the keys in hashtable HT."
  90   (collecting ()
  91     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
  92
  93 (defun iso-date (&optional time &key datep timep (sep #\ ))
  94   "Construct a textual date or time in ISO format.
  95
  96    The TIME is the universal time to convert, which defaults to now; DATEP is
  97    whether to emit the date; TIMEP is whether to emit the time, and
  98    SEP (default is space) is how to separate the two."
  99   (multiple-value-bind
 100       (sec min hr day mon yr dow dstp tz)
 101       (decode-universal-time (if (or (null time) (eq time :now))
 102                                  (get-universal-time)
 103                                  time))
 104     (declare (ignore dow dstp tz))
 105     (with-output-to-string (s)
 106       (when datep
 107         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 108         (when timep
 109           (write-char sep s)))
 110       (when timep
 111         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 112
 113 ;;;--------------------------------------------------------------------------
 114 ;;; Zone types.
 115
 116 (export 'soa)
 117 (defstruct (soa (:predicate soap))
 118   "Start-of-authority record information."
 119   source
 120   admin
 121   refresh
 122   retry
 123   expire
 124   min-ttl
 125   serial)
 126
 127 (export 'mx)
 128 (defstruct (mx (:predicate mxp))
 129   "Mail-exchange record information."
 130   priority
 131   domain)
 132
 133 (export 'zone)
 134 (defstruct (zone (:predicate zonep))
 135   "Zone information."
 136   soa
 137   default-ttl
 138   name
 139   records)
 140
 141 ;;;--------------------------------------------------------------------------
 142 ;;; Zone defaults.  It is intended that scripts override these.
 143
 144 (export '*default-zone-source*)
 145 (defvar *default-zone-source*
 146   (let ((hn (gethostname)))
 147     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 148   "The default zone source: the current host's name.")
 149
 150 (export '*default-zone-refresh*)
 151 (defvar *default-zone-refresh* (* 24 60 60)
 152   "Default zone refresh interval: one day.")
 153
 154 (export '*default-zone-admin*)
 155 (defvar *default-zone-admin* nil
 156   "Default zone administrator's email address.")
 157
 158 (export '*default-zone-retry*)
 159 (defvar *default-zone-retry* (* 60 60)
 160   "Default znoe retry interval: one hour.")
 161
 162 (export '*default-zone-expire*)
 163 (defvar *default-zone-expire* (* 14 24 60 60)
 164   "Default zone expiry time: two weeks.")
 165
 166 (export '*default-zone-min-ttl*)
 167 (defvar *default-zone-min-ttl* (* 4 60 60)
 168   "Default zone minimum TTL/negative TTL: four hours.")
 169
 170 (export '*default-zone-ttl*)
 171 (defvar *default-zone-ttl* (* 8 60 60)
 172   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 173
 174 (export '*default-mx-priority*)
 175 (defvar *default-mx-priority* 50
 176   "Default MX priority.")
 177
 178 ;;;--------------------------------------------------------------------------
 179 ;;; Zone variables and structures.
 180
 181 (defvar *zones* (make-hash-table :test #'equal)
 182   "Map of known zones.")
 183
 184 (export 'zone-find)
 185 (defun zone-find (name)
 186   "Find a zone given its NAME."
 187   (gethash (string-downcase (stringify name)) *zones*))
 188 (defun (setf zone-find) (zone name)
 189   "Make the zone NAME map to ZONE."
 190   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 191
 192 (export 'zone-record)
 193 (defstruct (zone-record (:conc-name zr-))
 194   "A zone record."
 195   (name '<unnamed>)
 196   ttl
 197   type
 198   (make-ptr-p nil)
 199   data)
 200
 201 (export 'zone-subdomain)
 202 (defstruct (zone-subdomain (:conc-name zs-))
 203   "A subdomain.  Slightly weird.  Used internally by zone-process-records
 204    below, and shouldn't escape."
 205   name
 206   ttl
 207   records)
 208
 209 (export '*zone-output-path*)
 210 (defvar *zone-output-path* nil
 211   "Pathname defaults to merge into output files.
 212
 213    If this is nil then use the prevailing `*default-pathname-defaults*'.
 214    This is not the same as capturing the `*default-pathname-defaults*' from
 215    load time.")
 216
 217 (export '*preferred-subnets*)
 218 (defvar *preferred-subnets* nil
 219   "Subnets to prefer when selecting defaults.")
 220
 221 ;;;--------------------------------------------------------------------------
 222 ;;; Zone infrastructure.
 223
 224 (defun zone-file-name (zone type)
 225   "Choose a file name for a given ZONE and TYPE."
 226   (merge-pathnames (make-pathname :name (string-downcase zone)
 227                                   :type (string-downcase type))
 228                    (or *zone-output-path* *default-pathname-defaults*)))
 229
 230 (export 'zone-preferred-subnet-p)
 231 (defun zone-preferred-subnet-p (name)
 232   "Answer whether NAME (a string or symbol) names a preferred subnet."
 233   (member name *preferred-subnets* :test #'string-equal))
 234
 235 (export 'preferred-subnet-case)
 236 (defmacro preferred-subnet-case (&body clauses)
 237   "CLAUSES have the form (SUBNETS . FORMS).
 238
 239    Evaluate the first FORMS whose SUBNETS (a list or single symbol, not
 240    evaluated) are considered preferred by zone-preferred-subnet-p.  If
 241    SUBNETS is the symbol t then the clause always matches."
 242   `(cond
 243     ,@(mapcar (lambda (clause)
 244                 (let ((subnets (car clause)))
 245                   (cons (cond ((eq subnets t)
 246                                t)
 247                               ((listp subnets)
 248                                `(or ,@(mapcar (lambda (subnet)
 249                                                 `(zone-preferred-subnet-p
 250                                                   ',subnet))
 251                                               subnets)))
 252                               (t
 253                                `(zone-preferred-subnet-p ',subnets)))
 254                         (cdr clause))))
 255               clauses)))
 256
 257 (defun zone-process-records (rec ttl func)
 258   "Sort out the list of records in REC, calling FUNC for each one.
 259
 260    TTL is the default time-to-live for records which don't specify one.
 261
 262    The syntax is a little fiddly to describe.  It operates relative to a
 263    subzone name NAME.
 264
 265    ZONE-RECORD: RR | TTL | SUBZONE
 266         The body of a zone form is a sequence of these.
 267
 268    TTL: :ttl INTEGER
 269         Sets the TTL for subsequent RRs in this zone or subzone.
 270
 271    RR: SYMBOL DATA
 272         Adds a record for the current NAME; the SYMBOL denotes the record
 273         type, and the DATA depends on the type.
 274
 275    SUBZONE: (LABELS ZONE-RECORD*)
 276         Defines a subzone.  The LABELS is either a list of labels, or a
 277         singleton label.  For each LABEL, evaluate the ZONE-RECORDs relative
 278         to LABEL.NAME.  The special LABEL `@' is a no-op."
 279   (labels ((sift (rec ttl)
 280              (collecting (top sub)
 281                (loop
 282                  (unless rec
 283                    (return))
 284                  (let ((r (pop rec)))
 285                    (cond ((eq r :ttl)
 286                           (setf ttl (pop rec)))
 287                          ((symbolp r)
 288                           (collect (make-zone-record :type r
 289                                                      :ttl ttl
 290                                                      :data (pop rec))
 291                                    top))
 292                          ((listp r)
 293                           (dolist (name (listify (car r)))
 294                             (collect (make-zone-subdomain :name name
 295                                                           :ttl ttl
 296                                                           :records (cdr r))
 297                                      sub)))
 298                          (t
 299                           (error "Unexpected record form ~A" (car r))))))))
 300            (process (rec dom ttl)
 301              (multiple-value-bind (top sub) (sift rec ttl)
 302                (if (and dom (null top) sub)
 303                    (let ((preferred
 304                           (or (find-if (lambda (s)
 305                                          (some #'zone-preferred-subnet-p
 306                                                (listify (zs-name s))))
 307                                        sub)
 308                               (car sub))))
 309                      (when preferred
 310                        (process (zs-records preferred)
 311                                 dom
 312                                 (zs-ttl preferred))))
 313                    (let ((name (and dom
 314                                     (string-downcase
 315                                      (join-strings #\. (reverse dom))))))
 316                      (dolist (zr top)
 317                        (setf (zr-name zr) name)
 318                        (funcall func zr))))
 319                (dolist (s sub)
 320                  (process (zs-records s)
 321                           (cons (zs-name s) dom)
 322                           (zs-ttl s))))))
 323     (process rec nil ttl)))
 324
 325 (export 'zone-parse-host)
 326 (defun zone-parse-host (f zname)
 327   "Parse a host name F: if F ends in a dot then it's considered absolute;
 328    otherwise it's relative to ZNAME."
 329   (setf f (stringify f))
 330   (cond ((string= f "@") (stringify zname))
 331         ((and (plusp (length f))
 332               (char= (char f (1- (length f))) #\.))
 333          (string-downcase (subseq f 0 (1- (length f)))))
 334         (t (string-downcase (concatenate 'string f "."
 335                                          (stringify zname))))))
 336 (defun default-rev-zone (base bytes)
 337   "Return the default reverse-zone name for the given BASE address and number
 338    of fixed leading BYTES."
 339   (join-strings #\. (collecting ()
 340                       (loop for i from (- 3 bytes) downto 0
 341                             do (collect (ipaddr-byte base i)))
 342                       (collect "in-addr.arpa"))))
 343
 344 (defun zone-name-from-net (net &optional bytes)
 345   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 346    subdomain of in-addr.arpa."
 347   (let ((ipn (net-get-as-ipnet net)))
 348     (with-ipnet (net mask) ipn
 349       (unless bytes
 350         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 351       (join-strings #\.
 352                     (append (loop
 353                                for i from (- 4 bytes) below 4
 354                                collect (logand #xff (ash net (* -8 i))))
 355                             (list "in-addr.arpa"))))))
 356
 357 (defun zone-net-from-name (name)
 358   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 359   (let* ((name (string-downcase (stringify name)))
 360          (len (length name))
 361          (suffix ".in-addr.arpa")
 362          (sufflen (length suffix))
 363          (addr 0)
 364          (n 0)
 365          (end (- len sufflen)))
 366     (unless (and (> len sufflen)
 367                  (string= name suffix :start1 end))
 368       (error "`~A' not in ~A." name suffix))
 369     (loop
 370        with start = 0
 371        for dot = (position #\. name :start start :end end)
 372        for byte = (parse-integer name
 373                                  :start start
 374                                  :end (or dot end))
 375        do (setf addr (logior addr (ash byte (* 8 n))))
 376           (incf n)
 377        when (>= n 4)
 378        do (error "Can't deduce network from ~A." name)
 379        while dot
 380        do (setf start (1+ dot)))
 381     (setf addr (ash addr (* 8 (- 4 n))))
 382     (make-ipnet addr (* 8 n))))
 383
 384 (defun zone-parse-net (net name)
 385   "Given a NET, and the NAME of a domain to guess from if NET is null, return
 386    the ipnet for the network."
 387   (if net
 388       (net-get-as-ipnet net)
 389       (zone-net-from-name name)))
 390
 391 (defun zone-cidr-delg-default-name (ipn bytes)
 392   "Given a delegated net IPN and the parent's number of changing BYTES,
 393    return the default deletate zone prefix."
 394   (with-ipnet (net mask) ipn
 395     (join-strings #\.
 396                   (reverse
 397                    (loop
 398                       for i from (1- bytes) downto 0
 399                       until (zerop (logand mask (ash #xff (* 8 i))))
 400                       collect (logand #xff (ash net (* -8 i))))))))
 401
 402 ;;;--------------------------------------------------------------------------
 403 ;;; Serial numbering.
 404
 405 (export 'make-zone-serial)
 406 (defun make-zone-serial (name)
 407   "Given a zone NAME, come up with a new serial number.
 408
 409    This will (very carefully) update a file ZONE.serial in the current
 410    directory."
 411   (let* ((file (zone-file-name name :serial))
 412          (last (with-open-file (in file
 413                                    :direction :input
 414                                    :if-does-not-exist nil)
 415                  (if in (read in)
 416                      (list 0 0 0 0))))
 417          (now (multiple-value-bind
 418                   (sec min hr dy mon yr dow dstp tz)
 419                   (get-decoded-time)
 420                 (declare (ignore sec min hr dow dstp tz))
 421                 (list dy mon yr)))
 422          (seq (cond ((not (equal now (cdr last))) 0)
 423                     ((< (car last) 99) (1+ (car last)))
 424                     (t (error "Run out of sequence numbers for ~A" name)))))
 425     (safely-writing (out file)
 426       (format out
 427               ";; Serial number file for zone ~A~%~
 428                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 429                ~S~%"
 430               name
 431               (cons seq now)))
 432     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 433
 434 ;;;--------------------------------------------------------------------------
 435 ;;; Zone form parsing.
 436
 437 (defun zone-parse-head (head)
 438   "Parse the HEAD of a zone form.
 439
 440    This has the form
 441
 442      (NAME &key :source :admin :refresh :retry
 443                 :expire :min-ttl :ttl :serial)
 444
 445    though a singleton NAME needn't be a list.  Returns the default TTL and an
 446    soa structure representing the zone head."
 447   (destructuring-bind
 448       (zname
 449        &key
 450        (source *default-zone-source*)
 451        (admin (or *default-zone-admin*
 452                   (format nil "hostmaster@~A" zname)))
 453        (refresh *default-zone-refresh*)
 454        (retry *default-zone-retry*)
 455        (expire *default-zone-expire*)
 456        (min-ttl *default-zone-min-ttl*)
 457        (ttl min-ttl)
 458        (serial (make-zone-serial zname)))
 459       (listify head)
 460     (values zname
 461             (timespec-seconds ttl)
 462             (make-soa :admin admin
 463                       :source (zone-parse-host source zname)
 464                       :refresh (timespec-seconds refresh)
 465                       :retry (timespec-seconds retry)
 466                       :expire (timespec-seconds expire)
 467                       :min-ttl (timespec-seconds min-ttl)
 468                       :serial serial))))
 469
 470 (export 'zone-make-name)
 471 (defun zone-make-name (prefix zone-name)
 472   (if (or (not prefix) (string= prefix "@"))
 473       zone-name
 474       (let ((len (length prefix)))
 475         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
 476             (join-strings #\. (list prefix zone-name))
 477             prefix))))
 478
 479 (export 'defzoneparse)
 480 (defmacro defzoneparse (types (name data list
 481                                &key (prefix (gensym "PREFIX"))
 482                                     (zname (gensym "ZNAME"))
 483                                     (ttl (gensym "TTL")))
 484                         &body body)
 485   "Define a new zone record type.
 486
 487    The TYPES may be a list of synonyms.  The other arguments are as follows:
 488
 489    NAME         The name of the record to be added.
 490
 491    DATA         The content of the record to be added (a single object,
 492                 unevaluated).
 493
 494    LIST         A function to add a record to the zone.  See below.
 495
 496    PREFIX       The prefix tag used in the original form.
 497
 498    ZNAME        The name of the zone being constructed.
 499
 500    TTL          The TTL for this record.
 501
 502    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 503    optional: you don't have to accept them if you're not interested.
 504
 505    The LIST argument names a function to be bound in the body to add a new
 506    low-level record to the zone.  It has the prototype
 507
 508      (LIST &key :name :type :data :ttl :make-ptr-p)
 509
 510    These (except MAKE-PTR-P, which defaults to nil) default to the above
 511    arguments (even if you didn't accept the arguments)."
 512   (setf types (listify types))
 513   (let* ((type (car types))
 514          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 515     (with-parsed-body (body decls doc) body
 516       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 517         `(progn
 518            (dolist (,i ',types)
 519              (setf (get ,i 'zone-parse) ',func))
 520            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 521              ,@doc
 522              ,@decls
 523              (let ((,name (zone-make-name ,prefix ,zname)))
 524                (flet ((,list (&key ((:name ,tname) ,name)
 525                                    ((:type ,ttype) ,type)
 526                                    ((:data ,tdata) ,data)
 527                                    ((:ttl ,tttl) ,ttl)
 528                                    ((:make-ptr-p ,tmakeptrp) nil))
 529                         #+cmu (declare (optimize ext:inhibit-warnings))
 530                         (collect (make-zone-record :name ,tname
 531                                                    :type ,ttype
 532                                                    :data ,tdata
 533                                                    :ttl ,tttl
 534                                                    :make-ptr-p ,tmakeptrp)
 535                                  ,col)))
 536                  ,@body)))
 537           ',type)))))
 538
 539 (export 'zone-parse-records)
 540 (defun zone-parse-records (zname ttl records)
 541   "Parse a sequence of RECORDS and return a list of raw records.
 542
 543    The records are parsed relative to the zone name ZNAME, and using the
 544    given default TTL."
 545   (collecting (rec)
 546     (flet ((parse-record (zr)
 547              (let ((func (or (get (zr-type zr) 'zone-parse)
 548                              (error "No parser for record ~A."
 549                                     (zr-type zr))))
 550                    (name (and (zr-name zr) (stringify (zr-name zr)))))
 551                (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
 552       (zone-process-records records ttl #'parse-record))))
 553
 554 (export 'zone-parse)
 555 (defun zone-parse (zf)
 556   "Parse a ZONE form.
 557
 558   The syntax of a zone form is as follows:
 559
 560    ZONE-FORM:
 561      ZONE-HEAD ZONE-RECORD*
 562
 563    ZONE-RECORD:
 564      ((NAME*) ZONE-RECORD*)
 565    | SYM ARGS"
 566   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 567     (make-zone :name zname
 568                :default-ttl ttl
 569                :soa soa
 570                :records (zone-parse-records zname ttl (cdr zf)))))
 571
 572 (export 'zone-create)
 573 (defun zone-create (zf)
 574   "Zone construction function.  Given a zone form ZF, construct the zone and
 575    add it to the table."
 576   (let* ((zone (zone-parse zf))
 577          (name (zone-name zone)))
 578     (setf (zone-find name) zone)
 579     name))
 580
 581 (export 'defzone)
 582 (defmacro defzone (soa &rest zf)
 583   "Zone definition macro."
 584   `(zone-create '(,soa ,@zf)))
 585
 586 (export 'defrevzone)
 587 (defmacro defrevzone (head &rest zf)
 588   "Define a reverse zone, with the correct name."
 589   (destructuring-bind
 590       (net &rest soa-args)
 591       (listify head)
 592     (let ((bytes nil))
 593       (when (and soa-args (integerp (car soa-args)))
 594         (setf bytes (pop soa-args)))
 595       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 596
 597 ;;;--------------------------------------------------------------------------
 598 ;;; Zone record parsers.
 599
 600 (defzoneparse :a (name data rec)
 601   ":a IPADDR"
 602   (rec :data (parse-ipaddr data) :make-ptr-p t))
 603
 604 (defzoneparse :svc (name data rec)
 605   ":svc IPADDR"
 606   (rec :type :a :data (parse-ipaddr data)))
 607
 608 (defzoneparse :ptr (name data rec :zname zname)
 609   ":ptr HOST"
 610   (rec :data (zone-parse-host data zname)))
 611
 612 (defzoneparse :cname (name data rec :zname zname)
 613   ":cname HOST"
 614   (rec :data (zone-parse-host data zname)))
 615
 616 (defzoneparse :txt (name data rec)
 617   ":txt TEXT"
 618   (rec :data data))
 619
 620 (export '*dkim-pathname-defaults*)
 621 (defvar *dkim-pathname-defaults*
 622   (make-pathname :directory '(:relative "keys")
 623                  :type "dkim"))
 624
 625 (defzoneparse :dkim (name data rec)
 626   ":dkim (KEYFILE {:TAG VALUE}*)"
 627   (destructuring-bind (file &rest plist) (listify data)
 628     (let ((things nil) (out nil))
 629       (labels ((flush ()
 630                  (when out
 631                    (push (get-output-stream-string out) things)
 632                    (setf out nil)))
 633                (emit (text)
 634                  (let ((len (length text)))
 635                    (when (and out (> (+ (file-position out)
 636                                         (length text))
 637                                      64))
 638                      (flush))
 639                    (when (plusp len)
 640                      (cond ((< len 64)
 641                             (unless out (setf out (make-string-output-stream)))
 642                             (write-string text out))
 643                            (t
 644                             (do ((i 0 j)
 645                                  (j 64 (+ j 64)))
 646                                 ((>= i len))
 647                               (push (subseq text i (min j len)) things))))))))
 648         (do ((p plist (cddr p)))
 649             ((endp p))
 650           (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
 651         (emit (with-output-to-string (out)
 652                 (write-string "p=" out)
 653                 (when file
 654                   (with-open-file
 655                       (in (merge-pathnames file *dkim-pathname-defaults*))
 656                     (loop
 657                       (when (string= (read-line in)
 658                                      "-----BEGIN PUBLIC KEY-----")
 659                         (return)))
 660                     (loop
 661                       (let ((line (read-line in)))
 662                         (if (string= line "-----END PUBLIC KEY-----")
 663                             (return)
 664                             (write-string line out)))))))))
 665       (rec :type :txt
 666            :data (nreverse things)))))
 667
 668 (eval-when (:load-toplevel :execute)
 669   (dolist (item '((sshfp-algorithm rsa 1)
 670                   (sshfp-algorithm dsa 2)
 671                   (sshfp-algorithm ecdsa 3)
 672                   (sshfp-type sha-1 1)
 673                   (sshfp-type sha-256 2)))
 674     (destructuring-bind (prop sym val) item
 675       (setf (get sym prop) val)
 676       (export sym))))
 677
 678 (export '*sshfp-pathname-defaults*)
 679 (defvar *sshfp-pathname-defaults*
 680   (make-pathname :directory '(:relative "keys")
 681                  :type "sshfp"))
 682
 683 (defzoneparse :sshfp (name data rec)
 684   ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
 685   (if (stringp data)
 686       (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
 687         (loop (let ((line (read-line in nil)))
 688                 (unless line (return))
 689                 (let ((words (str-split-words line)))
 690                   (pop words)
 691                   (when (string= (car words) "IN") (pop words))
 692                   (unless (and (string= (car words) "SSHFP")
 693                                (= (length words) 4))
 694                     (error "Invalid SSHFP record."))
 695                   (pop words)
 696                   (destructuring-bind (alg type fpr) words
 697                     (rec :data (list (parse-integer alg)
 698                                      (parse-integer type)
 699                                      fpr)))))))
 700       (flet ((lookup (what prop)
 701                (etypecase what
 702                  (fixnum what)
 703                  (symbol (or (get what prop)
 704                              (error "~S is not a known ~A" what prop))))))
 705         (dolist (item (listify data))
 706           (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
 707               (listify item)
 708             (rec :data (list (lookup alg 'sshfp-algorithm)
 709                              (lookup type 'sshfp-type)
 710                              fpr)))))))
 711
 712 (defzoneparse :mx (name data rec :zname zname)
 713   ":mx ((HOST :prio INT :ip IPADDR)*)"
 714   (dolist (mx (listify data))
 715     (destructuring-bind
 716         (mxname &key (prio *default-mx-priority*) ip)
 717         (listify mx)
 718       (let ((host (zone-parse-host mxname zname)))
 719         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 720         (rec :data (cons host prio))))))
 721
 722 (defzoneparse :ns (name data rec :zname zname)
 723   ":ns ((HOST :ip IPADDR)*)"
 724   (dolist (ns (listify data))
 725     (destructuring-bind
 726         (nsname &key ip)
 727         (listify ns)
 728       (let ((host (zone-parse-host nsname zname)))
 729         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 730         (rec :data host)))))
 731
 732 (defzoneparse :alias (name data rec :zname zname)
 733   ":alias (LABEL*)"
 734   (dolist (a (listify data))
 735     (rec :name (zone-parse-host a zname)
 736          :type :cname
 737          :data name)))
 738
 739 (defzoneparse :srv (name data rec :zname zname)
 740   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
 741   (dolist (srv data)
 742     (destructuring-bind (servopts &rest providers) srv
 743       (destructuring-bind
 744           (service &key ((:port default-port)) (protocol :tcp))
 745           (listify servopts)
 746         (unless default-port
 747           (let ((serv (serv-by-name service protocol)))
 748             (setf default-port (and serv (serv-port serv)))))
 749         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
 750           (dolist (prov providers)
 751             (destructuring-bind
 752                 (srvname
 753                  &key
 754                  (port default-port)
 755                  (prio *default-mx-priority*)
 756                  (weight 0)
 757                  ip)
 758                 (listify prov)
 759               (let ((host (zone-parse-host srvname zname)))
 760                 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 761                 (rec :name rname
 762                      :data (list prio weight port host))))))))))
 763
 764 (defzoneparse :net (name data rec)
 765   ":net (NETWORK*)"
 766   (dolist (net (listify data))
 767     (let ((n (net-get-as-ipnet net)))
 768       (rec :name (zone-parse-host "net" name)
 769            :type :a
 770            :data (ipnet-net n))
 771       (rec :name (zone-parse-host "mask" name)
 772            :type :a
 773            :data (ipnet-mask n))
 774       (rec :name (zone-parse-host "bcast" name)
 775            :type :a
 776            :data (ipnet-broadcast n)))))
 777
 778 (defzoneparse (:rev :reverse) (name data rec)
 779   ":reverse ((NET :bytes BYTES) ZONE*)
 780
 781    Add a reverse record each host in the ZONEs (or all zones) that lies
 782    within NET.  The BYTES give the number of prefix labels generated; this
 783    defaults to the smallest number of bytes needed to enumerate the net."
 784   (setf data (listify data))
 785   (destructuring-bind (net &key bytes) (listify (car data))
 786     (setf net (zone-parse-net net name))
 787     (unless bytes
 788       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 789     (let ((seen (make-hash-table :test #'equal)))
 790       (dolist (z (or (cdr data)
 791                      (hash-table-keys *zones*)))
 792         (dolist (zr (zone-records (zone-find z)))
 793           (when (and (eq (zr-type zr) :a)
 794                      (zr-make-ptr-p zr)
 795                      (ipaddr-networkp (zr-data zr) net))
 796             (let ((name (string-downcase
 797                          (join-strings
 798                           #\.
 799                           (collecting ()
 800                             (dotimes (i bytes)
 801                               (collect (logand #xff (ash (zr-data zr)
 802                                                          (* -8 i)))))
 803                             (collect name))))))
 804               (unless (gethash name seen)
 805                 (rec :name name :type :ptr
 806                      :ttl (zr-ttl zr) :data (zr-name zr))
 807                 (setf (gethash name seen) t)))))))))
 808
 809 (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
 810   ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
 811
 812    Insert CNAME records for delegating a portion of the reverse-lookup
 813    namespace which doesn't align with an octet boundary.
 814
 815    The NET specifies the origin network, in which the reverse records
 816    naturally lie.  The BYTES are the number of labels to supply for each
 817    address; the default is the smallest number which suffices to enumerate
 818    the entire NET.  The TARGET-NETs are subnets of NET which are to be
 819    delegated.  The TARGET-ZONEs are the zones to which we are delegating
 820    authority for the reverse records: the default is to append labels for those
 821    octets of the subnet base address which are not the same in all address in
 822    the subnet."
 823   (setf data (listify data))
 824   (destructuring-bind (net &key bytes) (listify (car data))
 825     (setf net (zone-parse-net net name))
 826     (unless bytes
 827       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 828     (dolist (map (or (cdr data) (list (list net))))
 829       (destructuring-bind (tnets &optional tdom) (listify map)
 830         (dolist (tnet (listify tnets))
 831           (setf tnet (zone-parse-net tnet name))
 832           (unless (ipnet-subnetp net tnet)
 833             (error "~A is not a subnet of ~A."
 834                    (ipnet-pretty tnet)
 835                    (ipnet-pretty net)))
 836           (unless tdom
 837             (with-ipnet (net mask) tnet
 838               (setf tdom
 839                     (join-strings
 840                      #\.
 841                      (append (reverse (loop
 842                                        for i from (1- bytes) downto 0
 843                                        until (zerop (logand mask
 844                                                             (ash #xff
 845                                                                  (* 8 i))))
 846                                        collect (ldb (byte 8 (* i 8)) net)))
 847                              (list name))))))
 848           (setf tdom (string-downcase (stringify tdom)))
 849           (dotimes (i (ipnet-hosts tnet))
 850             (unless (zerop i)
 851               (let* ((addr (ipnet-host tnet i))
 852                      (tail (join-strings #\.
 853                                          (loop
 854                                           for i from 0 below bytes
 855                                           collect
 856                                           (logand #xff
 857                                                   (ash addr (* 8 i)))))))
 858                 (rec :name (format nil "~A.~A" tail name)
 859                      :type :cname
 860                      :data (format nil "~A.~A" tail tdom))))))))))
 861
 862 ;;;--------------------------------------------------------------------------
 863 ;;; Zone file output.
 864
 865 (export 'zone-write)
 866 (defgeneric zone-write (format zone stream)
 867   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
 868
 869 (defvar *writing-zone* nil
 870   "The zone currently being written.")
 871
 872 (defvar *zone-output-stream* nil
 873   "Stream to write zone data on.")
 874
 875 (defmethod zone-write :around (format zone stream)
 876   (declare (ignore format))
 877   (let ((*writing-zone* zone)
 878         (*zone-output-stream* stream))
 879     (call-next-method)))
 880
 881 (export 'zone-save)
 882 (defun zone-save (zones &key (format :bind))
 883   "Write the named ZONES to files.  If no zones are given, write all the
 884    zones."
 885   (unless zones
 886     (setf zones (hash-table-keys *zones*)))
 887   (safely (safe)
 888     (dolist (z zones)
 889       (let ((zz (zone-find z)))
 890         (unless zz
 891           (error "Unknown zone `~A'." z))
 892         (let ((stream (safely-open-output-stream safe
 893                                                  (zone-file-name z :zone))))
 894           (zone-write format zz stream))))))
 895
 896 ;;;--------------------------------------------------------------------------
 897 ;;; Bind format output.
 898
 899 (export 'bind-hostname)
 900 (defun bind-hostname (hostname)
 901   (if (not hostname)
 902       "@"
 903       (let* ((h (string-downcase (stringify hostname)))
 904              (hl (length h))
 905              (r (string-downcase (zone-name *writing-zone*)))
 906              (rl (length r)))
 907         (cond ((string= r h) "@")
 908               ((and (> hl rl)
 909                     (char= (char h (- hl rl 1)) #\.)
 910                     (string= h r :start1 (- hl rl)))
 911                (subseq h 0 (- hl rl 1)))
 912               (t (concatenate 'string h "."))))))
 913
 914 (defmethod zone-write ((format (eql :bind)) zone stream)
 915   (format stream "~
 916 ;;; Zone file `~(~A~)'
 917 ;;;   (generated ~A)
 918
 919 $ORIGIN ~0@*~(~A.~)
 920 $TTL ~2@*~D~2%"
 921             (zone-name zone)
 922             (iso-date :now :datep t :timep t)
 923             (zone-default-ttl zone))
 924   (let* ((soa (zone-soa zone))
 925          (admin (let* ((name (soa-admin soa))
 926                        (at (position #\@ name))
 927                        (copy (format nil "~(~A~)." name)))
 928                   (when at
 929                     (setf (char copy at) #\.))
 930                   copy)))
 931       (format stream "~
 932 ~A~30TIN SOA~40T~A ~A (
 933 ~45T~10D~60T ;serial
 934 ~45T~10D~60T ;refresh
 935 ~45T~10D~60T ;retry
 936 ~45T~10D~60T ;expire
 937 ~45T~10D )~60T ;min-ttl~2%"
 938               (bind-hostname (zone-name zone))
 939               (bind-hostname (soa-source soa))
 940               admin
 941               (soa-serial soa)
 942               (soa-refresh soa)
 943               (soa-retry soa)
 944               (soa-expire soa)
 945               (soa-min-ttl soa)))
 946   (dolist (zr (zone-records zone))
 947     (bind-record (zr-type zr) zr)))
 948
 949 (export 'bind-record)
 950 (defgeneric bind-record (type zr))
 951
 952 (export 'bind-format-record)
 953 (defun bind-format-record (name ttl type format args)
 954   (format *zone-output-stream*
 955           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
 956           (bind-hostname name)
 957           (and (/= ttl (zone-default-ttl *writing-zone*))
 958                ttl)
 959           (string-upcase (symbol-name type))
 960           format args))
 961
 962 (defmethod bind-record (type zr)
 963   (destructuring-bind (format &rest args)
 964       (bind-record-format-args type (zr-data zr))
 965     (bind-format-record (zr-name zr)
 966                         (zr-ttl zr)
 967                         (bind-record-type type)
 968                         format args)))
 969
 970 (export 'bind-record-type)
 971 (defgeneric bind-record-type (type)
 972   (:method (type) type))
 973
 974 (export 'bind-record-format-args)
 975 (defgeneric bind-record-format-args (type data)
 976   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
 977   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
 978   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
 979   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
 980   (:method ((type (eql :mx)) data)
 981     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
 982   (:method ((type (eql :srv)) data)
 983     (destructuring-bind (prio weight port host) data
 984       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
 985   (:method ((type (eql :sshfp)) data)
 986     (cons "~2D ~2D ~A" data))
 987   (:method ((type (eql :txt)) data)
 988     (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
 989           (mapcar #'stringify (listify data)))))
 990
 991 ;;;----- That's all, folks --------------------------------------------------