mdw@git.distorted.org.uk Git - 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 (defun map-host-addresses (func addr &key (family *address-family*))
 584   "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
 585
 586   (dolist (a (host-addrs (host-parse addr family)))
 587     (funcall func a)))
 588
 589 (defmacro do-host ((addr spec &key (family *address-family*)) &body body)
 590   "Evaluate BODY, binding ADDR to each address denoted by SPEC."
 591   `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
 592      ,@body))
 593
 594 (export 'zone-set-address)
 595 (defun zone-set-address (rec addrspec &rest args
 596                          &key (family *address-family*) name ttl make-ptr-p)
 597   "Write records (using REC) defining addresses for ADDRSPEC."
 598   (declare (ignore name ttl make-ptr-p))
 599   (let ((key-args (loop for (k v) on args by #'cddr
 600                         unless (eq k :family)
 601                         nconc (list k v))))
 602     (do-host (addr addrspec :family family)
 603       (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
 604
 605 ;;;--------------------------------------------------------------------------
 606 ;;; Zone record parsers.
 607
 608 (defzoneparse :a (name data rec)
 609   ":a IPADDR"
 610   (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
 611
 612 (defzoneparse :aaaa (name data rec)
 613   ":aaaa IPADDR"
 614   (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
 615
 616 (defzoneparse :addr (name data rec)
 617   ":addr IPADDR"
 618   (zone-set-address #'rec data :make-ptr-p t))
 619
 620 (defzoneparse :svc (name data rec)
 621   ":svc IPADDR"
 622   (zone-set-address #'rec data))
 623
 624 (defzoneparse :ptr (name data rec :zname zname)
 625   ":ptr HOST"
 626   (rec :data (zone-parse-host data zname)))
 627
 628 (defzoneparse :cname (name data rec :zname zname)
 629   ":cname HOST"
 630   (rec :data (zone-parse-host data zname)))
 631
 632 (defzoneparse :txt (name data rec)
 633   ":txt TEXT"
 634   (rec :data data))
 635
 636 (export '*dkim-pathname-defaults*)
 637 (defvar *dkim-pathname-defaults*
 638   (make-pathname :directory '(:relative "keys")
 639                  :type "dkim"))
 640
 641 (defzoneparse :dkim (name data rec)
 642   ":dkim (KEYFILE {:TAG VALUE}*)"
 643   (destructuring-bind (file &rest plist) (listify data)
 644     (let ((things nil) (out nil))
 645       (labels ((flush ()
 646                  (when out
 647                    (push (get-output-stream-string out) things)
 648                    (setf out nil)))
 649                (emit (text)
 650                  (let ((len (length text)))
 651                    (when (and out (> (+ (file-position out)
 652                                         (length text))
 653                                      64))
 654                      (flush))
 655                    (when (plusp len)
 656                      (cond ((< len 64)
 657                             (unless out (setf out (make-string-output-stream)))
 658                             (write-string text out))
 659                            (t
 660                             (do ((i 0 j)
 661                                  (j 64 (+ j 64)))
 662                                 ((>= i len))
 663                               (push (subseq text i (min j len)) things))))))))
 664         (do ((p plist (cddr p)))
 665             ((endp p))
 666           (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
 667         (emit (with-output-to-string (out)
 668                 (write-string "p=" out)
 669                 (when file
 670                   (with-open-file
 671                       (in (merge-pathnames file *dkim-pathname-defaults*))
 672                     (loop
 673                       (when (string= (read-line in)
 674                                      "-----BEGIN PUBLIC KEY-----")
 675                         (return)))
 676                     (loop
 677                       (let ((line (read-line in)))
 678                         (if (string= line "-----END PUBLIC KEY-----")
 679                             (return)
 680                             (write-string line out)))))))))
 681       (rec :type :txt
 682            :data (nreverse things)))))
 683
 684 (eval-when (:load-toplevel :execute)
 685   (dolist (item '((sshfp-algorithm rsa 1)
 686                   (sshfp-algorithm dsa 2)
 687                   (sshfp-algorithm ecdsa 3)
 688                   (sshfp-type sha-1 1)
 689                   (sshfp-type sha-256 2)))
 690     (destructuring-bind (prop sym val) item
 691       (setf (get sym prop) val)
 692       (export sym))))
 693
 694 (export '*sshfp-pathname-defaults*)
 695 (defvar *sshfp-pathname-defaults*
 696   (make-pathname :directory '(:relative "keys")
 697                  :type "sshfp"))
 698
 699 (defzoneparse :sshfp (name data rec)
 700   ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
 701   (if (stringp data)
 702       (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
 703         (loop (let ((line (read-line in nil)))
 704                 (unless line (return))
 705                 (let ((words (str-split-words line)))
 706                   (pop words)
 707                   (when (string= (car words) "IN") (pop words))
 708                   (unless (and (string= (car words) "SSHFP")
 709                                (= (length words) 4))
 710                     (error "Invalid SSHFP record."))
 711                   (pop words)
 712                   (destructuring-bind (alg type fpr) words
 713                     (rec :data (list (parse-integer alg)
 714                                      (parse-integer type)
 715                                      fpr)))))))
 716       (flet ((lookup (what prop)
 717                (etypecase what
 718                  (fixnum what)
 719                  (symbol (or (get what prop)
 720                              (error "~S is not a known ~A" what prop))))))
 721         (dolist (item (listify data))
 722           (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
 723               (listify item)
 724             (rec :data (list (lookup alg 'sshfp-algorithm)
 725                              (lookup type 'sshfp-type)
 726                              fpr)))))))
 727
 728 (defzoneparse :mx (name data rec :zname zname)
 729   ":mx ((HOST :prio INT :ip IPADDR)*)"
 730   (dolist (mx (listify data))
 731     (destructuring-bind
 732         (mxname &key (prio *default-mx-priority*) ip)
 733         (listify mx)
 734       (let ((host (zone-parse-host mxname zname)))
 735         (when ip (zone-set-address #'rec ip :name host))
 736         (rec :data (cons host prio))))))
 737
 738 (defzoneparse :ns (name data rec :zname zname)
 739   ":ns ((HOST :ip IPADDR)*)"
 740   (dolist (ns (listify data))
 741     (destructuring-bind
 742         (nsname &key ip)
 743         (listify ns)
 744       (let ((host (zone-parse-host nsname zname)))
 745         (when ip (zone-set-address #'rec ip :name host))
 746         (rec :data host)))))
 747
 748 (defzoneparse :alias (name data rec :zname zname)
 749   ":alias (LABEL*)"
 750   (dolist (a (listify data))
 751     (rec :name (zone-parse-host a zname)
 752          :type :cname
 753          :data name)))
 754
 755 (defzoneparse :srv (name data rec :zname zname)
 756   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
 757   (dolist (srv data)
 758     (destructuring-bind (servopts &rest providers) srv
 759       (destructuring-bind
 760           (service &key ((:port default-port)) (protocol :tcp))
 761           (listify servopts)
 762         (unless default-port
 763           (let ((serv (serv-by-name service protocol)))
 764             (setf default-port (and serv (serv-port serv)))))
 765         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
 766           (dolist (prov providers)
 767             (destructuring-bind
 768                 (srvname
 769                  &key
 770                  (port default-port)
 771                  (prio *default-mx-priority*)
 772                  (weight 0)
 773                  ip)
 774                 (listify prov)
 775               (let ((host (zone-parse-host srvname zname)))
 776                 (when ip (zone-set-address #'rec ip :name host))
 777                 (rec :name rname
 778                      :data (list prio weight port host))))))))))
 779
 780 (defzoneparse :net (name data rec)
 781   ":net (NETWORK*)"
 782   (dolist (net (listify data))
 783     (dolist (ipn (net-ipnets (net-must-find net)))
 784       (let* ((base (ipnet-net ipn))
 785              (rrtype (ipaddr-rrtype base)))
 786         (flet ((frob (kind addr)
 787                  (when addr
 788                    (rec :name (zone-parse-host kind name)
 789                         :type rrtype
 790                         :data addr))))
 791           (frob "net" base)
 792           (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
 793           (frob "bcast" (ipnet-broadcast ipn)))))))
 794
 795 (defzoneparse (:rev :reverse) (name data rec)
 796   ":reverse ((NET &key :prefix-bits :family) ZONE*)
 797
 798    Add a reverse record each host in the ZONEs (or all zones) that lies
 799    within NET."
 800   (setf data (listify data))
 801   (destructuring-bind (net &key prefix-bits (family *address-family*))
 802       (listify (car data))
 803
 804     (dolist (ipn (net-parse-to-ipnets net family))
 805       (let* ((seen (make-hash-table :test #'equal))
 806              (width (ipnet-width ipn))
 807              (frag-len (if prefix-bits (- width prefix-bits)
 808                            (ipnet-changeable-bits width (ipnet-mask ipn)))))
 809         (dolist (z (or (cdr data) (hash-table-keys *zones*)))
 810           (dolist (zr (zone-records (zone-find z)))
 811             (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
 812                        (zr-make-ptr-p zr)
 813                        (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
 814               (let* ((frag (reverse-domain-fragment (zr-data zr)
 815                                                     0 frag-len))
 816                      (name (concatenate 'string frag "." name)))
 817                 (unless (gethash name seen)
 818                   (rec :name name :type :ptr
 819                        :ttl (zr-ttl zr) :data (zr-name zr))
 820                   (setf (gethash name seen) t))))))))))
 821
 822 (defzoneparse (:multi) (name data rec :zname zname :ttl ttl)
 823   ":multi (((NET*) &key :start :end :family :suffix) . REC)
 824
 825    Output multiple records covering a portion of the reverse-resolution
 826    namespace corresponding to the particular NETs.  The START and END bounds
 827    default to the most significant variable component of the
 828    reverse-resolution domain.
 829
 830    The REC tail is a sequence of record forms (as handled by
 831    `zone-process-records') to be emitted for each covered address.  Within
 832    the bodies of these forms, the symbol `*' will be replaced by the
 833    domain-name fragment corresponding to the current host, optionally
 834    followed by the SUFFIX.
 835
 836    Examples:
 837
 838         (:multi ((delegated-subnet :start 8)
 839                  :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
 840
 841         (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
 842                  :cname *))
 843
 844    Obviously, nested `:multi' records won't work well."
 845
 846   (destructuring-bind (nets &key start end (family *address-family*) suffix)
 847       (listify (car data))
 848     (dolist (net (listify nets))
 849       (dolist (ipn (net-parse-to-ipnets net family))
 850         (let* ((addr (ipnet-net ipn))
 851                (width (ipaddr-width addr))
 852                (comp-width (reverse-domain-component-width addr))
 853                (end (round-up (or end
 854                                   (ipnet-changeable-bits width
 855                                                          (ipnet-mask ipn)))
 856                               comp-width))
 857                (start (round-down (or start (- end comp-width))
 858                                   comp-width))
 859                (map (ipnet-host-map ipn)))
 860           (multiple-value-bind (host-step host-limit)
 861               (ipnet-index-bounds map start end)
 862             (do ((index 0 (+ index host-step)))
 863                 ((> index host-limit))
 864               (let* ((addr (ipnet-index-host map index))
 865                      (frag (reverse-domain-fragment addr start end))
 866                      (target (concatenate 'string
 867                                           (zone-make-name
 868                                            (if (not suffix) frag
 869                                                (concatenate 'string
 870                                                             frag "." suffix))
 871                                            zname)
 872                                           ".")))
 873                 (dolist (zr (zone-parse-records (zone-make-name frag zname)
 874                                                 ttl
 875                                                 (subst target '*
 876                                                        (cdr data))))
 877                   (rec :name (zr-name zr)
 878                        :type (zr-type zr)
 879                        :data (zr-data zr)
 880                        :ttl (zr-ttl zr)
 881                        :make-ptr-p (zr-make-ptr-p zr)))))))))))
 882
 883 ;;;--------------------------------------------------------------------------
 884 ;;; Zone file output.
 885
 886 (export 'zone-write)
 887 (defgeneric zone-write (format zone stream)
 888   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
 889
 890 (defvar *writing-zone* nil
 891   "The zone currently being written.")
 892
 893 (defvar *zone-output-stream* nil
 894   "Stream to write zone data on.")
 895
 896 (defmethod zone-write :around (format zone stream)
 897   (declare (ignore format))
 898   (let ((*writing-zone* zone)
 899         (*zone-output-stream* stream))
 900     (call-next-method)))
 901
 902 (export 'zone-save)
 903 (defun zone-save (zones &key (format :bind))
 904   "Write the named ZONES to files.  If no zones are given, write all the
 905    zones."
 906   (unless zones
 907     (setf zones (hash-table-keys *zones*)))
 908   (safely (safe)
 909     (dolist (z zones)
 910       (let ((zz (zone-find z)))
 911         (unless zz
 912           (error "Unknown zone `~A'." z))
 913         (let ((stream (safely-open-output-stream safe
 914                                                  (zone-file-name z :zone))))
 915           (zone-write format zz stream))))))
 916
 917 ;;;--------------------------------------------------------------------------
 918 ;;; Bind format output.
 919
 920 (export 'bind-hostname)
 921 (defun bind-hostname (hostname)
 922   (if (not hostname)
 923       "@"
 924       (let* ((h (string-downcase (stringify hostname)))
 925              (hl (length h))
 926              (r (string-downcase (zone-name *writing-zone*)))
 927              (rl (length r)))
 928         (cond ((string= r h) "@")
 929               ((and (> hl rl)
 930                     (char= (char h (- hl rl 1)) #\.)
 931                     (string= h r :start1 (- hl rl)))
 932                (subseq h 0 (- hl rl 1)))
 933               (t (concatenate 'string h "."))))))
 934
 935 (export 'bind-record)
 936 (defgeneric bind-record (type zr))
 937
 938 (defmethod zone-write ((format (eql :bind)) zone stream)
 939   (format stream "~
 940 ;;; Zone file `~(~A~)'
 941 ;;;   (generated ~A)
 942
 943 $ORIGIN ~0@*~(~A.~)
 944 $TTL ~2@*~D~2%"
 945             (zone-name zone)
 946             (iso-date :now :datep t :timep t)
 947             (zone-default-ttl zone))
 948   (let* ((soa (zone-soa zone))
 949          (admin (let* ((name (soa-admin soa))
 950                        (at (position #\@ name))
 951                        (copy (format nil "~(~A~)." name)))
 952                   (when at
 953                     (setf (char copy at) #\.))
 954                   copy)))
 955       (format stream "~
 956 ~A~30TIN SOA~40T~A ~A (
 957 ~45T~10D~60T ;serial
 958 ~45T~10D~60T ;refresh
 959 ~45T~10D~60T ;retry
 960 ~45T~10D~60T ;expire
 961 ~45T~10D )~60T ;min-ttl~2%"
 962               (bind-hostname (zone-name zone))
 963               (bind-hostname (soa-source soa))
 964               admin
 965               (soa-serial soa)
 966               (soa-refresh soa)
 967               (soa-retry soa)
 968               (soa-expire soa)
 969               (soa-min-ttl soa)))
 970   (dolist (zr (zone-records zone))
 971     (bind-record (zr-type zr) zr)))
 972
 973 (export 'bind-format-record)
 974 (defun bind-format-record (name ttl type format args)
 975   (format *zone-output-stream*
 976           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
 977           (bind-hostname name)
 978           (and (/= ttl (zone-default-ttl *writing-zone*))
 979                ttl)
 980           (string-upcase (symbol-name type))
 981           format args))
 982
 983 (export 'bind-record-type)
 984 (defgeneric bind-record-type (type)
 985   (:method (type) type))
 986
 987 (export 'bind-record-format-args)
 988 (defgeneric bind-record-format-args (type data)
 989   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
 990   (:method ((type (eql :aaaa)) data) (list "~A" (ipaddr-string data)))
 991   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
 992   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
 993   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
 994   (:method ((type (eql :mx)) data)
 995     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
 996   (:method ((type (eql :srv)) data)
 997     (destructuring-bind (prio weight port host) data
 998       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
 999   (:method ((type (eql :sshfp)) data)
1000     (cons "~2D ~2D ~A" data))
1001   (:method ((type (eql :txt)) data)
1002     (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
1003           (mapcar #'stringify (listify data)))))
1004
1005 (defmethod bind-record (type zr)
1006   (destructuring-bind (format &rest args)
1007       (bind-record-format-args type (zr-data zr))
1008     (bind-format-record (zr-name zr)
1009                         (zr-ttl zr)
1010                         (bind-record-type type)
1011                         format args)))
1012
1013 ;;;----- That's all, folks --------------------------------------------------