mdw@git.distorted.org.uk Git - zone/blob - zone.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; DNS zone generation
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Packaging.
  28
  29 (defpackage #:zone
  30   (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:mdw.safely)
  31   (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
  32            #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
  33              #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
  34              #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
  35              #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
  36            #:host-find# #:host-create #:defhost #:parse-ipaddr
  37              #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
  38              #:net-next-host #:net-host
  39            #:soa #:mx #:zone #:zone-record #:zone-subdomain
  40            #:*default-zone-source* #:*default-zone-refresh*
  41              #:*default-zone-retry* #:*default-zone-expire*
  42              #:*default-zone-min-ttl* #:*default-zone-ttl*
  43              #:*default-mx-priority* #:*default-zone-admin*
  44              #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
  45              #:defrevzone #:zone-save
  46            #:defzoneparse #:zone-parse-host
  47            #:timespec-seconds #:make-zone-serial))
  48
  49 (in-package #:zone)
  50
  51 ;;;--------------------------------------------------------------------------
  52 ;;; Basic types.
  53
  54 (defun mask (n)
  55   "Return 2^N - 1: i.e., a mask of N set bits."
  56   (1- (ash 1 n)))
  57 (deftype u32 ()
  58   "The type of unsigned 32-bit values."
  59   '(unsigned-byte 32))
  60 (deftype ipaddr ()
  61   "The type of IP (version 4) addresses."
  62   'u32)
  63
  64 ;;;--------------------------------------------------------------------------
  65 ;;; Various random utilities.
  66
  67 (defun to-integer (x)
  68   "Convert X to an integer in the most straightforward way."
  69   (floor (rational x)))
  70
  71 (defun from-mixed-base (base val)
  72   "BASE is a list of the ranges for the `digits' of a mixed-base
  73 representation.  Convert VAL, a list of digits, into an integer."
  74   (do ((base base (cdr base))
  75        (val (cdr val) (cdr val))
  76        (a (car val) (+ (* a (car base)) (car val))))
  77       ((or (null base) (null val)) a)))
  78
  79 (defun to-mixed-base (base val)
  80   "BASE is a list of the ranges for the `digits' of a mixed-base
  81 representation.  Convert VAL, an integer, into a list of digits."
  82   (let ((base (reverse base))
  83         (a nil))
  84     (loop
  85       (unless base
  86         (push val a)
  87         (return a))
  88       (multiple-value-bind (q r) (floor val (pop base))
  89         (push r a)
  90         (setf val q)))))
  91
  92 (defun timespec-seconds (ts)
  93   "Convert a timespec TS to seconds.  A timespec may be a real count of
  94 seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
  95 units."
  96   (cond ((null ts) 0)
  97         ((realp ts) (floor ts))
  98         ((atom ts)
  99          (error "Unknown timespec format ~A" ts))
 100         ((null (cdr ts))
 101          (timespec-seconds (car ts)))
 102         (t (+ (to-integer (* (car ts)
 103                              (case (intern (string-upcase
 104                                             (stringify (cadr ts)))
 105                                            '#:zone)
 106                                ((s sec secs second seconds) 1)
 107                                ((m min mins minute minutes) 60)
 108                                ((h hr hrs hour hours) #.(* 60 60))
 109                                ((d dy dys day days) #.(* 24 60 60))
 110                                ((w wk wks week weeks) #.(* 7 24 60 60))
 111                                ((y yr yrs year years) #.(* 365 24 60 60))
 112                                (t (error "Unknown time unit ~A"
 113                                          (cadr ts))))))
 114               (timespec-seconds (cddr ts))))))
 115
 116 (defun hash-table-keys (ht)
 117   "Return a list of the keys in hashtable HT."
 118   (collecting ()
 119     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 120
 121 (defun iso-date (&optional time &key datep timep (sep #\ ))
 122   "Construct a textual date or time in ISO format.  The TIME is the universal
 123 time to convert, which defaults to now; DATEP is whether to emit the date;
 124 TIMEP is whether to emit the time, and SEP (default is space) is how to
 125 separate the two."
 126   (multiple-value-bind
 127       (sec min hr day mon yr dow dstp tz)
 128       (decode-universal-time (if (or (null time) (eq time :now))
 129                                  (get-universal-time)
 130                                  time))
 131     (declare (ignore dow dstp tz))
 132     (with-output-to-string (s)
 133       (when datep
 134         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 135         (when timep
 136           (write-char sep s)))
 137       (when timep
 138         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 139
 140 ;;;--------------------------------------------------------------------------
 141 ;;; Simple messing with IP addresses.
 142
 143 (defun string-ipaddr (str &key (start 0) (end nil))
 144   "Parse STR as an IP address in dotted-quad form and return the integer
 145 equivalent.  STR may be anything at all: it's converted as if by
 146 `stringify'.  The START and END arguments may be used to parse out a
 147 substring."
 148   (setf str (stringify str))
 149   (unless end
 150     (setf end (length str)))
 151   (let ((addr 0) (noct 0))
 152     (loop
 153       (let* ((pos (position #\. str :start start :end end))
 154              (i (parse-integer str :start start :end (or pos end))))
 155         (unless (<= 0 i 256)
 156           (error "IP address octet out of range"))
 157         (setf addr (+ (* addr 256) i))
 158         (incf noct)
 159         (unless pos
 160           (return))
 161         (setf start (1+ pos))))
 162     (unless (= noct 4)
 163       (error "Wrong number of octets in IP address"))
 164     addr))
 165
 166 (defun ipaddr-byte (ip n)
 167   "Return byte N (from most significant downwards) of an IP address."
 168   (assert (<= 0 n 3))
 169   (logand #xff (ash ip (* -8 (- 3 n)))))
 170
 171 (defun ipaddr-string (ip)
 172   "Transform the address IP into a string in dotted-quad form."
 173   (check-type ip ipaddr)
 174   (join-strings #\. (collecting ()
 175                       (dotimes (i 4)
 176                         (collect (ipaddr-byte ip i))))))
 177
 178 (defun ipaddrp (ip)
 179   "Answer true if IP is a valid IP address in integer form."
 180   (typep ip 'ipaddr))
 181
 182 (defun ipaddr (ip)
 183   "Convert IP to an IP address.  If it's an integer, return it unchanged;
 184 otherwise convert by `string-ipaddr'."
 185   (typecase ip
 186     (ipaddr ip)
 187     (t (string-ipaddr ip))))
 188
 189 ;;;--------------------------------------------------------------------------
 190 ;;; Netmasks.
 191
 192 (defun integer-netmask (i)
 193   "Given an integer I, return a netmask with its I top bits set."
 194   (- (ash 1 32) (ash 1 (- 32 i))))
 195
 196 (defun ipmask (ip)
 197   "Transform IP into a netmask.  If it's a small integer then it's converted
 198 by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
 199 `ipaddr'."
 200   (typecase ip
 201     (null (mask 32))
 202     ((integer 0 32) (integer-netmask ip))
 203     (t (ipaddr ip))))
 204
 205 (defun ipmask-cidl-slash (mask)
 206   "Given a netmask MASK, return an integer N such that (integer-netmask N) =
 207 MASK, or nil if this is impossible."
 208   (dotimes (i 33)
 209     (when (= mask (integer-netmask i))
 210       (return i))))
 211
 212 ;;;--------------------------------------------------------------------------
 213 ;;; Networks: pairing an address and netmask.
 214
 215 (defun make-ipnet (net mask)
 216   "Construct an IP-network object given the NET and MASK; these are
 217 transformed as though by `ipaddr' and `ipmask'."
 218   (let ((net (ipaddr net))
 219         (mask (ipmask mask)))
 220     (cons (logand net mask) mask)))
 221
 222 (defun string-ipnet (str &key (start 0) (end nil))
 223   "Parse an IP-network from the string STR."
 224   (setf str (stringify str))
 225   (unless end (setf end (length str)))
 226   (let ((sl (position #\/ str :start start :end end)))
 227     (if sl
 228         (make-ipnet (parse-ipaddr (subseq str start sl))
 229                     (if (find #\. str :start (1+ sl) :end end)
 230                         (string-ipaddr str :start (1+ sl) :end end)
 231                         (integer-netmask (parse-integer str
 232                                                         :start (1+ sl)
 233                                                         :end end))))
 234         (make-ipnet (parse-ipaddr (subseq str start end))
 235                     (integer-netmask 32)))))
 236
 237 (defun ipnet (net &optional mask)
 238   "Construct an IP-network object from the given arguments.  A number of
 239 forms are acceptable:
 240
 241   * NET MASK -- as for `make-ipnet'.
 242   * ADDR -- a single address (equivalent to ADDR 32)
 243   * (NET . MASK|nil) -- a single-object representation.
 244   * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
 245   (cond (mask (make-ipnet net mask))
 246         ((or (stringp net) (symbolp net)) (string-ipnet net))
 247         (t (apply #'make-ipnet (pairify net 32)))))
 248
 249 (defun ipnet-net (ipn)
 250   "Return the base network address of IPN."
 251   (car ipn))
 252
 253 (defun ipnet-mask (ipn)
 254   "Return the netmask of IPN."
 255   (cdr ipn))
 256
 257 (defmacro with-ipnet ((net mask) ipn &body body)
 258   "Evaluate BODY with NET and MASK bound to the base address and netmask of
 259 IPN.  Either NET or MASK (or, less usefully, both) may be nil if not wanted."
 260   (with-gensyms tmp
 261     `(let ((,tmp ,ipn))
 262        (let (,@(and net `((,net (ipnet-net ,tmp))))
 263              ,@(and mask `((,mask (ipnet-mask ,tmp)))))
 264          ,@body))))
 265
 266 (defun ipnet-pretty (ipn)
 267   "Convert IPN to a pretty cons-cell form."
 268   (with-ipnet (net mask) ipn
 269     (cons (ipaddr-string net)
 270           (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
 271
 272 (defun ipnet-string (ipn)
 273   "Convert IPN to a string."
 274   (with-ipnet (net mask) ipn
 275     (format nil "~A/~A"
 276             (ipaddr-string net)
 277             (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
 278
 279 (defun ipnet-broadcast (ipn)
 280   "Return the broadcast address for the network IPN."
 281   (with-ipnet (net mask) ipn
 282     (logior net (logxor (mask 32) mask))))
 283
 284 (defun ipnet-hosts (ipn)
 285   "Return the number of available addresses in network IPN."
 286   (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
 287
 288 (defun ipnet-host (ipn host)
 289   "Return the address of the given HOST in network IPN.  This works even with
 290 a non-contiguous netmask."
 291   (check-type host u32)
 292   (with-ipnet (net mask) ipn
 293     (let ((i 0) (m 1) (a net) (h host))
 294       (loop
 295         (when (>= i 32)
 296           (error "Host index ~D out of range for network ~A"
 297                  host (ipnet-pretty ipn)))
 298         (cond ((zerop h)
 299                (return a))
 300               ((logbitp i mask)
 301                (setf h (ash h 1)))
 302               (t
 303                (setf a (logior a (logand m h)))
 304                (setf h (logandc2 h m))))
 305         (setf m (ash m 1))
 306         (incf i)))))
 307
 308 (defun ipaddr-networkp (ip ipn)
 309   "Returns true if address IP is within network IPN."
 310   (with-ipnet (net mask) ipn
 311     (= net (logand ip mask))))
 312
 313 (defun ipnet-subnetp (ipn subn)
 314   "Returns true if SUBN is a (non-strict) subnet of IPN."
 315   (with-ipnet (net mask) ipn
 316     (with-ipnet (subnet submask) subn
 317       (and (= net (logand subnet mask))
 318            (= submask (logior mask submask))))))
 319
 320 (defun ipnet-changeable-bytes (mask)
 321   "Answers how many low-order bytes of MASK are (entirely or partially)
 322 changeable.  This is used when constructing reverse zones."
 323   (dotimes (i 4 4)
 324     (when (/= (ipaddr-byte mask i) 255)
 325       (return (- 4 i)))))
 326
 327 ;;;--------------------------------------------------------------------------
 328 ;;; Name resolution.
 329
 330 #+cmu
 331 (defun resolve-hostname (name)
 332   "Resolve a hostname to an IP address using the DNS, or return nil."
 333   (let ((he (ext:lookup-host-entry name)))
 334     (and he
 335          (ext:host-entry-addr he))))
 336
 337 #+cmu
 338 (defun canonify-hostname (name)
 339   "Resolve a hostname to canonical form using the DNS, or return nil."
 340   (let ((he (ext:lookup-host-entry name)))
 341     (and he
 342          (ext:host-entry-name he))))
 343
 344 ;;;--------------------------------------------------------------------------
 345 ;;; Host names and specifiers.
 346
 347 (defun parse-ipaddr (addr)
 348   "Convert the string ADDR into an IP address: tries all sorts of things:
 349
 350   (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
 351     INDEX is an index or one of the special symbols understood by net-host,
 352     and defaults to :next
 353   INTEGER -- an integer IP address
 354   IPADDR -- an IP address in dotted-quad form
 355   HOST -- a host name defined by defhost
 356   DNSNAME -- a name string to look up in the DNS"
 357   (cond ((listp addr)
 358          (destructuring-bind
 359              (net host)
 360              (pairify addr :next)
 361            (net-host (or (net-find net)
 362                          (error "Network ~A not found" net))
 363                      host)))
 364         ((ipaddrp addr) addr)
 365         (t
 366          (setf addr (string-downcase (stringify addr)))
 367          (or (host-find addr)
 368              (and (plusp (length addr))
 369                   (digit-char-p (char addr 0))
 370                   (string-ipaddr addr))
 371              (resolve-hostname (stringify addr))
 372              (error "Host name ~A unresolvable" addr)))))
 373
 374 (defvar *hosts* (make-hash-table :test #'equal)
 375   "The table of known hostnames.")
 376
 377 (defun host-find (name)
 378   "Find a host by NAME."
 379   (gethash (string-downcase (stringify name)) *hosts*))
 380
 381 (defun (setf host-find) (addr name)
 382   "Make NAME map to ADDR (must be an ipaddr in integer form)."
 383   (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
 384
 385 (defun host-create (name addr)
 386   "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
 387   (setf (host-find name) (parse-ipaddr addr)))
 388
 389 (defmacro defhost (name addr)
 390   "Main host definition macro.  Neither NAME nor ADDR is evaluated."
 391   `(progn
 392      (host-create ',name ',addr)
 393      ',name))
 394
 395 ;;;--------------------------------------------------------------------------
 396 ;;; Network names and specifiers.
 397
 398 (defstruct (net (:predicate netp))
 399   "A network structure.  Slots:
 400
 401 NAME       The network's name, as a string
 402 IPNET      The network base address and mask
 403 HOSTS      Number of hosts in the network
 404 NEXT       Index of the next unassigned host"
 405   name
 406   ipnet
 407   hosts
 408   next)
 409
 410 (defvar *networks* (make-hash-table :test #'equal)
 411   "The table of known networks.")
 412
 413 (defun net-find (name)
 414   "Find a network by NAME."
 415   (gethash (string-downcase (stringify name)) *networks*))
 416
 417 (defun (setf net-find) (net name)
 418   "Make NAME map to NET."
 419   (setf (gethash (string-downcase (stringify name)) *networks*) net))
 420
 421 (defun net-get-as-ipnet (form)
 422   "Transform FORM into an ipnet.  FORM may be a network name, or something
 423 acceptable to the ipnet function."
 424   (let ((net (net-find form)))
 425     (if net (net-ipnet net)
 426         (ipnet form))))
 427
 428 (defun net-create (name &rest args)
 429   "Construct a new network called NAME and add it to the map.  The ARGS
 430 describe the new network, in a form acceptable to the ipnet function."
 431   (let ((ipn (apply #'ipnet args)))
 432     (setf (net-find name)
 433           (make-net :name (string-downcase (stringify name))
 434                     :ipnet ipn
 435                     :hosts (ipnet-hosts ipn)
 436                     :next 1))))
 437
 438 (defmacro defnet (name &rest args)
 439   "Main network definition macro.  Neither NAME nor any of the ARGS is
 440 evaluated."
 441   `(progn
 442      (net-create ',name ,@(mapcar (lambda (x) `',x) args))
 443      ',name))
 444
 445 (defun net-next-host (net)
 446   "Given a NET, return the IP address (as integer) of the next available
 447 address in the network."
 448   (unless (< (net-next net) (net-hosts net))
 449     (error "No more hosts left in network ~A" (net-name net)))
 450   (let ((next (net-next net)))
 451     (incf (net-next net))
 452     (net-host net next)))
 453
 454 (defun net-host (net host)
 455   "Return the given HOST on the NEXT.  HOST may be an index (in range, of
 456 course), or one of the keywords:
 457 :NEXT       next host, as by net-next-host
 458 :NET        network base address
 459 :BROADCAST  network broadcast address"
 460   (case host
 461     (:next (net-next-host net))
 462     (:net (ipnet-net (net-ipnet net)))
 463     (:broadcast (ipnet-broadcast (net-ipnet net)))
 464     (t (ipnet-host (net-ipnet net) host))))
 465
 466 ;;;--------------------------------------------------------------------------
 467 ;;; Zone types.
 468
 469 (defstruct (soa (:predicate soap))
 470   "Start-of-authority record information."
 471   source
 472   admin
 473   refresh
 474   retry
 475   expire
 476   min-ttl
 477   serial)
 478
 479 (defstruct (mx (:predicate mxp))
 480   "Mail-exchange record information."
 481   priority
 482   domain)
 483
 484 (defstruct (zone (:predicate zonep))
 485   "Zone information."
 486   soa
 487   default-ttl
 488   name
 489   records)
 490
 491 ;;;--------------------------------------------------------------------------
 492 ;;; Zone defaults.  It is intended that scripts override these.
 493
 494 (defvar *default-zone-source*
 495   (let ((hn (unix:unix-gethostname)))
 496     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 497   "The default zone source: the current host's name.")
 498
 499 (defvar *default-zone-refresh* (* 24 60 60)
 500   "Default zone refresh interval: one day.")
 501
 502 (defvar *default-zone-admin* nil
 503   "Default zone administrator's email address.")
 504
 505 (defvar *default-zone-retry* (* 60 60)
 506   "Default znoe retry interval: one hour.")
 507
 508 (defvar *default-zone-expire* (* 14 24 60 60)
 509   "Default zone expiry time: two weeks.")
 510
 511 (defvar *default-zone-min-ttl* (* 4 60 60)
 512   "Default zone minimum TTL/negative TTL: four hours.")
 513
 514 (defvar *default-zone-ttl* (* 8 60 60)
 515   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 516
 517 (defvar *default-mx-priority* 50
 518   "Default MX priority.")
 519
 520 ;;;--------------------------------------------------------------------------
 521 ;;; Serial numbering.
 522
 523 (defun make-zone-serial (name)
 524   "Given a zone NAME, come up with a new serial number.  This will (very
 525 carefully) update a file ZONE.serial in the current directory."
 526   (let* ((file (format nil "~(~A~).serial" name))
 527          (last (with-open-file (in file
 528                                    :direction :input
 529                                    :if-does-not-exist nil)
 530                  (if in (read in)
 531                      (list 0 0 0 0))))
 532          (now (multiple-value-bind
 533                   (sec min hr dy mon yr dow dstp tz)
 534                   (get-decoded-time)
 535                 (declare (ignore sec min hr dow dstp tz))
 536                 (list dy mon yr)))
 537          (seq (cond ((not (equal now (cdr last))) 0)
 538                     ((< (car last) 99) (1+ (car last)))
 539                     (t (error "Run out of sequence numbers for ~A" name)))))
 540     (safely-writing (out file)
 541       (format out
 542               ";; Serial number file for zone ~A~%~
 543                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 544                ~S~%"
 545               name
 546               (cons seq now)))
 547     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 548
 549 ;;;--------------------------------------------------------------------------
 550 ;;; Zone variables and structures.
 551
 552 (defvar *zones* (make-hash-table :test #'equal)
 553   "Map of known zones.")
 554
 555 (defun zone-find (name)
 556   "Find a zone given its NAME."
 557   (gethash (string-downcase (stringify name)) *zones*))
 558
 559 (defun (setf zone-find) (zone name)
 560   "Make the zone NAME map to ZONE."
 561   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 562
 563 (defstruct (zone-record (:conc-name zr-))
 564   "A zone record."
 565   (name '<unnamed>)
 566   ttl
 567   type
 568   (defsubp nil)
 569   data)
 570
 571 (defstruct (zone-subdomain (:conc-name zs-))
 572   "A subdomain.  Slightly weird.  Used internally by zone-process-records
 573 below, and shouldn't escape."
 574   name
 575   ttl
 576   records)
 577
 578 ;;;--------------------------------------------------------------------------
 579 ;;; Zone infrastructure.
 580
 581 (defun zone-process-records (rec ttl func)
 582   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
 583 the default time-to-live for records which don't specify one."
 584   (labels ((sift (rec ttl)
 585              (collecting (top sub)
 586                (loop
 587                  (unless rec
 588                    (return))
 589                  (let ((r (pop rec)))
 590                    (cond ((eq r :ttl)
 591                           (setf ttl (pop rec)))
 592                          ((symbolp r)
 593                           (collect (make-zone-record :type r
 594                                                      :ttl ttl
 595                                                      :data (pop rec))
 596                                    top))
 597                          ((listp r)
 598                           (dolist (name (listify (car r)))
 599                             (collect (make-zone-subdomain :name name
 600                                                           :ttl ttl
 601                                                           :records (cdr r))
 602                                      sub)))
 603                          (t
 604                           (error "Unexpected record form ~A" (car r))))))))
 605            (process (rec dom ttl defsubp)
 606              (multiple-value-bind (top sub) (sift rec ttl)
 607                (if (and dom (null top) sub)
 608                    (let ((s (pop sub)))
 609                      (process (zs-records s)
 610                               dom
 611                               (zs-ttl s)
 612                               defsubp)
 613                      (process (zs-records s)
 614                               (cons (zs-name s) dom)
 615                               (zs-ttl s)
 616                               t))
 617                  (let ((name (and dom
 618                                   (string-downcase
 619                                    (join-strings #\. (reverse dom))))))
 620                    (dolist (zr top)
 621                      (setf (zr-name zr) name)
 622                      (setf (zr-defsubp zr) defsubp)
 623                      (funcall func zr))))
 624                (dolist (s sub)
 625                  (process (zs-records s)
 626                           (cons (zs-name s) dom)
 627                           (zs-ttl s)
 628                           defsubp)))))
 629     (process rec nil ttl nil)))
 630
 631 (defun zone-parse-host (f zname)
 632   "Parse a host name F: if F ends in a dot then it's considered absolute;
 633 otherwise it's relative to ZNAME."
 634   (setf f (stringify f))
 635   (cond ((string= f "@") (stringify zname))
 636         ((and (plusp (length f))
 637               (char= (char f (1- (length f))) #\.))
 638          (string-downcase (subseq f 0 (1- (length f)))))
 639         (t (string-downcase (concatenate 'string f "."
 640                                          (stringify zname))))))
 641 (defun default-rev-zone (base bytes)
 642   "Return the default reverse-zone name for the given BASE address and number
 643 of fixed leading BYTES."
 644   (join-strings #\. (collecting ()
 645                       (loop for i from (- 3 bytes) downto 0
 646                             do (collect (ipaddr-byte base i)))
 647                       (collect "in-addr.arpa"))))
 648
 649 (defun zone-name-from-net (net &optional bytes)
 650   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 651 subdomain of in-addr.arpa."
 652   (let ((ipn (net-get-as-ipnet net)))
 653     (with-ipnet (net mask) ipn
 654       (unless bytes
 655         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 656       (join-strings #\.
 657                     (append (loop
 658                                for i from (- 4 bytes) below 4
 659                                collect (logand #xff (ash net (* -8 i))))
 660                             (list "in-addr.arpa"))))))
 661
 662 (defun zone-net-from-name (name)
 663   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 664   (let* ((name (string-downcase (stringify name)))
 665          (len (length name))
 666          (suffix ".in-addr.arpa")
 667          (sufflen (length suffix))
 668          (addr 0)
 669          (n 0)
 670          (end (- len sufflen)))
 671     (unless (and (> len sufflen)
 672                  (string= name suffix :start1 end))
 673       (error "`~A' not in ~A." name suffix))
 674     (loop
 675        with start = 0
 676        for dot = (position #\. name :start start :end end)
 677        for byte = (parse-integer name
 678                                  :start start
 679                                  :end (or dot end))
 680        do (setf addr (logior addr (ash byte (* 8 n))))
 681           (incf n)
 682        when (>= n 4)
 683        do (error "Can't deduce network from ~A." name)
 684        while dot
 685        do (setf start (1+ dot)))
 686     (setf addr (ash addr (* 8 (- 4 n))))
 687     (make-ipnet addr (* 8 n))))
 688
 689 (defun zone-reverse-records (records net list bytes dom)
 690   "Construct a reverse zone given a forward zone's RECORDS list, the NET that
 691 the reverse zone is to serve, a LIST to collect the records into, how
 692 many BYTES of data need to end up in the zone, and the DOM-ain suffix."
 693   (dolist (zr records)
 694     (when (and (eq (zr-type zr) :a)
 695                (not (zr-defsubp zr))
 696                (ipaddr-networkp (zr-data zr) net))
 697       (collect (make-zone-record
 698                 :name (string-downcase
 699                        (join-strings
 700                         #\.
 701                         (collecting ()
 702                           (dotimes (i bytes)
 703                             (collect (logand #xff (ash (zr-data zr)
 704                                                        (* -8 i)))))
 705                           (collect dom))))
 706                 :type :ptr
 707                 :ttl (zr-ttl zr)
 708                 :data (zr-name zr))
 709                list))))
 710
 711 (defun zone-reverse (data name list)
 712   "Process a :reverse record's DATA, for a domain called NAME, and add the
 713 records to the LIST."
 714   (destructuring-bind
 715       (net &key bytes zones)
 716       (listify data)
 717     (setf net (zone-parse-net net name))
 718     (dolist (z (or (listify zones)
 719                    (hash-table-keys *zones*)))
 720       (zone-reverse-records (zone-records (zone-find z))
 721                             net
 722                             list
 723                             (or bytes
 724                                 (ipnet-changeable-bytes (ipnet-mask net)))
 725                             name))))
 726
 727 (defun zone-parse-net (net name)
 728   "Given a NET, and the NAME of a domain to guess from if NET is null,
 729 return the ipnet for the network."
 730   (if net
 731       (net-get-as-ipnet net)
 732       (zone-net-from-name name)))
 733
 734 (defun zone-cidr-delg-default-name (ipn bytes)
 735   "Given a delegated net IPN and the parent's number of changing BYTES,
 736 return the default deletate zone prefix."
 737   (with-ipnet (net mask) ipn
 738     (join-strings #\.
 739                   (reverse
 740                    (loop
 741                       for i from (1- bytes) downto 0
 742                       until (zerop (logand mask (ash #xff (* 8 i))))
 743                       collect (logand #xff (ash net (* -8 i))))))))
 744
 745 (defun zone-cidr-delegation (data name ttl list)
 746   "Given :cidr-delegation info DATA, for a record called NAME and the current
 747 TTL, write lots of CNAME records to LIST."
 748   (destructuring-bind
 749       (net &key bytes)
 750       (listify (car data))
 751     (setf net (zone-parse-net net name))
 752     (unless bytes
 753       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 754     (dolist (map (cdr data))
 755       (destructuring-bind
 756           (tnet &optional tdom)
 757           (listify map)
 758         (setf tnet (zone-parse-net tnet name))
 759         (unless (ipnet-subnetp net tnet)
 760           (error "~A is not a subnet of ~A."
 761                  (ipnet-pretty tnet)
 762                  (ipnet-pretty net)))
 763         (unless tdom
 764           (setf tdom
 765                 (join-strings #\.
 766                               (list (zone-cidr-delg-default-name tnet bytes)
 767                                     name))))
 768         (setf tdom (string-downcase tdom))
 769         (dotimes (i (ipnet-hosts tnet))
 770           (let* ((addr (ipnet-host tnet i))
 771                  (tail (join-strings #\.
 772                                      (loop
 773                                         for i from 0 below bytes
 774                                         collect
 775                                           (logand #xff
 776                                                   (ash addr (* 8 i)))))))
 777             (collect (make-zone-record
 778                       :name (join-strings #\.
 779                                           (list tail name))
 780                       :type :cname
 781                       :ttl ttl
 782                       :data (join-strings #\. (list tail tdom)))
 783                      list)))))))
 784
 785 ;;;--------------------------------------------------------------------------
 786 ;;; Zone form parsing.
 787
 788 (defun zone-parse-head (head)
 789   "Parse the HEAD of a zone form.  This has the form
 790
 791      (NAME &key :source :admin :refresh :retry
 792                 :expire :min-ttl :ttl :serial)
 793
 794 though a singleton NAME needn't be a list.  Returns the default TTL and an
 795 soa structure representing the zone head."
 796   (destructuring-bind
 797       (zname
 798        &key
 799        (source *default-zone-source*)
 800        (admin (or *default-zone-admin*
 801                   (format nil "hostmaster@~A" zname)))
 802        (refresh *default-zone-refresh*)
 803        (retry *default-zone-retry*)
 804        (expire *default-zone-expire*)
 805        (min-ttl *default-zone-min-ttl*)
 806        (ttl min-ttl)
 807        (serial (make-zone-serial zname)))
 808       (listify head)
 809     (values zname
 810             (timespec-seconds ttl)
 811             (make-soa :admin admin
 812                       :source (zone-parse-host source zname)
 813                       :refresh (timespec-seconds refresh)
 814                       :retry (timespec-seconds retry)
 815                       :expire (timespec-seconds expire)
 816                       :min-ttl (timespec-seconds min-ttl)
 817                       :serial serial))))
 818
 819 (defmacro defzoneparse (types (name data list
 820                                &key (zname (gensym "ZNAME"))
 821                                     (ttl (gensym "TTL"))
 822                                     (defsubp (gensym "DEFSUBP")))
 823                         &body body)
 824   "Define a new zone record type (or TYPES -- a list of synonyms is
 825 permitted).  The arguments are as follows:
 826
 827 NAME    The name of the record to be added.
 828
 829 DATA    The content of the record to be added (a single object, unevaluated).
 830
 831 LIST    A function to add a record to the zone.  See below.
 832
 833 ZNAME   The name of the zone being constructed.
 834
 835 TTL     The TTL for this record.
 836
 837 DEFSUBP Whether this is the default subdomain for this entry.
 838
 839 You get to choose your own names for these.  ZNAME, TTL and DEFSUBP are
 840 optional: you don't have to accept them if you're not interested.
 841
 842 The LIST argument names a function to be bound in the body to add a new
 843 low-level record to the zone.  It has the prototype
 844
 845   (LIST &key :name :type :data :ttl :defsubp)
 846
 847 Except for defsubp, these default to the above arguments (even if you didn't
 848 accept the arguments)."
 849   (setf types (listify types))
 850   (let* ((type (car types))
 851          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 852     (with-gensyms (col tname ttype tttl tdata tdefsubp i)
 853       `(progn
 854          (dolist (,i ',types)
 855            (setf (get ,i 'zone-parse) ',func))
 856          (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
 857            (declare (ignorable ,zname ,defsubp))
 858            (flet ((,list (&key ((:name ,tname) ,name)
 859                                ((:type ,ttype) ,type)
 860                                ((:data ,tdata) ,data)
 861                                ((:ttl ,tttl) ,ttl)
 862                                ((:defsubp ,tdefsubp) nil))
 863                     (collect (make-zone-record :name ,tname
 864                                                :type ,ttype
 865                                                :data ,tdata
 866                                                :ttl ,tttl
 867                                                :defsubp ,tdefsubp)
 868                              ,col)))
 869              ,@body))
 870          ',type))))
 871
 872 (defun zone-parse-records (zone records)
 873   (let ((zname (zone-name zone)))
 874     (with-collection (rec)
 875         (flet ((parse-record (zr)
 876                  (let ((func (or (get (zr-type zr) 'zone-parse)
 877                                  (error "No parser for record ~A."
 878                                         (zr-type zr))))
 879                        (name (and (zr-name zr)
 880                                   (stringify (zr-name zr)))))
 881                    (if (or (not name)
 882                            (string= name "@"))
 883                        (setf name zname)
 884                        (let ((len (length name)))
 885                          (if (or (zerop len)
 886                                  (char/= (char name (1- len)) #\.))
 887                              (setf name (join-strings #\.
 888                                                       (list name zname))))))
 889                    (funcall func
 890                             name
 891                             (zr-data zr)
 892                             (zr-ttl zr)
 893                             rec
 894                             zname
 895                             (zr-defsubp zr)))))
 896           (zone-process-records records
 897                                 (zone-default-ttl zone)
 898                                 #'parse-record ))
 899       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 900
 901 (defun zone-parse (zf)
 902   "Parse a ZONE form.  The syntax of a zone form is as follows:
 903
 904 ZONE-FORM:
 905   ZONE-HEAD ZONE-RECORD*
 906
 907 ZONE-RECORD:
 908   ((NAME*) ZONE-RECORD*)
 909 | SYM ARGS"
 910   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 911     (let ((zone (make-zone :name zname
 912                            :default-ttl ttl
 913                            :soa soa
 914                            :records nil)))
 915       (zone-parse-records zone (cdr zf))
 916       zone)))
 917
 918 (defun zone-create (zf)
 919   "Zone construction function.  Given a zone form ZF, construct the zone and
 920 add it to the table."
 921   (let* ((zone (zone-parse zf))
 922          (name (zone-name zone)))
 923     (setf (zone-find name) zone)
 924     name))
 925
 926 (defmacro defzone (soa &rest zf)
 927   "Zone definition macro."
 928   `(zone-create '(,soa ,@zf)))
 929
 930 (defmacro defrevzone (head &rest zf)
 931   "Define a reverse zone, with the correct name."
 932   (destructuring-bind
 933       (net &rest soa-args)
 934       (listify head)
 935     (let ((bytes nil))
 936       (when (and soa-args (integerp (car soa-args)))
 937         (setf bytes (pop soa-args)))
 938       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 939
 940 ;;;--------------------------------------------------------------------------
 941 ;;; Zone record parsers.
 942
 943 (defzoneparse :a (name data rec :defsubp defsubp)
 944   ":a IPADDR"
 945   (rec :data (parse-ipaddr data) :defsubp defsubp))
 946
 947 (defzoneparse :ptr (name data rec :zname zname)
 948   ":ptr HOST"
 949   (rec :data (zone-parse-host data zname)))
 950
 951 (defzoneparse :cname (name data rec :zname zname)
 952   ":cname HOST"
 953   (rec :data (zone-parse-host data zname)))
 954
 955 (defzoneparse :mx (name data rec :zname zname)
 956   ":mx ((HOST :prio INT :ip IPADDR)*)"
 957   (dolist (mx (listify data))
 958     (destructuring-bind
 959         (mxname &key (prio *default-mx-priority*) ip)
 960         (listify mx)
 961       (let ((host (zone-parse-host mxname zname)))
 962         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 963         (rec :data (cons host prio))))))
 964
 965 (defzoneparse :ns (name data rec :zname zname)
 966   ":ns ((HOST :ip IPADDR)*)"
 967   (dolist (ns (listify data))
 968     (destructuring-bind
 969         (nsname &key ip)
 970         (listify ns)
 971       (let ((host (zone-parse-host nsname zname)))
 972         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 973         (rec :data host)))))
 974
 975 (defzoneparse :alias (name data rec :zname zname)
 976   ":alias (LABEL*)"
 977   (dolist (a (listify data))
 978     (rec :name (zone-parse-host a zname)
 979          :type :cname
 980          :data name)))
 981
 982 (defzoneparse :net (name data rec)
 983   ":net (NETWORK*)"
 984   (dolist (net (listify data))
 985     (let ((n (net-get-as-ipnet net)))
 986       (rec :name (zone-parse-host "net" name)
 987            :type :a
 988            :data (ipnet-net n))
 989       (rec :name (zone-parse-host "mask" name)
 990            :type :a
 991            :data (ipnet-mask n))
 992       (rec :name (zone-parse-host "broadcast" name)
 993            :type :a
 994            :data (ipnet-broadcast n)))))
 995
 996 (defzoneparse (:rev :reverse) (name data rec)
 997   ":reverse ((NET :bytes BYTES) ZONE*)"
 998   (setf data (listify data))
 999   (destructuring-bind
1000       (net &key bytes)
1001       (listify (car data))
1002     (setf net (zone-parse-net net name))
1003     (unless bytes
1004       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
1005     (dolist (z (or (cdr data)
1006                    (hash-table-keys *zones*)))
1007       (dolist (zr (zone-records (zone-find z)))
1008         (when (and (eq (zr-type zr) :a)
1009                    (not (zr-defsubp zr))
1010                    (ipaddr-networkp (zr-data zr) net))
1011           (rec :name (string-downcase
1012                       (join-strings
1013                        #\.
1014                        (collecting ()
1015                          (dotimes (i bytes)
1016                            (collect (logand #xff (ash (zr-data zr)
1017                                                       (* -8 i)))))
1018                          (collect name))))
1019                :type :ptr
1020                :ttl (zr-ttl zr)
1021                :data (zr-name zr)))))))
1022
1023 (defzoneparse (:cidr-delegation :cidr) (name data rec)
1024   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
1025   (destructuring-bind
1026       (net &key bytes)
1027       (listify (car data))
1028     (setf net (zone-parse-net net name))
1029     (unless bytes
1030       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
1031     (dolist (map (cdr data))
1032       (destructuring-bind
1033           (tnet &optional tdom)
1034           (listify map)
1035         (setf tnet (zone-parse-net tnet name))
1036         (unless (ipnet-subnetp net tnet)
1037           (error "~A is not a subnet of ~A."
1038                  (ipnet-pretty tnet)
1039                  (ipnet-pretty net)))
1040         (unless tdom
1041           (with-ipnet (net mask) tnet
1042             (setf tdom
1043                   (join-strings
1044                    #\.
1045                    (append (reverse (loop
1046                                        for i from (1- bytes) downto 0
1047                                        until (zerop (logand mask
1048                                                             (ash #xff
1049                                                                  (* 8 i))))
1050                                        collect (logand #xff
1051                                                        (ash net (* -8 i)))))
1052                            (list name))))))
1053         (setf tdom (string-downcase tdom))
1054         (dotimes (i (ipnet-hosts tnet))
1055           (let* ((addr (ipnet-host tnet i))
1056                  (tail (join-strings #\.
1057                                      (loop
1058                                         for i from 0 below bytes
1059                                         collect
1060                                           (logand #xff
1061                                                   (ash addr (* 8 i)))))))
1062             (rec :name (format nil "~A.~A" tail name)
1063                  :type :cname
1064                  :data (format nil "~A.~A" tail tdom))))))))
1065
1066 ;;;--------------------------------------------------------------------------
1067 ;;; Zone file output.
1068
1069 (defun zone-write (zone &optional (stream *standard-output*))
1070   "Write a ZONE's records to STREAM."
1071   (labels ((fix-admin (a)
1072              (let ((at (position #\@ a))
1073                    (s (concatenate 'string (string-downcase a) ".")))
1074                (when s
1075                  (setf (char s at) #\.))
1076                s))
1077            (fix-host (h)
1078              (if (not h)
1079                  "@"
1080                  (let* ((h (string-downcase (stringify h)))
1081                         (hl (length h))
1082                         (r (string-downcase (zone-name zone)))
1083                         (rl (length r)))
1084                    (cond ((string= r h) "@")
1085                          ((and (> hl rl)
1086                                (char= (char h (- hl rl 1)) #\.)
1087                                (string= h r :start1 (- hl rl)))
1088                           (subseq h 0 (- hl rl 1)))
1089                          (t (concatenate 'string h "."))))))
1090            (printrec (zr)
1091              (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
1092                      (fix-host (zr-name zr))
1093                      (and (/= (zr-ttl zr) (zone-default-ttl zone))
1094                           (zr-ttl zr))
1095                      (string-upcase (symbol-name (zr-type zr))))))
1096     (format stream "~
1097 ;;; Zone file `~(~A~)'
1098 ;;;   (generated ~A)
1099
1100 $ORIGIN ~@0*~(~A.~)
1101 $TTL ~@2*~D~2%"
1102             (zone-name zone)
1103             (iso-date :now :datep t :timep t)
1104             (zone-default-ttl zone))
1105     (let ((soa (zone-soa zone)))
1106       (format stream "~
1107 ~A~30TIN SOA~40T~A ~A (
1108 ~45T~10D~60T ;serial
1109 ~45T~10D~60T ;refresh
1110 ~45T~10D~60T ;retry
1111 ~45T~10D~60T ;expire
1112 ~45T~10D )~60T ;min-ttl~2%"
1113               (fix-host (zone-name zone))
1114               (fix-host (soa-source soa))
1115               (fix-admin (soa-admin soa))
1116               (soa-serial soa)
1117               (soa-refresh soa)
1118               (soa-retry soa)
1119               (soa-expire soa)
1120               (soa-min-ttl soa)))
1121     (dolist (zr (zone-records zone))
1122       (case (zr-type zr)
1123         (:a
1124          (printrec zr)
1125          (format stream "~A~%" (ipaddr-string (zr-data zr))))
1126         ((:ptr :cname)
1127          (printrec zr)
1128          (format stream "~A~%" (fix-host (zr-data zr))))
1129         (:ns
1130          (printrec zr)
1131          (format stream "~A~%" (fix-host (zr-data zr))))
1132         (:mx
1133          (printrec zr)
1134          (let ((mx (zr-data zr)))
1135            (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
1136         (:txt
1137          (printrec zr)
1138          (format stream "~S~%" (stringify (zr-data zr))))))))
1139
1140 (defun zone-save (zones)
1141   "Write the named ZONES to files.  If no zones are given, write all the
1142 zones."
1143   (unless zones
1144     (setf zones (hash-table-keys *zones*)))
1145   (safely (safe)
1146     (dolist (z zones)
1147       (let ((zz (zone-find z)))
1148         (unless zz
1149           (error "Unknown zone `~A'." z))
1150         (let ((stream (safely-open-output-stream safe
1151                                                  (format nil
1152                                                          "~(~A~).zone"
1153                                                          z))))
1154           (zone-write zz stream))))))
1155
1156 ;;;----- That's all, folks --------------------------------------------------