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