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