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 (defun zone-parse-records (zone records)
 540   "Parse the body of a zone form.
 541
 542    ZONE is the zone object; RECORDS is the body of the form."
 543   (let ((zname (zone-name zone)))
 544     (with-collection (rec)
 545         (flet ((parse-record (zr)
 546                  (let ((func (or (get (zr-type zr) 'zone-parse)
 547                                  (error "No parser for record ~A."
 548                                         (zr-type zr))))
 549                        (name (and (zr-name zr) (stringify (zr-name zr)))))
 550                    (funcall func
 551                             name
 552                             zname
 553                             (zr-data zr)
 554                             (zr-ttl zr)
 555                             rec))))
 556           (zone-process-records records
 557                                 (zone-default-ttl zone)
 558                                 #'parse-record))
 559       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 560
 561 (export 'zone-parse)
 562 (defun zone-parse (zf)
 563   "Parse a ZONE form.
 564
 565   The syntax of a zone form is as follows:
 566
 567    ZONE-FORM:
 568      ZONE-HEAD ZONE-RECORD*
 569
 570    ZONE-RECORD:
 571      ((NAME*) ZONE-RECORD*)
 572    | SYM ARGS"
 573   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 574     (let ((zone (make-zone :name zname
 575                            :default-ttl ttl
 576                            :soa soa
 577                            :records nil)))
 578       (zone-parse-records zone (cdr zf))
 579       zone)))
 580
 581 (export 'zone-create)
 582 (defun zone-create (zf)
 583   "Zone construction function.  Given a zone form ZF, construct the zone and
 584    add it to the table."
 585   (let* ((zone (zone-parse zf))
 586          (name (zone-name zone)))
 587     (setf (zone-find name) zone)
 588     name))
 589
 590 (export 'defzone)
 591 (defmacro defzone (soa &rest zf)
 592   "Zone definition macro."
 593   `(zone-create '(,soa ,@zf)))
 594
 595 (export 'defrevzone)
 596 (defmacro defrevzone (head &rest zf)
 597   "Define a reverse zone, with the correct name."
 598   (destructuring-bind
 599       (net &rest soa-args)
 600       (listify head)
 601     (let ((bytes nil))
 602       (when (and soa-args (integerp (car soa-args)))
 603         (setf bytes (pop soa-args)))
 604       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 605
 606 ;;;--------------------------------------------------------------------------
 607 ;;; Zone record parsers.
 608
 609 (defzoneparse :a (name data rec)
 610   ":a IPADDR"
 611   (rec :data (parse-ipaddr data) :make-ptr-p t))
 612
 613 (defzoneparse :svc (name data rec)
 614   ":svc IPADDR"
 615   (rec :type :a :data (parse-ipaddr data)))
 616
 617 (defzoneparse :ptr (name data rec :zname zname)
 618   ":ptr HOST"
 619   (rec :data (zone-parse-host data zname)))
 620
 621 (defzoneparse :cname (name data rec :zname zname)
 622   ":cname HOST"
 623   (rec :data (zone-parse-host data zname)))
 624
 625 (defzoneparse :txt (name data rec)
 626   ":txt TEXT"
 627   (rec :data data))
 628
 629 (defzoneparse :dkim (name data rec)
 630   ":dkim (KEYFILE {:TAG VALUE}*)"
 631   (destructuring-bind (file &rest plist) (listify data)
 632     (let ((things nil) (out nil))
 633       (labels ((flush ()
 634                  (when out
 635                    (push (get-output-stream-string out) things)
 636                    (setf out nil)))
 637                (emit (text)
 638                  (let ((len (length text)))
 639                    (when (and out (> (+ (file-position out)
 640                                         (length text))
 641                                      64))
 642                      (flush))
 643                    (when (plusp len)
 644                      (cond ((< len 64)
 645                             (unless out (setf out (make-string-output-stream)))
 646                             (write-string text out))
 647                            (t
 648                             (do ((i 0 j)
 649                                  (j 64 (+ j 64)))
 650                                 ((>= i len))
 651                               (push (subseq text i (min j len)) things))))))))
 652         (do ((p plist (cddr p)))
 653             ((endp p))
 654           (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
 655         (emit (with-output-to-string (out)
 656                 (write-string "p=" out)
 657                 (when file
 658                   (with-open-file (in file :direction :input)
 659                     (loop
 660                       (when (string= (read-line in)
 661                                      "-----BEGIN PUBLIC KEY-----")
 662                         (return)))
 663                     (loop
 664                       (let ((line (read-line in)))
 665                         (if (string= line "-----END PUBLIC KEY-----")
 666                             (return)
 667                             (write-string line out)))))))))
 668       (rec :type :txt
 669            :data (nreverse things)))))
 670
 671 (eval-when (:load-toplevel :execute)
 672   (dolist (item '((sshfp-algorithm rsa 1)
 673                   (sshfp-algorithm dsa 2)
 674                   (sshfp-algorithm ecdsa 3)
 675                   (sshfp-type sha-1 1)
 676                   (sshfp-type sha-256 2)))
 677     (destructuring-bind (prop sym val) item
 678       (setf (get sym prop) val)
 679       (export sym))))
 680
 681 (defzoneparse :sshfp (name data rec)
 682   ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
 683   (if (stringp data)
 684       (with-open-file (in data)
 685         (loop (let ((line (read-line in nil)))
 686                 (unless line (return))
 687                 (let ((words (str-split-words line)))
 688                   (pop words)
 689                   (when (string= (car words) "IN") (pop words))
 690                   (unless (and (string= (car words) "SSHFP")
 691                                (= (length words) 4))
 692                     (error "Invalid SSHFP record."))
 693                   (pop words)
 694                   (destructuring-bind (alg type fpr) words
 695                     (rec :data (list (parse-integer alg)
 696                                      (parse-integer type)
 697                                      fpr)))))))
 698       (flet ((lookup (what prop)
 699                (etypecase what
 700                  (fixnum what)
 701                  (symbol (or (get what prop)
 702                              (error "~S is not a known ~A" what prop))))))
 703         (dolist (item (listify data))
 704           (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
 705               (listify item)
 706             (rec :data (list (lookup alg 'sshfp-algorithm)
 707                              (lookup type 'sshfp-type)
 708                              fpr)))))))
 709
 710 (defzoneparse :mx (name data rec :zname zname)
 711   ":mx ((HOST :prio INT :ip IPADDR)*)"
 712   (dolist (mx (listify data))
 713     (destructuring-bind
 714         (mxname &key (prio *default-mx-priority*) ip)
 715         (listify mx)
 716       (let ((host (zone-parse-host mxname zname)))
 717         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 718         (rec :data (cons host prio))))))
 719
 720 (defzoneparse :ns (name data rec :zname zname)
 721   ":ns ((HOST :ip IPADDR)*)"
 722   (dolist (ns (listify data))
 723     (destructuring-bind
 724         (nsname &key ip)
 725         (listify ns)
 726       (let ((host (zone-parse-host nsname zname)))
 727         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 728         (rec :data host)))))
 729
 730 (defzoneparse :alias (name data rec :zname zname)
 731   ":alias (LABEL*)"
 732   (dolist (a (listify data))
 733     (rec :name (zone-parse-host a zname)
 734          :type :cname
 735          :data name)))
 736
 737 (defzoneparse :srv (name data rec :zname zname)
 738   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
 739   (dolist (srv data)
 740     (destructuring-bind (servopts &rest providers) srv
 741       (destructuring-bind
 742           (service &key ((:port default-port)) (protocol :tcp))
 743           (listify servopts)
 744         (unless default-port
 745           (let ((serv (serv-by-name service protocol)))
 746             (setf default-port (and serv (serv-port serv)))))
 747         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
 748           (dolist (prov providers)
 749             (destructuring-bind
 750                 (srvname
 751                  &key
 752                  (port default-port)
 753                  (prio *default-mx-priority*)
 754                  (weight 0)
 755                  ip)
 756                 (listify prov)
 757               (let ((host (zone-parse-host srvname zname)))
 758                 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 759                 (rec :name rname
 760                      :data (list prio weight port host))))))))))
 761
 762 (defzoneparse :net (name data rec)
 763   ":net (NETWORK*)"
 764   (dolist (net (listify data))
 765     (let ((n (net-get-as-ipnet net)))
 766       (rec :name (zone-parse-host "net" name)
 767            :type :a
 768            :data (ipnet-net n))
 769       (rec :name (zone-parse-host "mask" name)
 770            :type :a
 771            :data (ipnet-mask n))
 772       (rec :name (zone-parse-host "bcast" name)
 773            :type :a
 774            :data (ipnet-broadcast n)))))
 775
 776 (defzoneparse (:rev :reverse) (name data rec)
 777   ":reverse ((NET :bytes BYTES) ZONE*)
 778
 779    Add a reverse record each host in the ZONEs (or all zones) that lies
 780    within NET.  The BYTES give the number of prefix labels generated; this
 781    defaults to the smallest number of bytes needed to enumerate the net."
 782   (setf data (listify data))
 783   (destructuring-bind (net &key bytes) (listify (car data))
 784     (setf net (zone-parse-net net name))
 785     (unless bytes
 786       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 787     (let ((seen (make-hash-table :test #'equal)))
 788       (dolist (z (or (cdr data)
 789                      (hash-table-keys *zones*)))
 790         (dolist (zr (zone-records (zone-find z)))
 791           (when (and (eq (zr-type zr) :a)
 792                      (zr-make-ptr-p zr)
 793                      (ipaddr-networkp (zr-data zr) net))
 794             (let ((name (string-downcase
 795                          (join-strings
 796                           #\.
 797                           (collecting ()
 798                             (dotimes (i bytes)
 799                               (collect (logand #xff (ash (zr-data zr)
 800                                                          (* -8 i)))))
 801                             (collect name))))))
 802               (unless (gethash name seen)
 803                 (rec :name name :type :ptr
 804                      :ttl (zr-ttl zr) :data (zr-name zr))
 805                 (setf (gethash name seen) t)))))))))
 806
 807 (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
 808   ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
 809
 810    Insert CNAME records for delegating a portion of the reverse-lookup
 811    namespace which doesn't align with an octet boundary.
 812
 813    The NET specifies the origin network, in which the reverse records
 814    naturally lie.  The BYTES are the number of labels to supply for each
 815    address; the default is the smallest number which suffices to enumerate
 816    the entire NET.  The TARGET-NETs are subnets of NET which are to be
 817    delegated.  The TARGET-ZONEs are the zones to which we are delegating
 818    authority for the reverse records: the default is to append labels for those
 819    octets of the subnet base address which are not the same in all address in
 820    the subnet."
 821   (setf data (listify data))
 822   (destructuring-bind (net &key bytes) (listify (car data))
 823     (setf net (zone-parse-net net name))
 824     (unless bytes
 825       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 826     (dolist (map (or (cdr data) (list (list net))))
 827       (destructuring-bind (tnets &optional tdom) (listify map)
 828         (dolist (tnet (listify tnets))
 829           (setf tnet (zone-parse-net tnet name))
 830           (unless (ipnet-subnetp net tnet)
 831             (error "~A is not a subnet of ~A."
 832                    (ipnet-pretty tnet)
 833                    (ipnet-pretty net)))
 834           (unless tdom
 835             (with-ipnet (net mask) tnet
 836               (setf tdom
 837                     (join-strings
 838                      #\.
 839                      (append (reverse (loop
 840                                        for i from (1- bytes) downto 0
 841                                        until (zerop (logand mask
 842                                                             (ash #xff
 843                                                                  (* 8 i))))
 844                                        collect (ldb (byte 8 (* i 8)) net)))
 845                              (list name))))))
 846           (setf tdom (string-downcase (stringify tdom)))
 847           (dotimes (i (ipnet-hosts tnet))
 848             (unless (zerop i)
 849               (let* ((addr (ipnet-host tnet i))
 850                      (tail (join-strings #\.
 851                                          (loop
 852                                           for i from 0 below bytes
 853                                           collect
 854                                           (logand #xff
 855                                                   (ash addr (* 8 i)))))))
 856                 (rec :name (format nil "~A.~A" tail name)
 857                      :type :cname
 858                      :data (format nil "~A.~A" tail tdom))))))))))
 859
 860 ;;;--------------------------------------------------------------------------
 861 ;;; Zone file output.
 862
 863 (export 'zone-write)
 864 (defgeneric zone-write (format zone stream)
 865   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
 866
 867 (defvar *writing-zone* nil
 868   "The zone currently being written.")
 869
 870 (defvar *zone-output-stream* nil
 871   "Stream to write zone data on.")
 872
 873 (defmethod zone-write :around (format zone stream)
 874   (declare (ignore format))
 875   (let ((*writing-zone* zone)
 876         (*zone-output-stream* stream))
 877     (call-next-method)))
 878
 879 (export 'zone-save)
 880 (defun zone-save (zones &key (format :bind))
 881   "Write the named ZONES to files.  If no zones are given, write all the
 882    zones."
 883   (unless zones
 884     (setf zones (hash-table-keys *zones*)))
 885   (safely (safe)
 886     (dolist (z zones)
 887       (let ((zz (zone-find z)))
 888         (unless zz
 889           (error "Unknown zone `~A'." z))
 890         (let ((stream (safely-open-output-stream safe
 891                                                  (zone-file-name z :zone))))
 892           (zone-write format zz stream))))))
 893
 894 ;;;--------------------------------------------------------------------------
 895 ;;; Bind format output.
 896
 897 (export 'bind-hostname)
 898 (defun bind-hostname (hostname)
 899   (if (not hostname)
 900       "@"
 901       (let* ((h (string-downcase (stringify hostname)))
 902              (hl (length h))
 903              (r (string-downcase (zone-name *writing-zone*)))
 904              (rl (length r)))
 905         (cond ((string= r h) "@")
 906               ((and (> hl rl)
 907                     (char= (char h (- hl rl 1)) #\.)
 908                     (string= h r :start1 (- hl rl)))
 909                (subseq h 0 (- hl rl 1)))
 910               (t (concatenate 'string h "."))))))
 911
 912 (defmethod zone-write ((format (eql :bind)) zone stream)
 913   (format stream "~
 914 ;;; Zone file `~(~A~)'
 915 ;;;   (generated ~A)
 916
 917 $ORIGIN ~0@*~(~A.~)
 918 $TTL ~2@*~D~2%"
 919             (zone-name zone)
 920             (iso-date :now :datep t :timep t)
 921             (zone-default-ttl zone))
 922   (let* ((soa (zone-soa zone))
 923          (admin (let* ((name (soa-admin soa))
 924                        (at (position #\@ name))
 925                        (copy (format nil "~(~A~)." name)))
 926                   (when at
 927                     (setf (char copy at) #\.))
 928                   copy)))
 929       (format stream "~
 930 ~A~30TIN SOA~40T~A ~A (
 931 ~45T~10D~60T ;serial
 932 ~45T~10D~60T ;refresh
 933 ~45T~10D~60T ;retry
 934 ~45T~10D~60T ;expire
 935 ~45T~10D )~60T ;min-ttl~2%"
 936               (bind-hostname (zone-name zone))
 937               (bind-hostname (soa-source soa))
 938               admin
 939               (soa-serial soa)
 940               (soa-refresh soa)
 941               (soa-retry soa)
 942               (soa-expire soa)
 943               (soa-min-ttl soa)))
 944   (dolist (zr (zone-records zone))
 945     (bind-record (zr-type zr) zr)))
 946
 947 (export 'bind-record)
 948 (defgeneric bind-record (type zr))
 949
 950 (export 'bind-format-record)
 951 (defun bind-format-record (name ttl type format args)
 952   (format *zone-output-stream*
 953           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
 954           (bind-hostname name)
 955           (and (/= ttl (zone-default-ttl *writing-zone*))
 956                ttl)
 957           (string-upcase (symbol-name type))
 958           format args))
 959
 960 (defmethod bind-record (type zr)
 961   (destructuring-bind (format &rest args)
 962       (bind-record-format-args type (zr-data zr))
 963     (bind-format-record (zr-name zr)
 964                         (zr-ttl zr)
 965                         (bind-record-type type)
 966                         format args)))
 967
 968 (export 'bind-record-type)
 969 (defgeneric bind-record-type (type)
 970   (:method (type) type))
 971
 972 (export 'bind-record-format-args)
 973 (defgeneric bind-record-format-args (type data)
 974   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
 975   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
 976   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
 977   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
 978   (:method ((type (eql :mx)) data)
 979     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
 980   (:method ((type (eql :srv)) data)
 981     (destructuring-bind (prio weight port host) data
 982       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
 983   (:method ((type (eql :sshfp)) data)
 984     (cons "~2D ~2D ~A" data))
 985   (:method ((type (eql :txt)) data)
 986     (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
 987           (mapcar #'stringify (listify data)))))
 988
 989 ;;;----- That's all, folks --------------------------------------------------