chiark - git - mdw - zone/blob - zone.lisp

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