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* *default-pathname-defaults*
 211   "Pathname defaults to merge into output files.")
 212
 213 (export '*preferred-subnets*)
 214 (defvar *preferred-subnets* nil
 215   "Subnets to prefer when selecting defaults.")
 216
 217 ;;;--------------------------------------------------------------------------
 218 ;;; Zone infrastructure.
 219
 220 (defun zone-file-name (zone type)
 221   "Choose a file name for a given ZONE and TYPE."
 222   (merge-pathnames (make-pathname :name (string-downcase zone)
 223                                   :type (string-downcase type))
 224                    *zone-output-path*))
 225
 226 (export 'zone-preferred-subnet-p)
 227 (defun zone-preferred-subnet-p (name)
 228   "Answer whether NAME (a string or symbol) names a preferred subnet."
 229   (member name *preferred-subnets* :test #'string-equal))
 230
 231 (export 'preferred-subnet-case)
 232 (defmacro preferred-subnet-case (&body clauses)
 233   "CLAUSES have the form (SUBNETS . FORMS).
 234
 235    Evaluate the first FORMS whose SUBNETS (a list or single symbol, not
 236    evaluated) are considered preferred by zone-preferred-subnet-p.  If
 237    SUBNETS is the symbol t then the clause always matches."
 238   `(cond
 239     ,@(mapcar (lambda (clause)
 240                 (let ((subnets (car clause)))
 241                   (cons (cond ((eq subnets t)
 242                                t)
 243                               ((listp subnets)
 244                                `(or ,@(mapcar (lambda (subnet)
 245                                                 `(zone-preferred-subnet-p
 246                                                   ',subnet))
 247                                               subnets)))
 248                               (t
 249                                `(zone-preferred-subnet-p ',subnets)))
 250                         (cdr clause))))
 251               clauses)))
 252
 253 (defun zone-process-records (rec ttl func)
 254   "Sort out the list of records in REC, calling FUNC for each one.
 255
 256    TTL is the default time-to-live for records which don't specify one.
 257
 258    The syntax is a little fiddly to describe.  It operates relative to a
 259    subzone name NAME.
 260
 261    ZONE-RECORD: RR | TTL | SUBZONE
 262         The body of a zone form is a sequence of these.
 263
 264    TTL: :ttl INTEGER
 265         Sets the TTL for subsequent RRs in this zone or subzone.
 266
 267    RR: SYMBOL DATA
 268         Adds a record for the current NAME; the SYMBOL denotes the record
 269         type, and the DATA depends on the type.
 270
 271    SUBZONE: (LABELS ZONE-RECORD*)
 272         Defines a subzone.  The LABELS is either a list of labels, or a
 273         singleton label.  For each LABEL, evaluate the ZONE-RECORDs relative
 274         to LABEL.NAME.  The special LABEL `@' is a no-op."
 275   (labels ((sift (rec ttl)
 276              (collecting (top sub)
 277                (loop
 278                  (unless rec
 279                    (return))
 280                  (let ((r (pop rec)))
 281                    (cond ((eq r :ttl)
 282                           (setf ttl (pop rec)))
 283                          ((symbolp r)
 284                           (collect (make-zone-record :type r
 285                                                      :ttl ttl
 286                                                      :data (pop rec))
 287                                    top))
 288                          ((listp r)
 289                           (dolist (name (listify (car r)))
 290                             (collect (make-zone-subdomain :name name
 291                                                           :ttl ttl
 292                                                           :records (cdr r))
 293                                      sub)))
 294                          (t
 295                           (error "Unexpected record form ~A" (car r))))))))
 296            (process (rec dom ttl)
 297              (multiple-value-bind (top sub) (sift rec ttl)
 298                (if (and dom (null top) sub)
 299                    (let ((preferred
 300                           (or (find-if (lambda (s)
 301                                          (some #'zone-preferred-subnet-p
 302                                                (listify (zs-name s))))
 303                                        sub)
 304                               (car sub))))
 305                      (when preferred
 306                        (process (zs-records preferred)
 307                                 dom
 308                                 (zs-ttl preferred))))
 309                    (let ((name (and dom
 310                                     (string-downcase
 311                                      (join-strings #\. (reverse dom))))))
 312                      (dolist (zr top)
 313                        (setf (zr-name zr) name)
 314                        (funcall func zr))))
 315                (dolist (s sub)
 316                  (process (zs-records s)
 317                           (cons (zs-name s) dom)
 318                           (zs-ttl s))))))
 319     (process rec nil ttl)))
 320
 321 (export 'zone-parse-host)
 322 (defun zone-parse-host (f zname)
 323   "Parse a host name F: if F ends in a dot then it's considered absolute;
 324    otherwise it's relative to ZNAME."
 325   (setf f (stringify f))
 326   (cond ((string= f "@") (stringify zname))
 327         ((and (plusp (length f))
 328               (char= (char f (1- (length f))) #\.))
 329          (string-downcase (subseq f 0 (1- (length f)))))
 330         (t (string-downcase (concatenate 'string f "."
 331                                          (stringify zname))))))
 332 (defun default-rev-zone (base bytes)
 333   "Return the default reverse-zone name for the given BASE address and number
 334    of fixed leading BYTES."
 335   (join-strings #\. (collecting ()
 336                       (loop for i from (- 3 bytes) downto 0
 337                             do (collect (ipaddr-byte base i)))
 338                       (collect "in-addr.arpa"))))
 339
 340 (defun zone-name-from-net (net &optional bytes)
 341   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 342    subdomain of in-addr.arpa."
 343   (let ((ipn (net-get-as-ipnet net)))
 344     (with-ipnet (net mask) ipn
 345       (unless bytes
 346         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 347       (join-strings #\.
 348                     (append (loop
 349                                for i from (- 4 bytes) below 4
 350                                collect (logand #xff (ash net (* -8 i))))
 351                             (list "in-addr.arpa"))))))
 352
 353 (defun zone-net-from-name (name)
 354   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 355   (let* ((name (string-downcase (stringify name)))
 356          (len (length name))
 357          (suffix ".in-addr.arpa")
 358          (sufflen (length suffix))
 359          (addr 0)
 360          (n 0)
 361          (end (- len sufflen)))
 362     (unless (and (> len sufflen)
 363                  (string= name suffix :start1 end))
 364       (error "`~A' not in ~A." name suffix))
 365     (loop
 366        with start = 0
 367        for dot = (position #\. name :start start :end end)
 368        for byte = (parse-integer name
 369                                  :start start
 370                                  :end (or dot end))
 371        do (setf addr (logior addr (ash byte (* 8 n))))
 372           (incf n)
 373        when (>= n 4)
 374        do (error "Can't deduce network from ~A." name)
 375        while dot
 376        do (setf start (1+ dot)))
 377     (setf addr (ash addr (* 8 (- 4 n))))
 378     (make-ipnet addr (* 8 n))))
 379
 380 (defun zone-parse-net (net name)
 381   "Given a NET, and the NAME of a domain to guess from if NET is null, return
 382    the ipnet for the network."
 383   (if net
 384       (net-get-as-ipnet net)
 385       (zone-net-from-name name)))
 386
 387 (defun zone-cidr-delg-default-name (ipn bytes)
 388   "Given a delegated net IPN and the parent's number of changing BYTES,
 389    return the default deletate zone prefix."
 390   (with-ipnet (net mask) ipn
 391     (join-strings #\.
 392                   (reverse
 393                    (loop
 394                       for i from (1- bytes) downto 0
 395                       until (zerop (logand mask (ash #xff (* 8 i))))
 396                       collect (logand #xff (ash net (* -8 i))))))))
 397
 398 ;;;--------------------------------------------------------------------------
 399 ;;; Serial numbering.
 400
 401 (export 'make-zone-serial)
 402 (defun make-zone-serial (name)
 403   "Given a zone NAME, come up with a new serial number.
 404
 405    This will (very carefully) update a file ZONE.serial in the current
 406    directory."
 407   (let* ((file (zone-file-name name :serial))
 408          (last (with-open-file (in file
 409                                    :direction :input
 410                                    :if-does-not-exist nil)
 411                  (if in (read in)
 412                      (list 0 0 0 0))))
 413          (now (multiple-value-bind
 414                   (sec min hr dy mon yr dow dstp tz)
 415                   (get-decoded-time)
 416                 (declare (ignore sec min hr dow dstp tz))
 417                 (list dy mon yr)))
 418          (seq (cond ((not (equal now (cdr last))) 0)
 419                     ((< (car last) 99) (1+ (car last)))
 420                     (t (error "Run out of sequence numbers for ~A" name)))))
 421     (safely-writing (out file)
 422       (format out
 423               ";; Serial number file for zone ~A~%~
 424                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 425                ~S~%"
 426               name
 427               (cons seq now)))
 428     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 429
 430 ;;;--------------------------------------------------------------------------
 431 ;;; Zone form parsing.
 432
 433 (defun zone-parse-head (head)
 434   "Parse the HEAD of a zone form.
 435
 436    This has the form
 437
 438      (NAME &key :source :admin :refresh :retry
 439                 :expire :min-ttl :ttl :serial)
 440
 441    though a singleton NAME needn't be a list.  Returns the default TTL and an
 442    soa structure representing the zone head."
 443   (destructuring-bind
 444       (zname
 445        &key
 446        (source *default-zone-source*)
 447        (admin (or *default-zone-admin*
 448                   (format nil "hostmaster@~A" zname)))
 449        (refresh *default-zone-refresh*)
 450        (retry *default-zone-retry*)
 451        (expire *default-zone-expire*)
 452        (min-ttl *default-zone-min-ttl*)
 453        (ttl min-ttl)
 454        (serial (make-zone-serial zname)))
 455       (listify head)
 456     (values zname
 457             (timespec-seconds ttl)
 458             (make-soa :admin admin
 459                       :source (zone-parse-host source zname)
 460                       :refresh (timespec-seconds refresh)
 461                       :retry (timespec-seconds retry)
 462                       :expire (timespec-seconds expire)
 463                       :min-ttl (timespec-seconds min-ttl)
 464                       :serial serial))))
 465
 466 (export 'zone-make-name)
 467 (defun zone-make-name (prefix zone-name)
 468   (if (or (not prefix) (string= prefix "@"))
 469       zone-name
 470       (let ((len (length prefix)))
 471         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
 472             (join-strings #\. (list prefix zone-name))
 473             prefix))))
 474
 475 (export 'defzoneparse)
 476 (defmacro defzoneparse (types (name data list
 477                                &key (prefix (gensym "PREFIX"))
 478                                     (zname (gensym "ZNAME"))
 479                                     (ttl (gensym "TTL")))
 480                         &body body)
 481   "Define a new zone record type.
 482
 483    The TYPES may be a list of synonyms.  The other arguments are as follows:
 484
 485    NAME         The name of the record to be added.
 486
 487    DATA         The content of the record to be added (a single object,
 488                 unevaluated).
 489
 490    LIST         A function to add a record to the zone.  See below.
 491
 492    PREFIX       The prefix tag used in the original form.
 493
 494    ZNAME        The name of the zone being constructed.
 495
 496    TTL          The TTL for this record.
 497
 498    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 499    optional: you don't have to accept them if you're not interested.
 500
 501    The LIST argument names a function to be bound in the body to add a new
 502    low-level record to the zone.  It has the prototype
 503
 504      (LIST &key :name :type :data :ttl :make-ptr-p)
 505
 506    These (except MAKE-PTR-P, which defaults to nil) default to the above
 507    arguments (even if you didn't accept the arguments)."
 508   (setf types (listify types))
 509   (let* ((type (car types))
 510          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 511     (with-parsed-body (body decls doc) body
 512       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 513         `(progn
 514            (dolist (,i ',types)
 515              (setf (get ,i 'zone-parse) ',func))
 516            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 517              ,@doc
 518              ,@decls
 519              (let ((,name (zone-make-name ,prefix ,zname)))
 520                (flet ((,list (&key ((:name ,tname) ,name)
 521                                    ((:type ,ttype) ,type)
 522                                    ((:data ,tdata) ,data)
 523                                    ((:ttl ,tttl) ,ttl)
 524                                    ((:make-ptr-p ,tmakeptrp) nil))
 525                         #+cmu (declare (optimize ext:inhibit-warnings))
 526                         (collect (make-zone-record :name ,tname
 527                                                    :type ,ttype
 528                                                    :data ,tdata
 529                                                    :ttl ,tttl
 530                                                    :make-ptr-p ,tmakeptrp)
 531                                  ,col)))
 532                  ,@body)))
 533           ',type)))))
 534
 535 (defun zone-parse-records (zone records)
 536   "Parse the body of a zone form.
 537
 538    ZONE is the zone object; RECORDS is the body of the form."
 539   (let ((zname (zone-name zone)))
 540     (with-collection (rec)
 541         (flet ((parse-record (zr)
 542                  (let ((func (or (get (zr-type zr) 'zone-parse)
 543                                  (error "No parser for record ~A."
 544                                         (zr-type zr))))
 545                        (name (and (zr-name zr) (stringify (zr-name zr)))))
 546                    (funcall func
 547                             name
 548                             zname
 549                             (zr-data zr)
 550                             (zr-ttl zr)
 551                             rec))))
 552           (zone-process-records records
 553                                 (zone-default-ttl zone)
 554                                 #'parse-record))
 555       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 556
 557 (export 'zone-parse)
 558 (defun zone-parse (zf)
 559   "Parse a ZONE form.
 560
 561   The syntax of a zone form is as follows:
 562
 563    ZONE-FORM:
 564      ZONE-HEAD ZONE-RECORD*
 565
 566    ZONE-RECORD:
 567      ((NAME*) ZONE-RECORD*)
 568    | SYM ARGS"
 569   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 570     (let ((zone (make-zone :name zname
 571                            :default-ttl ttl
 572                            :soa soa
 573                            :records nil)))
 574       (zone-parse-records zone (cdr zf))
 575       zone)))
 576
 577 (export 'zone-create)
 578 (defun zone-create (zf)
 579   "Zone construction function.  Given a zone form ZF, construct the zone and
 580    add it to the table."
 581   (let* ((zone (zone-parse zf))
 582          (name (zone-name zone)))
 583     (setf (zone-find name) zone)
 584     name))
 585
 586 (export 'defzone)
 587 (defmacro defzone (soa &rest zf)
 588   "Zone definition macro."
 589   `(zone-create '(,soa ,@zf)))
 590
 591 (export 'defrevzone)
 592 (defmacro defrevzone (head &rest zf)
 593   "Define a reverse zone, with the correct name."
 594   (destructuring-bind
 595       (net &rest soa-args)
 596       (listify head)
 597     (let ((bytes nil))
 598       (when (and soa-args (integerp (car soa-args)))
 599         (setf bytes (pop soa-args)))
 600       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 601
 602 ;;;--------------------------------------------------------------------------
 603 ;;; Zone record parsers.
 604
 605 (defzoneparse :a (name data rec)
 606   ":a IPADDR"
 607   (rec :data (parse-ipaddr data) :make-ptr-p t))
 608
 609 (defzoneparse :svc (name data rec)
 610   ":svc IPADDR"
 611   (rec :type :a :data (parse-ipaddr data)))
 612
 613 (defzoneparse :ptr (name data rec :zname zname)
 614   ":ptr HOST"
 615   (rec :data (zone-parse-host data zname)))
 616
 617 (defzoneparse :cname (name data rec :zname zname)
 618   ":cname HOST"
 619   (rec :data (zone-parse-host data zname)))
 620
 621 (defzoneparse :txt (name data rec)
 622   ":txt TEXT"
 623   (rec :data data))
 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 (in file :direction :input)
 655                     (loop
 656                       (when (string= (read-line in)
 657                                      "-----BEGIN PUBLIC KEY-----")
 658                         (return)))
 659                     (loop
 660                       (let ((line (read-line in)))
 661                         (if (string= line "-----END PUBLIC KEY-----")
 662                             (return)
 663                             (write-string line out)))))))))
 664       (rec :type :txt
 665            :data (nreverse things)))))
 666
 667 (defzoneparse :mx (name data rec :zname zname)
 668   ":mx ((HOST :prio INT :ip IPADDR)*)"
 669   (dolist (mx (listify data))
 670     (destructuring-bind
 671         (mxname &key (prio *default-mx-priority*) ip)
 672         (listify mx)
 673       (let ((host (zone-parse-host mxname zname)))
 674         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 675         (rec :data (cons host prio))))))
 676
 677 (defzoneparse :ns (name data rec :zname zname)
 678   ":ns ((HOST :ip IPADDR)*)"
 679   (dolist (ns (listify data))
 680     (destructuring-bind
 681         (nsname &key ip)
 682         (listify ns)
 683       (let ((host (zone-parse-host nsname zname)))
 684         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 685         (rec :data host)))))
 686
 687 (defzoneparse :alias (name data rec :zname zname)
 688   ":alias (LABEL*)"
 689   (dolist (a (listify data))
 690     (rec :name (zone-parse-host a zname)
 691          :type :cname
 692          :data name)))
 693
 694 (defzoneparse :srv (name data rec :zname zname)
 695   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
 696   (dolist (srv data)
 697     (destructuring-bind (servopts &rest providers) srv
 698       (destructuring-bind
 699           (service &key ((:port default-port)) (protocol :tcp))
 700           (listify servopts)
 701         (unless default-port
 702           (let ((serv (serv-by-name service protocol)))
 703             (setf default-port (and serv (serv-port serv)))))
 704         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
 705           (dolist (prov providers)
 706             (destructuring-bind
 707                 (srvname
 708                  &key
 709                  (port default-port)
 710                  (prio *default-mx-priority*)
 711                  (weight 0)
 712                  ip)
 713                 (listify prov)
 714               (let ((host (zone-parse-host srvname zname)))
 715                 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 716                 (rec :name rname
 717                      :data (list prio weight port host))))))))))
 718
 719 (defzoneparse :net (name data rec)
 720   ":net (NETWORK*)"
 721   (dolist (net (listify data))
 722     (let ((n (net-get-as-ipnet net)))
 723       (rec :name (zone-parse-host "net" name)
 724            :type :a
 725            :data (ipnet-net n))
 726       (rec :name (zone-parse-host "mask" name)
 727            :type :a
 728            :data (ipnet-mask n))
 729       (rec :name (zone-parse-host "bcast" name)
 730            :type :a
 731            :data (ipnet-broadcast n)))))
 732
 733 (defzoneparse (:rev :reverse) (name data rec)
 734   ":reverse ((NET :bytes BYTES) ZONE*)
 735
 736    Add a reverse record each host in the ZONEs (or all zones) that lies
 737    within NET.  The BYTES give the number of prefix labels generated; this
 738    defaults to the smallest number of bytes needed to enumerate the net."
 739   (setf data (listify data))
 740   (destructuring-bind (net &key bytes) (listify (car data))
 741     (setf net (zone-parse-net net name))
 742     (unless bytes
 743       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 744     (let ((seen (make-hash-table :test #'equal)))
 745       (dolist (z (or (cdr data)
 746                      (hash-table-keys *zones*)))
 747         (dolist (zr (zone-records (zone-find z)))
 748           (when (and (eq (zr-type zr) :a)
 749                      (zr-make-ptr-p zr)
 750                      (ipaddr-networkp (zr-data zr) net))
 751             (let ((name (string-downcase
 752                          (join-strings
 753                           #\.
 754                           (collecting ()
 755                             (dotimes (i bytes)
 756                               (collect (logand #xff (ash (zr-data zr)
 757                                                          (* -8 i)))))
 758                             (collect name))))))
 759               (unless (gethash name seen)
 760                 (rec :name name :type :ptr
 761                      :ttl (zr-ttl zr) :data (zr-name zr))
 762                 (setf (gethash name seen) t)))))))))
 763
 764 (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
 765   ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
 766
 767    Insert CNAME records for delegating a portion of the reverse-lookup
 768    namespace which doesn't align with an octet boundary.
 769
 770    The NET specifies the origin network, in which the reverse records
 771    naturally lie.  The BYTES are the number of labels to supply for each
 772    address; the default is the smallest number which suffices to enumerate
 773    the entire NET.  The TARGET-NETs are subnets of NET which are to be
 774    delegated.  The TARGET-ZONEs are the zones to which we are delegating
 775    authority for the reverse records: the default is to append labels for those
 776    octets of the subnet base address which are not the same in all address in
 777    the subnet."
 778   (setf data (listify data))
 779   (destructuring-bind (net &key bytes) (listify (car data))
 780     (setf net (zone-parse-net net name))
 781     (unless bytes
 782       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 783     (dolist (map (or (cdr data) (list (list net))))
 784       (destructuring-bind (tnets &optional tdom) (listify map)
 785         (dolist (tnet (listify tnets))
 786           (setf tnet (zone-parse-net tnet name))
 787           (unless (ipnet-subnetp net tnet)
 788             (error "~A is not a subnet of ~A."
 789                    (ipnet-pretty tnet)
 790                    (ipnet-pretty net)))
 791           (unless tdom
 792             (with-ipnet (net mask) tnet
 793               (setf tdom
 794                     (join-strings
 795                      #\.
 796                      (append (reverse (loop
 797                                        for i from (1- bytes) downto 0
 798                                        until (zerop (logand mask
 799                                                             (ash #xff
 800                                                                  (* 8 i))))
 801                                        collect (ldb (byte 8 (* i 8)) net)))
 802                              (list name))))))
 803           (setf tdom (string-downcase (stringify tdom)))
 804           (dotimes (i (ipnet-hosts tnet))
 805             (unless (zerop i)
 806               (let* ((addr (ipnet-host tnet i))
 807                      (tail (join-strings #\.
 808                                          (loop
 809                                           for i from 0 below bytes
 810                                           collect
 811                                           (logand #xff
 812                                                   (ash addr (* 8 i)))))))
 813                 (rec :name (format nil "~A.~A" tail name)
 814                      :type :cname
 815                      :data (format nil "~A.~A" tail tdom))))))))))
 816
 817 ;;;--------------------------------------------------------------------------
 818 ;;; Zone file output.
 819
 820 (export 'zone-write)
 821 (defgeneric zone-write (format zone stream)
 822   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
 823
 824 (defvar *writing-zone* nil
 825   "The zone currently being written.")
 826
 827 (defvar *zone-output-stream* nil
 828   "Stream to write zone data on.")
 829
 830 (defmethod zone-write :around (format zone stream)
 831   (declare (ignore format))
 832   (let ((*writing-zone* zone)
 833         (*zone-output-stream* stream))
 834     (call-next-method)))
 835
 836 (export 'zone-save)
 837 (defun zone-save (zones &key (format :bind))
 838   "Write the named ZONES to files.  If no zones are given, write all the
 839    zones."
 840   (unless zones
 841     (setf zones (hash-table-keys *zones*)))
 842   (safely (safe)
 843     (dolist (z zones)
 844       (let ((zz (zone-find z)))
 845         (unless zz
 846           (error "Unknown zone `~A'." z))
 847         (let ((stream (safely-open-output-stream safe
 848                                                  (zone-file-name z :zone))))
 849           (zone-write format zz stream))))))
 850
 851 ;;;--------------------------------------------------------------------------
 852 ;;; Bind format output.
 853
 854 (export 'bind-hostname)
 855 (defun bind-hostname (hostname)
 856   (if (not hostname)
 857       "@"
 858       (let* ((h (string-downcase (stringify hostname)))
 859              (hl (length h))
 860              (r (string-downcase (zone-name *writing-zone*)))
 861              (rl (length r)))
 862         (cond ((string= r h) "@")
 863               ((and (> hl rl)
 864                     (char= (char h (- hl rl 1)) #\.)
 865                     (string= h r :start1 (- hl rl)))
 866                (subseq h 0 (- hl rl 1)))
 867               (t (concatenate 'string h "."))))))
 868
 869 (defmethod zone-write ((format (eql :bind)) zone stream)
 870   (format stream "~
 871 ;;; Zone file `~(~A~)'
 872 ;;;   (generated ~A)
 873
 874 $ORIGIN ~0@*~(~A.~)
 875 $TTL ~2@*~D~2%"
 876             (zone-name zone)
 877             (iso-date :now :datep t :timep t)
 878             (zone-default-ttl zone))
 879   (let* ((soa (zone-soa zone))
 880          (admin (let* ((name (soa-admin soa))
 881                        (at (position #\@ name))
 882                        (copy (format nil "~(~A~)." name)))
 883                   (when at
 884                     (setf (char copy at) #\.))
 885                   copy)))
 886       (format stream "~
 887 ~A~30TIN SOA~40T~A ~A (
 888 ~45T~10D~60T ;serial
 889 ~45T~10D~60T ;refresh
 890 ~45T~10D~60T ;retry
 891 ~45T~10D~60T ;expire
 892 ~45T~10D )~60T ;min-ttl~2%"
 893               (bind-hostname (zone-name zone))
 894               (bind-hostname (soa-source soa))
 895               admin
 896               (soa-serial soa)
 897               (soa-refresh soa)
 898               (soa-retry soa)
 899               (soa-expire soa)
 900               (soa-min-ttl soa)))
 901   (dolist (zr (zone-records zone))
 902     (bind-record (zr-type zr) zr)))
 903
 904 (export 'bind-record)
 905 (defgeneric bind-record (type zr))
 906
 907 (export 'bind-format-record)
 908 (defun bind-format-record (name ttl type format args)
 909   (format *zone-output-stream*
 910           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
 911           (bind-hostname name)
 912           (and (/= ttl (zone-default-ttl *writing-zone*))
 913                ttl)
 914           (string-upcase (symbol-name type))
 915           format args))
 916
 917 (defmethod bind-record (type zr)
 918   (destructuring-bind (format &rest args)
 919       (bind-record-format-args type (zr-data zr))
 920     (bind-format-record (zr-name zr)
 921                         (zr-ttl zr)
 922                         (bind-record-type type)
 923                         format args)))
 924
 925 (export 'bind-record-type)
 926 (defgeneric bind-record-type (type)
 927   (:method (type) type))
 928
 929 (export 'bind-record-format-args)
 930 (defgeneric bind-record-format-args (type data)
 931   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
 932   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
 933   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
 934   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
 935   (:method ((type (eql :mx)) data)
 936     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
 937   (:method ((type (eql :srv)) data)
 938     (destructuring-bind (prio weight port host) data
 939       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
 940   (:method ((type (eql :txt)) data)
 941     (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
 942           (mapcar #'stringify (listify data)))))
 943
 944 ;;;----- That's all, folks --------------------------------------------------