From 32ebbe9b0fcc1a698c6ffec760259c5f7e953a9d Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 15 Apr 2014 14:02:06 +0100 Subject: [PATCH] net.lisp, zone.lisp: Major overhaul for multiple address families. A lot of internals have changed, and some user-visible features have been dropped. * IP addresses and networks are now captured in CLOS objects, and the low-level details of messing with them are handled in generic functions which live in their own separate files. * `ipnet-pretty' has gone. Now `ipnet' objects are directly printable. * `ipnet-changeable-bytes' has gone; there's now `ipnet-changeable-bits' instead. * `host' and `net' objects now track multiple addresses, so accessing them is a bit different. `net-get-as-ipnet' has gone, replaced by `net-parse-to-ipnets'. Acceptable syntaxes have mostly been enhanced, with the ability to control which address families are emitted. * Slightly painfully, support for DNS lookups has been dropped -- because SBCL doesn't have a good way of doing IPv6 lookups. * The `:cidr-delegation' record parser has gone, and been replaced by `:multi', which can be used to achieve the same thing (and a number of other special effects besides). * For the sake of sanity, the `:a' record parser only produces A records. The new `:addr' parser will produce records for all address families associated with its input. --- Makefile | 9 +- addr-family-ipv4.lisp | 85 ++++ net.lisp | 1090 ++++++++++++++++++++++++++++++++++++------------- zone.asd | 1 + zone.lisp | 462 ++++++++++----------- 5 files changed, 1113 insertions(+), 534 deletions(-) create mode 100644 addr-family-ipv4.lisp diff --git a/Makefile b/Makefile index e39eaf2..7decd8f 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,13 @@ +SOURCES = \ + zone.asd \ + frontend.lisp \ + zone.lisp \ + net.lisp serv.lisp sys.lisp \ + addr-family-ipv4.lisp + CLEANFILES += zone all:: zone -zone: frontend.lisp zone.lisp net.lisp serv.lisp sys.lisp +zone: $(SOURCES) cl-launch -o $@ -s zone +I -d `pwd`/zone.core -r zone.frontend:main clean:; rm -f $(CLEANFILES) diff --git a/addr-family-ipv4.lisp b/addr-family-ipv4.lisp new file mode 100644 index 0000000..f1846c8 --- /dev/null +++ b/addr-family-ipv4.lisp @@ -0,0 +1,85 @@ +;;; -*-lisp-*- +;;; +;;; IPv6 address family support +;;; +;;; (c) 2005 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software Foundation, +;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(in-package #:net) + +;;;-------------------------------------------------------------------------- +;;; Basic address type. + +(deftype u32 () + "The type of unsigned 32-bit values." + '(unsigned-byte 32)) + +(export 'ip4addr) +(defclass ip4addr (ipaddr) + ((addr :type u32 :initarg :addr :reader ipaddr-addr))) + +(defmethod family-addrclass ((family (eql :ipv4))) 'ip4addr) + +(defmethod ipaddr-family ((addr ip4addr)) :ipv4) +(defmethod ipaddr-width ((class (eql 'ip4addr))) 32) +(defmethod ipaddr-rrtype ((addr ip4addr)) :a) + +(defun parse-partial-ip4addr (str &key (start 0) (end nil) (min 1) (max 32)) + "Parse (a substring of) STR as a partial IPv4 address." + (parse-partial-address str :start start :end end + :delim #\. :width 8 :radix 10 + :min min :max max :shiftp t + :what "IPv4 address")) + +(defmethod parse-partial-ipaddr ((class (eql 'ip4addr)) str + &key (start 0) (end nil) (min 1) (max 32)) + (parse-partial-ip4addr str :start start :end end :min min :max max)) + +(defmethod ipaddr-string ((ip ip4addr)) + "Convert IP into an IPv4 dotted-quad address string." + (let ((addr (ipaddr-addr ip))) + (join-strings #\. (collecting () + (dotimes (i 4) + (collect (ldb (byte 8 (- 24 (* i 8))) addr))))))) + +;;;-------------------------------------------------------------------------- +;;; IPv4 networks. + +(defmethod ipmask ((addr ip4addr) (mask ip4addr)) + (ipaddr-addr mask)) + +(defclass ip4net (ipnet) + ((net :type ip4addr :initarg :net :reader ipnet-net) + (mask :type u32 :initarg :mask :reader ipnet-mask))) + +(defmethod ipaddr-ipnet ((addr ip4addr) mask) + (make-instance 'ip4net :net addr :mask mask)) + +(defmethod ipnet-broadcast ((ipn ip4net)) + (with-ipnet (nil addr mask) ipn + (make-instance 'ip4addr :addr (logior addr (logxor mask #xffffffff))))) + +;;;-------------------------------------------------------------------------- +;;; Reverse lookups. + +(defmethod reverse-domain-component-width ((ipaddr ip4addr)) 8) +(defmethod reverse-domain-radix ((ipaddr ip4addr)) 10) +(defmethod reverse-domain-suffix ((ipaddr ip4addr)) "in-addr.arpa") + +;;;----- That's all, folks -------------------------------------------------- diff --git a/net.lisp b/net.lisp index d5f4d76..c8852f9 100644 --- a/net.lisp +++ b/net.lisp @@ -24,320 +24,619 @@ (in-package #:net) ;;;-------------------------------------------------------------------------- -;;; Basic types. +;;; Various random utilities. +(declaim (inline mask)) (defun mask (n) "Return 2^N - 1: i.e., a mask of N set bits." (1- (ash 1 n))) -(deftype u32 () - "The type of unsigned 32-bit values." - '(unsigned-byte 32)) +(defun find-first-bit-transition + (mask &optional (low 0) (high (integer-length mask))) + "Find the first (lowest bit-position) transition in MASK within the bounds. -(export 'ipaddr) -(deftype ipaddr () - "The type of IP (version 4) addresses." - 'u32) + The LOW bound is inclusive; the high bound is exclusive. A transition is + a change from zero to one, or vice-versa. The return value is the + upper (exclusive) bound on the initial run, and the lower (inclusive) + bound on the new run. -;;;-------------------------------------------------------------------------- -;;; Various random utilities. + If there is no transition within the bounds, then return HIGH." + + ;; Arrange that the initial run is ones. + (unless (logbitp low mask) (setf mask (lognot mask))) + + ;; Now, note that MASK + 2^LOW is identical to MASK in all bit positions + ;; except for (a) the run of one bits starting at LOW, and (b) the zero bit + ;; just above it. So MASK xor (MASK + 2^LOW) is zero except for these + ;; bits; so all we need now is to find the position of its most significant + ;; set bit. + (let ((pos (1- (integer-length (logxor mask (+ mask (ash 1 low))))))) + (if (<= low pos high) pos high))) (defun count-low-zero-bits (n) "Return the number of low-order zero bits in the integer N." - (if (zerop n) nil - (loop for i from 0 - until (logbitp i n) - finally (return i)))) + (cond ((zerop n) nil) + ((oddp n) 0) + (t (find-first-bit-transition n)))) + +(declaim (inline round-down)) +(defun round-down (n step) + "Return the largest multiple of STEP not greater than N." + (* step (floor n step))) + +(declaim (inline round-up)) +(defun round-up (n step) + "Return the smallest multiple of STEP not less than N." + (* step (ceiling n step))) + +(defgeneric extract-class-name (object) + (:documentation "Turn OBJECT into a class name.") + (:method ((instance standard-object)) + (extract-class-name (class-of instance))) + (:method ((class standard-class)) + (class-name class)) + (:method ((name symbol)) + name)) + +(defclass savable-object () + ()) +(defmethod make-load-form ((object savable-object) &optional environment) + (make-load-form-saving-slots object :environment environment)) + +;;;-------------------------------------------------------------------------- +;;; Parsing primitives for addresses. + +(defun parse-partial-address + (str + &key (start 0) (end nil) (delim #\.) + (width 8) (radix 10) (min 1) (max 32) (shiftp t) + (what "address")) + "Parse a partial address from STR, which should be a sequence of integers + in the given RADIX, separated by the DELIM character, with each integer + N_i in the interval 0 <= N_i < 2^WIDTH. If the sequence is N_1, N_2, ..., + N_k, then the basic partial address BPA is the sum + + SUM_{1<=i<=k} 2^{WIDTH (k-i)} N_i + + If SHIFTP is true (the default) then let OFFSET be the smallest multiple + of WIDTH not less than MAX - k WIDTH; otherwise, let OFFSET be zero. The + partial address PA is BPA 2^SHIFT. + + The return values are: PA, OFFSET, k WIDTH + OFFSET; i.e., the partial + address, and (inclusive) lower and (exclusive) upper bounds on the bits + specified by STR." + + (setf-default end (length str)) + (let ((addr 0) (nbits 0) (limit (ash 1 width))) + (when (< start end) + (loop + (when (>= nbits max) + (error "Too many elements in ~A" what)) + (let* ((pos (position delim str :start start :end end)) + (w (parse-integer str :radix radix + :start start :end (or pos end)))) + (unless (and (<= 0 w) (< w limit)) + (error "Element out of range in ~A" what)) + (setf addr (logior (ash addr width) w)) + (incf nbits width) + (unless pos (return)) + (setf start (1+ pos))))) + (when (< nbits min) + (error "Not enough elements in ~A" what)) + (if shiftp + (let* ((top (round-up max width)) + (shift (- top nbits))) + (values (ash addr shift) shift top)) + (values addr 0 nbits)))) ;;;-------------------------------------------------------------------------- -;;; Simple messing with IP addresses. +;;; Simple messing about with IP addresses. + +(export 'ipaddr) +(export 'ipaddr-addr) +(defclass ipaddr (savable-object) + () + (:documentation + "Base class for IP addresses.")) + +(export 'ipaddr-family) +(defgeneric ipaddr-family (addr)) + +(export 'family-addrclass) +(defgeneric family-addrclass (family) + (:method ((af symbol)) nil)) + +(export 'ipaddr-width) +(defgeneric ipaddr-width (class) + (:method ((object t)) (ipaddr-width (extract-class-name object)))) + +(export 'ipaddr-comparable-p) +(defgeneric ipaddr-comparable-p (addr-a addr-b) + (:method ((addr-a ipaddr) (addr-b ipaddr)) + (eq (class-of addr-a) (class-of addr-b)))) + +(defun guess-address-class (str &key (start 0) (end nil)) + (declare (ignore str start end)) + 'ip4addr) + +(defgeneric parse-partial-ipaddr (class str &key start end min max) + (:method ((object t) str &rest keywords) + (apply #'parse-partial-ipaddr (extract-class-name object) str keywords))) (export 'string-ipaddr) (defun string-ipaddr (str &key (start 0) (end nil)) - "Parse STR into an address. + "Parse STR into an address; guess what kind is intended by the user. STR may be anything at all: it's converted as if by `stringify'. The START and END arguments may be used to parse out a substring." (setf str (stringify str)) - (setf-default end (length str)) - (let ((addr 0) (noct 0)) - (loop - (let* ((pos (position #\. str :start start :end end)) - (i (parse-integer str :start start :end (or pos end)))) - (unless (<= 0 i 256) - (error "IP address octet out of range")) - (setf addr (+ (* addr 256) i)) - (incf noct) - (unless pos - (return)) - (setf start (1+ pos)))) - (unless (= noct 4) - (error "Wrong number of octets in IP address")) - addr)) - -(export 'ipaddr-byte) -(defun ipaddr-byte (ip n) - "Return byte N (from most significant downwards) of an IP address." - (assert (<= 0 n 3)) - (logand #xff (ash ip (* -8 (- 3 n))))) + (let* ((class (guess-address-class str :start start :end end)) + (width (ipaddr-width class))) + (make-instance class :addr + (parse-partial-ipaddr class str + :start start :end end + :min width :max width)))) + +(export 'integer-ipaddr) +(defgeneric integer-ipaddr (int like) + (:documentation "Convert INT into an address of type indicated by LIKE. + + Specifically, if LIKE is an address object, then use its type; if it's + a class, then use it directly; if it's a symbol, then use the class it + names.") + (:method (int (like t)) (integer-ipaddr int (class-of like))) + (:method (int (like symbol)) + (make-instance (or (family-addrclass like) like) :addr int)) + (:method (int (like standard-class)) (make-instance like :addr int))) (export 'ipaddr-string) -(defun ipaddr-string (ip) - "Transform the address IP into a string in dotted-quad form." - (check-type ip ipaddr) - (join-strings #\. (collecting () - (dotimes (i 4) - (collect (ipaddr-byte ip i)))))) +(defgeneric ipaddr-string (ip) + (:documentation + "Transform the address IP into a string in dotted-quad form.")) + +(defmethod print-object ((addr ipaddr) stream) + (print-unreadable-object (addr stream :type t) + (write-string (ipaddr-string addr) stream))) (export 'ipaddrp) (defun ipaddrp (ip) "Answer true if IP is a valid IP address in integer form." (typep ip 'ipaddr)) -(defun ipaddr (ip) - "Convert IP to an IP address. +(defun ipaddr (ip &optional like) + "Convert IP to an IP address, of type similar to LIKE. - If it's an integer, return it unchanged; otherwise convert by - `string-ipaddr'." + If it's an IP address, just return it unchanged; If it's an integer, + capture it; otherwise convert by `string-ipaddr'." (typecase ip (ipaddr ip) + (integer (integer-ipaddr ip like)) (t (string-ipaddr ip)))) +(export 'ipaddr-rrtype) +(defgeneric ipaddr-rrtype (addr) + (:documentation "Return the proper resource record type for ADDR.")) + ;;;-------------------------------------------------------------------------- ;;; Netmasks. (export 'integer-netmask) -(defun integer-netmask (i) - "Given an integer I, return a netmask with its I top bits set." - (- (ash 1 32) (ash 1 (- 32 i)))) - -(export 'ipmask) -(defun ipmask (ip) - "Transform IP into a netmask. If it's a small integer then it's converted - by `integer-netmask'; if nil, then all-bits-set; otherwise convert using - `ipaddr'." - (typecase ip - (null (mask 32)) - ((integer 0 32) (integer-netmask ip)) - (t (ipaddr ip)))) +(defun integer-netmask (n i) + "Given an integer I, return an N-bit netmask with its I top bits set." + (- (ash 1 n) (ash 1 (- n i)))) (export 'ipmask-cidl-slash) -(defun ipmask-cidl-slash (mask) +(defun ipmask-cidl-slash (width mask) "Given a netmask MASK, try to compute a prefix length. - Return an integer N such that (integer-netmask N) = MASK, or nil if this - is impossible." - (dotimes (i 33) - (when (= mask (integer-netmask i)) - (return i)))) + Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if + this is impossible." + (let* ((low (logxor mask (mask width))) + (bits (integer-length low))) + (and (= low (mask bits)) (- width bits)))) + +(export 'ipmask) +(defgeneric ipmask (addr mask) + (:documentation "Convert MASK into a suitable netmask for ADDR.") + (:method ((addr ipaddr) (mask null)) + (mask (ipaddr-width addr))) + (:method ((addr ipaddr) (mask integer)) + (let ((w (ipaddr-width addr))) + (if (<= 0 mask w) + (integer-netmask w mask) + (error "Mask out of range."))))) + +(export 'mask-ipaddr) +(defun mask-ipaddr (addr mask) + "Apply the MASK to the ADDR, returning the base address." + (integer-ipaddr (logand mask (ipaddr-addr addr)) addr)) ;;;-------------------------------------------------------------------------- ;;; Networks: pairing an address and netmask. -(export 'make-ipnet) -(defun make-ipnet (net mask) - "Construct an IP-network object given the NET and MASK; these are - transformed as though by `ipaddr' and `ipmask'." - (let ((net (ipaddr net)) - (mask (ipmask mask))) - (cons (logand net mask) mask))) - -(export 'string-ipnet) -(defun string-ipnet (str &key (start 0) (end nil)) - "Parse an IP-network from the string STR." - (setf str (stringify str)) - (setf-default end (length str)) - (let ((sl (position #\/ str :start start :end end))) - (if sl - (make-ipnet (parse-ipaddr (subseq str start sl)) - (if (find #\. str :start (1+ sl) :end end) - (string-ipaddr str :start (1+ sl) :end end) - (integer-netmask (parse-integer str - :start (1+ sl) - :end end)))) - (make-ipnet (parse-ipaddr (subseq str start end)) - (integer-netmask 32))))) - (export 'ipnet) -(defun ipnet (net) - "Construct an IP-network object from the given argument. A number of forms - are acceptable: +(export 'ipnet-net) +(export 'ipnet-mask) +(defclass ipnet (savable-object) + () + (:documentation "Base class for IP networks.")) - * ADDR -- a single address (equivalent to ADDR 32) - * (NET . MASK|nil) -- a single-object representation. - * IPNET -- return an equivalent (`equal', not necessarily `eql') - version." - (cond ((or (stringp net) (symbolp net)) (string-ipnet net)) - (t (apply #'make-ipnet (pairify net 32))))) +(export 'ipnet-family) +(defgeneric ipnet-family (ipn) + (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn)))) -(export 'ipnet-net) -(defun ipnet-net (ipn) - "Return the base network address of IPN." - (car ipn)) +(export 'ipnet-addr) +(defun ipnet-addr (ipn) + "Return the base network address of IPN as a raw integer." + (ipaddr-addr (ipnet-net ipn))) -(export 'ipnet-mask) -(defun ipnet-mask (ipn) - "Return the netmask of IPN." - (cdr ipn)) +(export 'ipaddr-ipnet) +(defgeneric ipaddr-ipnet (addr mask) + (:documentation "Construct an `ipnet' object given a base ADDR and MASK.")) + +(export 'make-ipnet) +(defun make-ipnet (net mask) + "Construct an IP-network object given the NET and MASK; these are + transformed as though by `ipaddr' and `ipmask'." + (let* ((net (ipaddr net)) + (mask (ipmask net mask))) + (ipaddr-ipnet (mask-ipaddr net mask) mask))) (export 'with-ipnet) -(defmacro with-ipnet ((net mask) ipn &body body) +(defmacro with-ipnet ((net addr mask) ipn &body body) "Evaluate the BODY with components of IPN in scope. - The NET is bound to the underlying network base address and MASK is bound - to the netmask, again as an integer. Either (or both) of these may be nil - if not wanted." + The NET is bound to the underlying network base address, as an `ipaddr'; + ADDR is bound to the integer value of this address; and MASK is bound to + the netmask, again as an integer. Any (or all) of these may be nil if not + wanted." (with-gensyms tmp `(let ((,tmp ,ipn)) (let (,@(and net `((,net (ipnet-net ,tmp)))) + ,@(and addr `((,addr (ipnet-addr ,tmp)))) ,@(and mask `((,mask (ipnet-mask ,tmp))))) ,@body)))) -(export 'ipnet-pretty) -(defun ipnet-pretty (ipn) - "Convert IPN to a pretty cons-cell form." - (with-ipnet (net mask) ipn - (cons (ipaddr-string net) - (or (ipmask-cidl-slash mask) (ipaddr-string mask))))) +(export 'ipnet-width) +(defun ipnet-width (ipn) + "Return the underlying bit width of the addressing system." + (ipaddr-width (ipnet-net ipn))) (export 'ipnet-string) (defun ipnet-string (ipn) "Convert IPN to a string." - (with-ipnet (net mask) ipn + (with-ipnet (net nil mask) ipn (format nil "~A/~A" (ipaddr-string net) - (or (ipmask-cidl-slash mask) (ipaddr-string mask))))) + (or (ipmask-cidl-slash (ipnet-width ipn) mask) + (ipaddr-string (make-instance (class-of net) :addr mask)))))) + +(defmethod print-object ((ipn ipnet) stream) + (print-unreadable-object (ipn stream :type t) + (write-string (ipnet-string ipn) stream))) + +(defun parse-subnet (class width max str &key (start 0) (end nil)) + "Parse a subnet description from a (substring of) STR." + (setf-default end (length str)) + (let ((sl (position #\/ str :start start :end end))) + (multiple-value-bind (addr lo hi) + (parse-partial-ipaddr class str :max max + :start start :end (or sl end)) + (let* ((present (integer-netmask hi (- hi lo))) + (mask (cond ((not sl) + present) + ((every #'digit-char-p (subseq str (1+ sl) end)) + (let ((length (parse-integer str + :start (1+ sl) + :end end))) + (unless (>= length (- width max)) + (error "Mask doesn't reach subnet boundary")) + (integer-netmask max (- length (- width max))))) + (t + (parse-partial-ipaddr class str :max max + :start (1+ sl) :end end))))) + (unless (zerop (logandc2 mask present)) + (error "Mask selects bits not present in base address")) + (values addr mask))))) + +(export 'ipnet-subnet) +(defun ipnet-subnet (base-ipn sub-net sub-mask) + "Construct a subnet of IPN, using the NET and MASK. + + The NET must either be zero or agree with IPN at all positions indicated + by their respective masks." + (with-ipnet (base-net base-addr base-mask) base-ipn + (let* ((sub-net (ipaddr sub-net (ipnet-net base-ipn))) + (sub-addr (ipaddr-addr sub-net)) + (sub-mask (ipmask sub-net sub-mask)) + (common (logand base-mask sub-mask)) + (base-overlap (logand base-addr common)) + (sub-overlap (logand sub-addr common)) + (full-mask (logior base-mask sub-mask))) + (unless (or (zerop sub-overlap) + (= sub-overlap base-overlap)) + (error "Subnet doesn't match base network")) + (ipaddr-ipnet (integer-ipaddr (logand full-mask + (logior base-addr sub-addr)) + base-net) + full-mask)))) + +(export 'string-ipnet) +(defun string-ipnet (str &key (start 0) (end nil)) + "Parse an IP-network from the string STR." + (setf str (stringify str)) + (setf-default end (length str)) + (let ((addr-class (guess-address-class str :start start :end end))) + (multiple-value-bind (addr mask) + (let ((width (ipaddr-width addr-class))) + (parse-subnet addr-class width width str + :start start :end end)) + (make-ipnet (make-instance addr-class :addr addr) + (make-instance addr-class :addr mask))))) + +(export 'string-subipnet) +(defun string-subipnet (ipn str &key (start 0) (end nil)) + (setf str (stringify str)) + (let* ((addr-class (extract-class-name (ipnet-net ipn))) + (width (ipaddr-width addr-class)) + (max (- width + (or (ipmask-cidl-slash width (ipnet-mask ipn)) + (error "Base network has complex netmask"))))) + (multiple-value-bind (addr mask) + (parse-subnet addr-class width max str :start start :end end) + (ipnet-subnet ipn + (make-instance addr-class :addr addr) + (make-instance addr-class :addr mask))))) + +(defun ipnet (net) + "Construct an IP-network object from the given argument. + + A number of forms are acceptable: + + * ADDR -- a single address, equivalent to (ADDR . N). + * (NET . MASK|nil) -- a single-object representation. + * IPNET -- return an equivalent (`equal', not necessarily `eql') + version." + (typecase net + (ipnet net) + ((or string symbol) (string-ipnet net)) + (t (apply #'make-ipnet (pairify net nil))))) (export 'ipnet-broadcast) -(defun ipnet-broadcast (ipn) - "Return the broadcast address for the network IPN." - (with-ipnet (net mask) ipn - (logior net (logxor (mask 32) mask)))) +(defgeneric ipnet-broadcast (ipn) + (:documentation "Return the broadcast address for the network IPN. + + Returns nil if there isn't one.")) (export 'ipnet-hosts) (defun ipnet-hosts (ipn) "Return the number of available addresses in network IPN." - (ash 1 (- 32 (logcount (ipnet-mask ipn))))) + (ash 1 (- (ipnet-width ipn) (logcount (ipnet-mask ipn))))) + +(defstruct host-map + "An internal object used by `ipnet-index-host' and `ipnet-host-index'. + + Our objective is to be able to convert between flat host indices and a + possibly crazy non-flat host space. We record the underlying IPNET for + convenience, and a list of byte-specifications for the runs of zero bits + in the netmask, in ascending order." + ipnet + bytes) + +(export 'ipnet-host-map) +(defun ipnet-host-map (ipn) + "Work out how to enumerate the variable portion of IPN. + + Returns an object which can be passed to `ipnet-index-host' and + `ipnet-host-index'." + (let* ((mask (ipnet-mask ipn)) (bytes nil) (i 0) + (len (integer-length mask)) (width (ipnet-width ipn))) + (when (logbitp i mask) (setf i (find-first-bit-transition mask i))) + (loop + (unless (< i len) (return)) + (let ((next (find-first-bit-transition mask i width))) + (push (byte (- next i) i) bytes) + (setf i (find-first-bit-transition mask next width)))) + (when (< len width) (push (byte (- width len) len) bytes)) + (make-host-map :ipnet ipn :bytes (nreverse bytes)))) + +(export 'ipnet-index-host) +(defun ipnet-index-host (map host) + "Convert a HOST index to its address." + (let* ((ipn (host-map-ipnet map)) + (addr (logand (ipnet-addr ipn) (ipnet-mask ipn)))) + (dolist (byte (host-map-bytes map)) + (setf (ldb byte addr) host + host (ash host (- (byte-size byte))))) + (unless (zerop host) + (error "Host index out of range.")) + (integer-ipaddr addr (ipnet-net ipn)))) + +(export 'ipnet-host-index) +(defun ipnet-host-index (map addr) + "Convert an ADDR into a host index." + (let ((addr (ipaddr-addr addr)) + (host 0) (offset 0)) + (dolist (byte (host-map-bytes map)) + (setf host (logior host + (ash (ldb byte addr) offset)) + offset (+ offset (byte-size byte)))) + host)) + +(export 'ipnet-index-bounds) +(defun ipnet-index-bounds (map start end) + "Return host-index bounds corresponding to the given bit-position bounds." + (flet ((hack (frob-map good-byte tweak-addr) + (dolist (byte (funcall frob-map (host-map-bytes map))) + (let* ((low (byte-position byte)) + (high (+ low (byte-size byte))) + (good (funcall good-byte low high))) + (when good + (return-from hack + (ipnet-host-index map + (ipaddr (funcall tweak-addr + (ash 1 good)) + (ipnet-net + (host-map-ipnet map)))))))) + (error "No variable bits in range."))) + (values (hack #'identity + (lambda (low high) + (and (< start high) (max start low))) + #'identity) + (hack #'reverse + (lambda (low high) + (and (>= end low) (min end high))) + #'1-)))) (export 'ipnet-host) (defun ipnet-host (ipn host) "Return the address of the given HOST in network IPN. This works even with a non-contiguous netmask." - (check-type host u32) - (with-ipnet (net mask) ipn - (let ((i 0) (m 1) (a net) (h host)) - (loop - (when (>= i 32) - (error "Host index ~D out of range for network ~A" - host (ipnet-pretty ipn))) - (cond ((zerop h) - (return a)) - ((logbitp i mask) - (setf h (ash h 1))) - (t - (setf a (logior a (logand m h))) - (setf h (logandc2 h m)))) - (setf m (ash m 1)) - (incf i))))) + (ipnet-index-host (ipnet-host-map ipn) host)) (export 'ipaddr-networkp) (defun ipaddr-networkp (ip ipn) - "Returns true if address IP is within network IPN." - (with-ipnet (net mask) ipn - (= net (logand ip mask)))) + "Returns true if numeric address IP is within network IPN." + (with-ipnet (nil addr mask) ipn + (= addr (logand ip mask)))) (export 'ipnet-subnetp) (defun ipnet-subnetp (ipn subn) "Returns true if SUBN is a (non-strict) subnet of IPN." - (with-ipnet (net mask) ipn - (with-ipnet (subnet submask) subn - (and (= net (logand subnet mask)) + (with-ipnet (net addr mask) ipn + (with-ipnet (subnet subaddr submask) subn + (and (ipaddr-comparable-p net subnet) + (= addr (logand subaddr mask)) (= submask (logior mask submask)))))) -(export 'ipnet-changeable-bytes) -(defun ipnet-changeable-bytes (mask) - "Answers how many low-order bytes of MASK are (entirely or partially) - changeable. This is used when constructing reverse zones." - (dotimes (i 4 4) - (when (/= (ipaddr-byte mask i) 255) - (return (- 4 i))))) +(export 'ipnet-overlapp) +(defun ipnet-overlapp (ipn-a ipn-b) + "Returns true if IPN-A and IPN-B have any addresses in common." + (with-ipnet (net-a addr-a mask-a) ipn-a + (with-ipnet (net-b addr-b mask-b) ipn-b + + ;; In the case of an overlap, we explicitly construct a common + ;; address. If this fails, we know that the networks don't overlap + ;; after all. + (flet ((narrow (addr-a mask-a addr-b mask-b) + ;; Narrow network A towards B, by setting bits in A's base + ;; address towards which A is indifferent, but B is not; + ;; return the resulting base address. This address is still + ;; within network A, since we only set bits to which A is + ;; indifferent. + (logior addr-a (logand addr-b (logandc2 mask-a mask-b))))) + + (and (ipaddr-comparable-p net-a net-b) + (= (narrow addr-a mask-a addr-b mask-b) + (narrow addr-b mask-b addr-a mask-a))))))) + +(export 'ipnet-changeable-bits) +(defun ipnet-changeable-bits (width mask) + "Work out the number of changeable bits in a network, given its MASK. + + This is a conservative estimate in the case of noncontiguous masks. The + WIDTH is the total width of an address." + + ;; We bisect the address. If the low-order bits are changeable then we + ;; recurse on them; otherwise we look at the high-order bits. A mask M of + ;; width W is changeable if it's not all-ones, i.e., if M /= 2^W. If the + ;; top half is changeable then we don't need to look at the bottom half. + (labels ((recurse (width mask offset) + (if (= width 1) + (if (zerop mask) (1+ offset) offset) + (let* ((lowwidth (floor width 2)) + (highwidth (- width lowwidth)) + (highmask (ash mask (- lowwidth)))) + (if (logbitp highwidth (1+ highmask)) + (recurse lowwidth + (logand mask (mask lowwidth)) + offset) + (recurse highwidth highmask (+ offset lowwidth))))))) + (recurse width mask 0))) ;;;-------------------------------------------------------------------------- -;;; Host names and specifiers. - -(export 'parse-ipaddr) -(defun parse-ipaddr (addr) - "Convert the string ADDR into an IP address. - - Tries all sorts of things: - - (NET [INDEX]) index a network: NET is a network name defined by - defnet; INDEX is an index or one of the special - symbols understood by net-host, and defaults to :next - - INTEGER an integer IP address - - IPADDR an IP address in dotted-quad form - - HOST a host name defined by defhost - - DNSNAME a name string to look up in the DNS" - (cond ((listp addr) - (destructuring-bind - (net host) - (pairify addr :next) - (net-host (or (net-find net) - (error "Network ~A not found" net)) - host))) - ((ipaddrp addr) addr) - (t - (setf addr (string-downcase (stringify addr))) - (or (host-find addr) - (and (plusp (length addr)) - (digit-char-p (char addr 0)) - (string-ipaddr addr)) - (resolve-hostname (stringify addr)) - (error "Host name ~A unresolvable" addr))))) - -(defvar *hosts* (make-hash-table :test #'equal) - "The table of known hostnames.") - -(export 'host-find) -(defun host-find (name) - "Find a host by NAME." - (gethash (string-downcase (stringify name)) *hosts*)) -(defun (setf host-find) (addr name) - "Make NAME map to ADDR (must be an ipaddr in integer form)." - (setf (gethash (string-downcase (stringify name)) *hosts*) addr)) - -(export 'host-create) -(defun host-create (name addr) - "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)." - (setf (host-find name) (parse-ipaddr addr))) - -(export 'defhost) -(defmacro defhost (name addr) - "Main host definition macro. Neither NAME nor ADDR is evaluated." - `(progn - (host-create ',name ',addr) - ',name)) +;;; Reverse lookups. + +(export 'reverse-domain-component-width) +(defgeneric reverse-domain-component-width (ipaddr) + (:documentation "Return the component width for splitting IPADDR.")) + +(export 'reverse-domain-component-radix) +(defgeneric reverse-domain-radix (ipaddr) + (:documentation "Return the radix for representing IPADDR components.")) + +(export 'reverse-domain-component-suffix) +(defgeneric reverse-domain-suffix (ipaddr) + (:documentation "Return the reverse-lookup domain suffix for IPADDR.")) + +(export 'reverse-domain-fragment) +(defgeneric reverse-domain-fragment (ipaddr start end &key partialp) + (:documentation + "Return a portion of an IPADDR's reverse-resolution domain name. + + Specifically, return the portion of the name which covers the bits of an + IPADDR between bits START (inclusive) and END (exclusive). Address + components which are only partially within the given bounds are included + unless PARTIALP is nil.") + (:method ((ipaddr ipaddr) start end &key (partialp t)) + + (let ((addr (ipaddr-addr ipaddr)) + (comp-width (reverse-domain-component-width ipaddr)) + (radix (reverse-domain-radix ipaddr))) + + (with-output-to-string (out) + (do ((i (funcall (if partialp #'round-down #'round-up) + start comp-width) + (+ i comp-width)) + (limit (funcall (if partialp #'round-up #'round-down) + end comp-width)) + (sep nil t)) + ((>= i limit)) + (format out "~:[~;.~]~(~vR~)" + sep radix (ldb (byte comp-width i) addr))))))) + +(export 'reverse-domain) +(defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len) + (:documentation "Return a reverse-resolution domain name for IPADDR-OR-IPN. + + If PREFIX-LEN is nil then it defaults to the length of the network's fixed + prefix.") + (:method ((ipn ipnet) &optional prefix-len) + (let* ((addr (ipnet-net ipn)) + (mask (ipnet-mask ipn)) + (width (ipaddr-width addr))) + (concatenate 'string + (reverse-domain-fragment + addr + (if prefix-len + (- width prefix-len) + (ipnet-changeable-bits width mask)) + width + :partialp nil) + "." + (reverse-domain-suffix addr)))) + (:method ((addr ipaddr) &optional prefix-len) + (let* ((width (ipaddr-width addr))) + (reverse-domain (make-ipnet addr (mask width)) + (or prefix-len width))))) ;;;-------------------------------------------------------------------------- ;;; Network names and specifiers. (export 'net) -(defstruct (net (:predicate netp)) - "A network structure. Slots: - - NAME The network's name, as a string - IPNET The network base address and mask - HOSTS Number of hosts in the network - NEXT Index of the next unassigned host" - name - ipnet - hosts - next) +(export 'net-name) +(export 'net-ipnets) +(defclass net () + ((name :type string :initarg :name :reader net-name) + (ipnets :type list :initarg :ipnets :initform nil :accessor net-ipnets) + (next :type unsigned-byte :initform 1 :accessor net-next))) + +(defmethod print-object ((net net) stream) + (print-unreadable-object (net stream :type t) + (format stream "~A~@[ = ~{~A~^, ~}~]" + (net-name net) + (mapcar #'ipnet-string (net-ipnets net))))) (defvar *networks* (make-hash-table :test #'equal) "The table of known networks.") @@ -350,59 +649,106 @@ "Make NAME map to NET." (setf (gethash (string-downcase (stringify name)) *networks*) net)) -(export 'net-get-as-ipnet) -(defun net-get-as-ipnet (form) - "Transform FORM into an ipnet. - - FORM may be a network name, or something acceptable to the ipnet - function." - (let ((net (net-find form))) - (if net (net-ipnet net) - (ipnet form)))) - -(defun process-net-form (root addr subnets) +(export 'net-must-find) +(defun net-must-find (name) + (or (net-find name) + (error "Unknown network ~A." name))) + +(defun net-ipnet (net family) + (find family (net-ipnets net) :key #'ipnet-family)) +(defun (setf net-ipnet) (ipnet net family) + (assert (eq (ipnet-family ipnet) family)) + (let ((ipns (net-ipnets net))) + (if (find family ipns :key #'ipnet-family) + (nsubstitute ipnet family ipns :key #'ipnet-family) + (setf (net-ipnets net) (cons ipnet ipns))))) + +(defun process-net-form (name addr subnets) "Unpack a net-form. - The return value is a list of entries, each of which is a list of the form - (NAME ADDR MASK). The first entry is merely repeats the given ROOT and - ADDR arguments (unpacking ADDR into separate network address and mask). - The SUBNETS are then processed: they are a list of items of the form (NAME - NUM-HOSTS . SUBNETS), where NAME names the subnet, NUM-HOSTS is the number - of hosts in it, and SUBNETS are its sub-subnets in the same form. An - error is signalled if a net's subnets use up more hosts than the net has - to start with." - - (labels ((frob (subnets limit finger) - (when subnets - (destructuring-bind (name size &rest subs) (car subnets) - (when (> (count-low-zero-bits size) - (count-low-zero-bits finger)) - (error "Bad subnet size for ~A." name)) - (when (> (+ finger size) limit) - (error "Subnet ~A out of range." name)) - (append (and name - (list (list name finger (- (ash 1 32) size)))) - (frob subs (+ finger size) finger) - (frob (cdr subnets) limit (+ finger size))))))) - (let ((ipn (ipnet addr))) - (with-ipnet (net mask) ipn - (unless (ipmask-cidl-slash mask) - (error "Bad mask for subnet form.")) - (cons (list root net mask) - (frob subnets (+ net (ipnet-hosts ipn) 1) net)))))) + A net-form looks like (NAME ADDR [SUBNET ...]) where: + + * NAME is the name for the network. + + * ADDR is the subnet address (acceptable to `string-subipnet'); at + top-level, this is a plain network address (acceptable to + `string-ipnet'). Alternatively (for compatibility) the ADDR for a + non-top-level network can be an integer number of addresses to + allocate to this subnet; the subnet's base address is implicitly just + past the previous subnet's limit address (or, for the first subnet, + it's the parent network's base address). This won't work at all well + if your subnets have crazy netmasks. + + * The SUBNETs are further net-forms, of the same form, whose addresses + are interpreted relative to the parent network's address. + + The return value is a list of items of the form (NAME . IPNET)." + + (labels ((process-subnets (subnets parent) + (let ((finger (ipnet-addr parent)) + (list nil)) + (dolist (subnet subnets list) + (destructuring-bind (name addr &rest subs) subnet + (let ((net (etypecase addr + (integer + (when (or (> (count-low-zero-bits addr) + (count-low-zero-bits finger)) + (not (zerop (logand addr + (1- addr))))) + (error "Bad subnet size for ~A." name)) + (make-ipnet + (ipaddr finger (ipnet-net parent)) + (ipaddr (- (ash 1 (ipnet-width parent)) + addr) + (ipnet-net parent)))) + ((or string symbol) + (string-subipnet parent addr))))) + + (unless (ipnet-subnetp parent net) + (error "Network `~A' (~A) falls outside parent ~A." + name (ipnet-string net) (ipnet-string parent))) + + (dolist (entry list nil) + (let ((ipn (cdr entry))) + (when (ipnet-overlapp ipn net) + (error "Network `~A' (~A) overlaps `~A' (~A)." + name (ipnet-string net) + (car entry) (ipnet-string ipn))))) + + (setf finger + (1+ (logior + (ipnet-addr net) + (logxor (ipnet-mask net) + (1- (ash 1 (ipnet-width net))))))) + + (when name + (push (cons name net) list)) + + (when subs + (setf list (nconc (process-subnets subs net) + list))))))))) + + (let* ((top (string-ipnet addr)) + (list (nreverse (process-subnets subnets top)))) + (when name (push (cons name top) list)) + list))) (export 'net-create) (defun net-create (name net) "Construct a new network called NAME and add it to the map. - The ARGS describe the new network, in a form acceptable to the `ipnet' - function." - (let ((ipn (ipnet net))) - (setf (net-find name) - (make-net :name (string-downcase (stringify name)) - :ipnet ipn - :hosts (ipnet-hosts ipn) - :next 1)))) + The NET describes the new network, in a form acceptable to the `ipnet' + function. A named network may have multiple addresses with different + families: each `net-create' call adds a new family, or modifies the net's + address in an existing family." + (let ((ipn (ipnet net)) + (net (net-find name))) + (if net + (progn (setf (net-ipnet net (ipnet-family ipn)) ipn) net) + (setf (net-find name) + (make-instance 'net + :name (string-downcase (stringify name)) + :ipnets (list ipn)))))) (export 'defnet) (defmacro defnet (name net &rest subnets) @@ -410,33 +756,195 @@ None of the arguments is evaluated." `(progn - ,@(loop for (name addr mask) in (process-net-form name net subnets) - collect `(net-create ',name '(,addr . ,mask))) - ',name)) - -(export 'net-next-host) -(defun net-next-host (net) - "Given a NET, return the IP address (as integer) of the next available - address in the network." - (unless (< (net-next net) (net-hosts net)) - (error "No more hosts left in network ~A" (net-name net))) - (let ((next (net-next net))) - (incf (net-next net)) - (net-host net next))) + ,@(mapcar (lambda (item) + (let ((name (car item)) (ipn (cdr item))) + `(net-create ',name ',ipn))) + (process-net-form name net subnets)) + ',name)) + +(export 'net-parse-to-ipnets) +(defun net-parse-to-ipnets (form &optional (family t)) + (flet ((hack (form family) + (let* ((form (if (and (consp form) + (endp (cdr form))) + (car form) + form)) + (net (net-find form)) + (ipns (if net (net-ipnets net) + (list (ipnet form))))) + (if (eq family t) ipns + (remove family ipns + :key #'ipnet-family + :test-not #'eq))))) + (let* ((ipns (if (and (listp form) + (every (lambda (clause) + (and (listp clause) + (symbolp (car clause)) + (or (eq (car clause) t) + (family-addrclass + (car clause))))) + form)) + (mappend (lambda (clause) + (hack (cdr clause) (car clause))) + form) + (hack form family))) + (merged (reduce (lambda (ipns ipn) + (if (find (ipnet-family ipn) ipns + :key #'ipnet-family) + ipns + (cons ipn ipns))) + ipns + :initial-value nil))) + (or merged (error "No matching addresses."))))) (export 'net-host) -(defun net-host (net host) - "Return the given HOST on the NEXT. +(defun net-host (net-form host &optional (family t)) + "Return the given HOST on the NET, as an anonymous `host' object. HOST may be an index (in range, of course), or one of the keywords: - :NEXT next host, as by net-next-host - :NET network base address - :BROADCAST network broadcast address" - (case host - (:next (net-next-host net)) - (:net (ipnet-net (net-ipnet net))) - (:broadcast (ipnet-broadcast (net-ipnet net))) - (t (ipnet-host (net-ipnet net) host)))) + :next next host, as by net-next-host + :net network base address + :broadcast network broadcast address + + If FAMILY is not `t', then only return an address with that family; + otherwise return all available addresses." + (flet ((hosts (ipns host) + (mapcar (lambda (ipn) (ipnet-host ipn host)) + (remove host ipns :key #'ipnet-hosts :test-not #'<)))) + (let* ((net (and (typep net-form '(or string symbol)) + (net-find net-form))) + (ipns (net-parse-to-ipnets net-form family)) + (addrs (case host + (:next + (if net + (prog1 (hosts ipns (net-next net)) + (incf (net-next net))) + (error "Can't use `:next' without a named net."))) + (:net (mapcar #'ipnet-net ipns)) + (:broadcast (remove nil (mapcar #'ipnet-broadcast ipns))) + (t (hosts ipns host))))) + (unless addrs + (error "No networks have that address.")) + (make-instance 'host :addrs addrs)))) + +;;;-------------------------------------------------------------------------- +;;; Host names and specifiers. + +(export 'host) +(export 'host-name) +(export 'host-addrs) +(defclass host () + ((name :type (or string null) :initform nil + :initarg :name :reader host-name) + (addrs :type list :initarg :addrs :initform nil :accessor host-addrs))) + +(defmethod print-object ((host host) stream) + (print-unreadable-object (host stream :type t) + (format stream "~:[~;~@*~A~]~@[ = ~{~A~^, ~}~]" + (host-name host) + (mapcar #'ipaddr-string (host-addrs host))))) + +(defvar *hosts* (make-hash-table :test #'equal) + "The table of known hostnames.") + +(export 'host-find) +(defun host-find (name) + "Find a host by NAME." + (gethash (string-downcase (stringify name)) *hosts*)) +(defun (setf host-find) (addr name) + "Make NAME map to ADDR (must be an ipaddr in integer form)." + (setf (gethash (string-downcase (stringify name)) *hosts*) addr)) + +(defun merge-addresses (addrs-a addrs-b) + (append (remove-if (lambda (addr) + (member (ipaddr-family addr) addrs-b + :key #'ipaddr-family)) + addrs-a) + addrs-b)) + +(export 'host-parse) +(defun host-parse (addr &optional (family t)) + "Convert the ADDR into a (possibly anonymous) `host' object. + + The ADDR can be one of a number of different things. + + HOST a host name defined using `defhost' + + (NET INDEX) a particular host in a network + + IPADDR an address form acceptable to `ipnet' + + ((FAMILY . ADDR) ...) the above, restricted to a particular address + FAMILY (i.e., one of the keywords `:ipv4', + etc.)" + + (labels ((filter-addresses (addrs family) + (make-instance 'host + :addrs (if (eq family t) addrs + (remove family addrs + :key #'ipaddr-family + :test-not #'eq)))) + (host-addresses (host family) + (if (eq family t) host + (filter-addresses (host-addrs host) family))) + (hack (addr family) + (let* ((form (listify addr)) + (indic (car form)) + (host (and (null (cdr form)) + (host-find indic)))) + (cond (host + (host-addresses host family)) + ((and (consp (cdr form)) + (endp (cddr form))) + (net-host (car form) (cadr form) family)) + (t + (filter-addresses (list (ipaddr indic)) family)))))) + (let ((host (cond + ((not (eq family t)) + (hack addr family)) + ((and (listp addr) + (every (lambda (clause) + (and (listp clause) + (symbolp (car clause)) + (or (eq (car clause) t) + (family-addrclass (car clause))))) + addr)) + (make-instance 'host + :addrs (reduce #'merge-addresses + (mapcar + (lambda (clause) + (host-addrs + (hack (cdr clause) + (car clause)))) + (reverse addr)) + :initial-value nil))) + (t + (hack addr t))))) + (unless (host-addrs host) + (error "No matching addresses.")) + host))) + +(export 'host-create) +(defun host-create (name addr) + "Make host NAME map to ADDR (anything acceptable to `host-parse')." + (let ((existing (host-find name)) + (new (host-parse addr))) + (if (not existing) + (setf (host-find name) + (make-instance 'host + :name (string-downcase (stringify name)) + :addrs (host-addrs new))) + (progn + (setf (host-addrs existing) + (merge-addresses (host-addrs existing) (host-addrs new))) + existing)))) + +(export 'defhost) +(defmacro defhost (name addr) + "Main host definition macro. Neither NAME nor ADDR is evaluated." + `(progn + (host-create ',name ',addr) + ',name)) ;;;----- That's all, folks -------------------------------------------------- diff --git a/zone.asd b/zone.asd index 32cd09a..d090da7 100644 --- a/zone.asd +++ b/zone.asd @@ -8,6 +8,7 @@ :components ((:file "net-package") (:file "sys") (:file "net") + (:file "addr-family-ipv4") (:file "serv") (:file "zone") (:file "frontend")) diff --git a/zone.lisp b/zone.lisp index 9e5795d..735e87f 100644 --- a/zone.lisp +++ b/zone.lisp @@ -27,7 +27,8 @@ (defpackage #:zone (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely - #:net #:services)) + #:net #:services) + (:import-from #:net #:round-down #:round-up)) (in-package #:zone) @@ -257,6 +258,69 @@ (cdr clause)))) clauses))) +(export 'zone-parse-host) +(defun zone-parse-host (f zname) + "Parse a host name F. + + If F ends in a dot then it's considered absolute; otherwise it's relative + to ZNAME." + (setf f (stringify f)) + (cond ((string= f "@") (stringify zname)) + ((and (plusp (length f)) + (char= (char f (1- (length f))) #\.)) + (string-downcase (subseq f 0 (1- (length f))))) + (t (string-downcase (concatenate 'string f "." + (stringify zname)))))) + +(export 'zone-make-name) +(defun zone-make-name (prefix zone-name) + "Compute a full domain name from a PREFIX and a ZONE-NAME. + + If the PREFIX ends with `.' then it's absolute already; otherwise, append + the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then + return the ZONE-NAME only." + (if (or (not prefix) (string= prefix "@")) + zone-name + (let ((len (length prefix))) + (if (or (zerop len) (char/= (char prefix (1- len)) #\.)) + (join-strings #\. (list prefix zone-name)) + prefix)))) + +;;;-------------------------------------------------------------------------- +;;; Serial numbering. + +(export 'make-zone-serial) +(defun make-zone-serial (name) + "Given a zone NAME, come up with a new serial number. + + This will (very carefully) update a file ZONE.serial in the current + directory." + (let* ((file (zone-file-name name :serial)) + (last (with-open-file (in file + :direction :input + :if-does-not-exist nil) + (if in (read in) + (list 0 0 0 0)))) + (now (multiple-value-bind + (sec min hr dy mon yr dow dstp tz) + (get-decoded-time) + (declare (ignore sec min hr dow dstp tz)) + (list dy mon yr))) + (seq (cond ((not (equal now (cdr last))) 0) + ((< (car last) 99) (1+ (car last))) + (t (error "Run out of sequence numbers for ~A" name))))) + (safely-writing (out file) + (format out + ";; Serial number file for zone ~A~%~ + ;; (LAST-SEQ DAY MONTH YEAR)~%~ + ~S~%" + name + (cons seq now))) + (from-mixed-base '(100 100 100) (reverse (cons seq now))))) + +;;;-------------------------------------------------------------------------- +;;; Zone form parsing. + (defun zone-process-records (rec ttl func) "Sort out the list of records in REC, calling FUNC for each one. @@ -352,120 +416,6 @@ ;; Process the records we're given with no prefix. (process rec nil ttl))) -(export 'zone-parse-host) -(defun zone-parse-host (f zname) - "Parse a host name F. - - If F ends in a dot then it's considered absolute; otherwise it's relative - to ZNAME." - (setf f (stringify f)) - (cond ((string= f "@") (stringify zname)) - ((and (plusp (length f)) - (char= (char f (1- (length f))) #\.)) - (string-downcase (subseq f 0 (1- (length f))))) - (t (string-downcase (concatenate 'string f "." - (stringify zname)))))) -(defun default-rev-zone (base bytes) - "Return the default reverse-zone name for the given BASE address and number - of fixed leading BYTES." - (join-strings #\. (collecting () - (loop for i from (- 3 bytes) downto 0 - do (collect (ipaddr-byte base i))) - (collect "in-addr.arpa")))) - -(defun zone-name-from-net (net &optional bytes) - "Given a NET, and maybe the BYTES to use, convert to the appropriate - subdomain of in-addr.arpa." - (let ((ipn (net-get-as-ipnet net))) - (with-ipnet (net mask) ipn - (unless bytes - (setf bytes (- 4 (ipnet-changeable-bytes mask)))) - (join-strings #\. - (append (loop - for i from (- 4 bytes) below 4 - collect (logand #xff (ash net (* -8 i)))) - (list "in-addr.arpa")))))) - -(defun zone-net-from-name (name) - "Given a NAME in the in-addr.arpa space, convert it to an ipnet." - (let* ((name (string-downcase (stringify name))) - (len (length name)) - (suffix ".in-addr.arpa") - (sufflen (length suffix)) - (addr 0) - (n 0) - (end (- len sufflen))) - (unless (and (> len sufflen) - (string= name suffix :start1 end)) - (error "`~A' not in ~A." name suffix)) - (loop - with start = 0 - for dot = (position #\. name :start start :end end) - for byte = (parse-integer name - :start start - :end (or dot end)) - do (setf addr (logior addr (ash byte (* 8 n)))) - (incf n) - when (>= n 4) - do (error "Can't deduce network from ~A." name) - while dot - do (setf start (1+ dot))) - (setf addr (ash addr (* 8 (- 4 n)))) - (make-ipnet addr (* 8 n)))) - -(defun zone-parse-net (net name) - "Given a NET, and the NAME of a domain to guess from if NET is null, return - the ipnet for the network." - (if net - (net-get-as-ipnet net) - (zone-net-from-name name))) - -(defun zone-cidr-delg-default-name (ipn bytes) - "Given a delegated net IPN and the parent's number of changing BYTES, - return the default deletate zone prefix." - (with-ipnet (net mask) ipn - (join-strings #\. - (reverse - (loop - for i from (1- bytes) downto 0 - until (zerop (logand mask (ash #xff (* 8 i)))) - collect (logand #xff (ash net (* -8 i)))))))) - -;;;-------------------------------------------------------------------------- -;;; Serial numbering. - -(export 'make-zone-serial) -(defun make-zone-serial (name) - "Given a zone NAME, come up with a new serial number. - - This will (very carefully) update a file ZONE.serial in the current - directory." - (let* ((file (zone-file-name name :serial)) - (last (with-open-file (in file - :direction :input - :if-does-not-exist nil) - (if in (read in) - (list 0 0 0 0)))) - (now (multiple-value-bind - (sec min hr dy mon yr dow dstp tz) - (get-decoded-time) - (declare (ignore sec min hr dow dstp tz)) - (list dy mon yr))) - (seq (cond ((not (equal now (cdr last))) 0) - ((< (car last) 99) (1+ (car last))) - (t (error "Run out of sequence numbers for ~A" name))))) - (safely-writing (out file) - (format out - ";; Serial number file for zone ~A~%~ - ;; (LAST-SEQ DAY MONTH YEAR)~%~ - ~S~%" - name - (cons seq now))) - (from-mixed-base '(100 100 100) (reverse (cons seq now))))) - -;;;-------------------------------------------------------------------------- -;;; Zone form parsing. - (defun zone-parse-head (head) "Parse the HEAD of a zone form. @@ -499,20 +449,6 @@ :min-ttl (timespec-seconds min-ttl) :serial serial)))) -(export 'zone-make-name) -(defun zone-make-name (prefix zone-name) - "Compute a full domain name from a PREFIX and a ZONE-NAME. - - If the PREFIX ends with `.' then it's absolute already; otherwise, append - the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then - return the ZONE-NAME only." - (if (or (not prefix) (string= prefix "@")) - zone-name - (let ((len (length prefix))) - (if (or (zerop len) (char/= (char prefix (1- len)) #\.)) - (join-strings #\. (list prefix zone-name)) - prefix)))) - (export 'defzoneparse) (defmacro defzoneparse (types (name data list &key (prefix (gensym "PREFIX")) @@ -618,31 +554,68 @@ name)) (export 'defzone) -(defmacro defzone (soa &rest zf) +(defmacro defzone (soa &body zf) "Zone definition macro." `(zone-create '(,soa ,@zf))) +(export '*address-family*) +(defvar *address-family* t + "The default address family. This is bound by `defrevzone'.") + (export 'defrevzone) -(defmacro defrevzone (head &rest zf) +(defmacro defrevzone (head &body zf) "Define a reverse zone, with the correct name." - (destructuring-bind - (net &rest soa-args) + (destructuring-bind (nets &rest args + &key &allow-other-keys + (family '*address-family*) + prefix-bits) (listify head) - (let ((bytes nil)) - (when (and soa-args (integerp (car soa-args))) - (setf bytes (pop soa-args))) - `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf))))) + (with-gensyms (ipn) + `(dolist (,ipn (net-parse-to-ipnets ',nets ,family)) + (let ((*address-family* (ipnet-family ,ipn))) + (zone-create `((,(reverse-domain ,ipn ,prefix-bits) + ,@',(loop for (k v) on args by #'cddr + unless (member k + '(:family :prefix-bits)) + nconc (list k v))) + ,@',zf))))))) + +(defun map-host-addresses (func addr &key (family *address-family*)) + "Call FUNC for each address denoted by ADDR (a `host-parse' address)." + + (dolist (a (host-addrs (host-parse addr family))) + (funcall func a))) + +(defmacro do-host ((addr spec &key (family *address-family*)) &body body) + "Evaluate BODY, binding ADDR to each address denoted by SPEC." + `(dolist (,addr (host-addrs (host-parse ,spec ,family))) + ,@body)) + +(export 'zone-set-address) +(defun zone-set-address (rec addrspec &rest args + &key (family *address-family*) name ttl make-ptr-p) + "Write records (using REC) defining addresses for ADDRSPEC." + (declare (ignore name ttl make-ptr-p)) + (let ((key-args (loop for (k v) on args by #'cddr + unless (eq k :family) + nconc (list k v)))) + (do-host (addr addrspec :family family) + (apply rec :type (ipaddr-rrtype addr) :data addr key-args)))) ;;;-------------------------------------------------------------------------- ;;; Zone record parsers. (defzoneparse :a (name data rec) ":a IPADDR" - (rec :data (parse-ipaddr data) :make-ptr-p t)) + (zone-set-address #'rec data :make-ptr-p t :family :ipv4)) + +(defzoneparse :addr (name data rec) + ":addr IPADDR" + (zone-set-address #'rec data :make-ptr-p t)) (defzoneparse :svc (name data rec) ":svc IPADDR" - (rec :type :a :data (parse-ipaddr data))) + (zone-set-address #'rec data)) (defzoneparse :ptr (name data rec :zname zname) ":ptr HOST" @@ -755,7 +728,7 @@ (mxname &key (prio *default-mx-priority*) ip) (listify mx) (let ((host (zone-parse-host mxname zname))) - (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (when ip (zone-set-address #'rec ip :name host)) (rec :data (cons host prio)))))) (defzoneparse :ns (name data rec :zname zname) @@ -765,7 +738,7 @@ (nsname &key ip) (listify ns) (let ((host (zone-parse-host nsname zname))) - (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (when ip (zone-set-address #'rec ip :name host)) (rec :data host))))) (defzoneparse :alias (name data rec :zname zname) @@ -796,107 +769,112 @@ ip) (listify prov) (let ((host (zone-parse-host srvname zname))) - (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (when ip (zone-set-address #'rec ip :name host)) (rec :name rname :data (list prio weight port host)))))))))) (defzoneparse :net (name data rec) ":net (NETWORK*)" (dolist (net (listify data)) - (let ((n (net-get-as-ipnet net))) - (rec :name (zone-parse-host "net" name) - :type :a - :data (ipnet-net n)) - (rec :name (zone-parse-host "mask" name) - :type :a - :data (ipnet-mask n)) - (rec :name (zone-parse-host "bcast" name) - :type :a - :data (ipnet-broadcast n))))) + (dolist (ipn (net-ipnets (net-must-find net))) + (let* ((base (ipnet-net ipn)) + (rrtype (ipaddr-rrtype base))) + (flet ((frob (kind addr) + (when addr + (rec :name (zone-parse-host kind name) + :type rrtype + :data addr)))) + (frob "net" base) + (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn))) + (frob "bcast" (ipnet-broadcast ipn))))))) (defzoneparse (:rev :reverse) (name data rec) - ":reverse ((NET :bytes BYTES) ZONE*) + ":reverse ((NET &key :prefix-bits :family) ZONE*) Add a reverse record each host in the ZONEs (or all zones) that lies - within NET. The BYTES give the number of prefix labels generated; this - defaults to the smallest number of bytes needed to enumerate the net." + within NET." (setf data (listify data)) - (destructuring-bind (net &key bytes) (listify (car data)) - (setf net (zone-parse-net net name)) - (unless bytes - (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) - (let ((seen (make-hash-table :test #'equal))) - (dolist (z (or (cdr data) - (hash-table-keys *zones*))) - (dolist (zr (zone-records (zone-find z))) - (when (and (eq (zr-type zr) :a) - (zr-make-ptr-p zr) - (ipaddr-networkp (zr-data zr) net)) - (let ((name (string-downcase - (join-strings - #\. - (collecting () - (dotimes (i bytes) - (collect (logand #xff (ash (zr-data zr) - (* -8 i))))) - (collect name)))))) - (unless (gethash name seen) - (rec :name name :type :ptr - :ttl (zr-ttl zr) :data (zr-name zr)) - (setf (gethash name seen) t))))))))) - -(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname) - ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*) - - Insert CNAME records for delegating a portion of the reverse-lookup - namespace which doesn't align with an octet boundary. - - The NET specifies the origin network, in which the reverse records - naturally lie. The BYTES are the number of labels to supply for each - address; the default is the smallest number which suffices to enumerate - the entire NET. The TARGET-NETs are subnets of NET which are to be - delegated. The TARGET-ZONEs are the zones to which we are delegating - authority for the reverse records: the default is to append labels for those - octets of the subnet base address which are not the same in all address in - the subnet." - (setf data (listify data)) - (destructuring-bind (net &key bytes) (listify (car data)) - (setf net (zone-parse-net net name)) - (unless bytes - (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) - (dolist (map (or (cdr data) (list (list net)))) - (destructuring-bind (tnets &optional tdom) (listify map) - (dolist (tnet (listify tnets)) - (setf tnet (zone-parse-net tnet name)) - (unless (ipnet-subnetp net tnet) - (error "~A is not a subnet of ~A." - (ipnet-pretty tnet) - (ipnet-pretty net))) - (unless tdom - (with-ipnet (net mask) tnet - (setf tdom - (join-strings - #\. - (append (reverse (loop - for i from (1- bytes) downto 0 - until (zerop (logand mask - (ash #xff - (* 8 i)))) - collect (ldb (byte 8 (* i 8)) net))) - (list name)))))) - (setf tdom (string-downcase (stringify tdom))) - (dotimes (i (ipnet-hosts tnet)) - (unless (zerop i) - (let* ((addr (ipnet-host tnet i)) - (tail (join-strings #\. - (loop - for i from 0 below bytes - collect - (logand #xff - (ash addr (* 8 i))))))) - (rec :name (format nil "~A.~A" tail name) - :type :cname - :data (format nil "~A.~A" tail tdom)))))))))) + (destructuring-bind (net &key prefix-bits (family *address-family*)) + (listify (car data)) + + (dolist (ipn (net-parse-to-ipnets net family)) + (let* ((seen (make-hash-table :test #'equal)) + (width (ipnet-width ipn)) + (frag-len (if prefix-bits (- width prefix-bits) + (ipnet-changeable-bits width (ipnet-mask ipn))))) + (dolist (z (or (cdr data) (hash-table-keys *zones*))) + (dolist (zr (zone-records (zone-find z))) + (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn))) + (zr-make-ptr-p zr) + (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn)) + (let* ((frag (reverse-domain-fragment (zr-data zr) + 0 frag-len)) + (name (concatenate 'string frag "." name))) + (unless (gethash name seen) + (rec :name name :type :ptr + :ttl (zr-ttl zr) :data (zr-name zr)) + (setf (gethash name seen) t)))))))))) + +(defzoneparse (:multi) (name data rec :zname zname :ttl ttl) + ":multi (((NET*) &key :start :end :family :suffix) . REC) + + Output multiple records covering a portion of the reverse-resolution + namespace corresponding to the particular NETs. The START and END bounds + default to the most significant variable component of the + reverse-resolution domain. + + The REC tail is a sequence of record forms (as handled by + `zone-process-records') to be emitted for each covered address. Within + the bodies of these forms, the symbol `*' will be replaced by the + domain-name fragment corresponding to the current host, optionally + followed by the SUFFIX. + + Examples: + + (:multi ((delegated-subnet :start 8) + :ns (some.ns.delegated.example :ip \"169.254.5.2\"))) + + (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\") + :cname *)) + + Obviously, nested `:multi' records won't work well." + + (destructuring-bind (nets &key start end (family *address-family*) suffix) + (listify (car data)) + (dolist (net (listify nets)) + (dolist (ipn (net-parse-to-ipnets net family)) + (let* ((addr (ipnet-net ipn)) + (width (ipaddr-width addr)) + (comp-width (reverse-domain-component-width addr)) + (end (round-up (or end + (ipnet-changeable-bits width + (ipnet-mask ipn))) + comp-width)) + (start (round-down (or start (- end comp-width)) + comp-width)) + (map (ipnet-host-map ipn))) + (multiple-value-bind (host-step host-limit) + (ipnet-index-bounds map start end) + (do ((index 0 (+ index host-step))) + ((> index host-limit)) + (let* ((addr (ipnet-index-host map index)) + (frag (reverse-domain-fragment addr start end)) + (target (concatenate 'string + (zone-make-name + (if (not suffix) frag + (concatenate 'string + frag "." suffix)) + zname) + "."))) + (dolist (zr (zone-parse-records (zone-make-name frag zname) + ttl + (subst target '* + (cdr data)))) + (rec :name (zr-name zr) + :type (zr-type zr) + :data (zr-data zr) + :ttl (zr-ttl zr) + :make-ptr-p (zr-make-ptr-p zr))))))))))) ;;;-------------------------------------------------------------------------- ;;; Zone file output. @@ -950,6 +928,9 @@ (subseq h 0 (- hl rl 1))) (t (concatenate 'string h ".")))))) +(export 'bind-record) +(defgeneric bind-record (type zr)) + (defmethod zone-write ((format (eql :bind)) zone stream) (format stream "~ ;;; Zone file `~(~A~)' @@ -985,9 +966,6 @@ $TTL ~2@*~D~2%" (dolist (zr (zone-records zone)) (bind-record (zr-type zr) zr))) -(export 'bind-record) -(defgeneric bind-record (type zr)) - (export 'bind-format-record) (defun bind-format-record (name ttl type format args) (format *zone-output-stream* @@ -998,14 +976,6 @@ $TTL ~2@*~D~2%" (string-upcase (symbol-name type)) format args)) -(defmethod bind-record (type zr) - (destructuring-bind (format &rest args) - (bind-record-format-args type (zr-data zr)) - (bind-format-record (zr-name zr) - (zr-ttl zr) - (bind-record-type type) - format args))) - (export 'bind-record-type) (defgeneric bind-record-type (type) (:method (type) type)) @@ -1027,4 +997,12 @@ $TTL ~2@*~D~2%" (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]" (mapcar #'stringify (listify data))))) +(defmethod bind-record (type zr) + (destructuring-bind (format &rest args) + (bind-record-format-args type (zr-data zr)) + (bind-format-record (zr-name zr) + (zr-ttl zr) + (bind-record-type type) + format args))) + ;;;----- That's all, folks -------------------------------------------------- -- 2.11.0