net.lisp: Report some more useful errors.

[zone] / net.lisp

;;; -*-lisp-*-
;;;
;;; Network (numbering) tools
;;;
;;; (c) 2006 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)

;;;--------------------------------------------------------------------------
;;; 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)))

(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.

   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.

   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."
  (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))

(defun natural-string< (string1 string2
                        &key (start1 0) (end1 nil)
                        (start2 0) (end2 nil))
  "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.

   In particular, digit sequences are handled in a moderately sensible way.
   Split the strings into maximally long alternating sequences of non-numeric
   and numeric characters, such that the non-numeric sequences are
   non-empty.  Compare these lexicographically; numeric sequences order
   according to their integer values, non-numeric sequences in the usual
   lexicographic ordering.

   Returns two values: whether STRING1 strictly precedes STRING2, and whether
   STRING1 strictly follows STRING2."

  (let ((end1 (or end1 (length string1)))
        (end2 (or end2 (length string2))))
    (loop
      (cond ((>= start1 end1)
             (let ((eqp (>= start2 end2)))
               (return (values (not eqp) nil))))
            ((>= start2 end2)
             (return (values nil t)))
            ((and (digit-char-p (char string1 start1))
                  (digit-char-p (char string2 start2)))
             (let* ((lim1 (or (position-if-not #'digit-char-p string1
                                               :start start1 :end end1)
                              end1))
                    (n1 (parse-integer string1 :start start1 :end lim1))
                    (lim2 (or (position-if-not #'digit-char-p string2
                                               :start start2 :end end2)
                              end2))
                    (n2 (parse-integer string2 :start start2 :end lim2)))
               (cond ((< n1 n2) (return (values t nil)))
                     ((> n1 n2) (return (values nil t))))
               (setf start1 lim1
                     start2 lim2)))
            (t
             (let ((lim1 (or (position-if #'digit-char-p string1
                                          :start start1 :end end1)
                             end1))
                   (lim2 (or (position-if #'digit-char-p string2
                                          :start start2 :end end2)
                             end2)))
               (cond ((string< string1 string2
                               :start1 start1 :end1 lim1
                               :start2 start2 :end2 lim2)
                      (return (values t nil)))
                     ((string> string1 string2
                               :start1 start1 :end1 lim1
                               :start2 start2 :end2 lim2)
                      (return (values nil t))))
               (setf start1 lim1
                     start2 lim2)))))))

;;;--------------------------------------------------------------------------
;;; 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 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)
  (:documentation "Return the address family of ADDR, as a keyword."))

(export 'family-addrclass)
(defgeneric family-addrclass (family)
  (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.")
  (:method ((af symbol)) nil))

(export 'ipaddr-width)
(defgeneric ipaddr-width (class)
  (:documentation "Return the width, in bits, of addresses from CLASS.

   Alternatively, the CLASS may be given as an example object.")
  (:method ((object t)) (ipaddr-width (extract-class-name object))))

(export 'ipaddr-comparable-p)
(defgeneric ipaddr-comparable-p (addr-a addr-b)
  (:documentation "Is it meaningful to compare ADDR-A and 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))
  "Return a class name for the address in (the given substring of) STR.

   This ought to be an extension point for additional address families, but
   it isn't at the moment."
  (cond ((position #\: str :start start :end end) 'ip6addr)
        (t 'ip4addr)))

(defgeneric parse-partial-ipaddr (class str &key start end min max)
  (:documentation
   "Parse (a substring of) STR into a partial address of the given CLASS.

   Returns three values: the parsed address fragment, as an integer; and the
   low and high bit positions covered by the response.

   The CLASS may instead be an example object of the required class.  The MIN
   and MAX arguments bound the number of bits acceptable in the response; the
   result is shifted so that the most significant component of the returned
   address is in the same component as bit position 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; 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))
  (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)
(defgeneric ipaddr-string (ip)
  (:documentation "Transform the address IP into a numeric textual 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 &optional like)
  "Convert IP to an IP address, of type similar to LIKE.

   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 (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 (width mask)
  "Given a netmask MASK, try to compute a prefix length.

   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 "Prefix length 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 'ipnet)
(export 'ipnet-net)
(export 'ipnet-mask)
(defclass ipnet (savable-object)
  ()
  (:documentation "Base class for IP networks."))

(export 'ipnet-family)
(defgeneric ipnet-family (ipn)
  (:documentation "Return the address family of IPN, as a keyword.")
  (:method ((ipn ipnet)) (ipaddr-family (ipnet-net 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 '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 addr mask) ipn &body body)
  "Evaluate the BODY with components of IPN in scope.

   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-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 nil mask) ipn
    (format nil "~A/~A"
            (ipaddr-string net)
            (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) (slashp t))
  "Parse a subnet description from (a substring of) STR.

   Suppose we have a parent network, with a prefix length of MAX.  The WIDTH
   gives the overall length of addresses of the appropriate class, i.e.,
   (ipaddr-width WIDTH), but in fact callers have already computed this for
   their own reasons.

   Parse (the designated substring of) STR to construct the base address of a
   subnet.  The string should have the form BASE/MASK, where the MASK is
   either a literal bitmask (in the usual syntax for addresses) or an integer
   prefix length.  An explicit prefix length is expected to cover the entire
   address including the parent prefix: an error is signalled if the prefix
   isn't long enough to cover any of the subnet.  A mask is parsed relative
   to the end of the parent address, just as the subnet base address is.

   Returns the relative base address and mask as two integer values."

  (setf-default end (length str))
  (let ((sl (and slashp (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)))))

(defun check-subipnet (base-ipn sub-addr sub-mask)
  "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN.

   The BASE-IPN is an `ipnet'; SUB-ADDR and SUB-MASK are plain integers.  If
   the subnet is invalid (i.e., the subnet disagrees with its putative parent
   over some of the fixed address bits) then an error is signalled; otherwise
   return the combined base address (as an `ipaddr') and mask (as an
   integer)."
  (with-ipnet (base-net base-addr base-mask) base-ipn
    (let* ((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"))
      (values (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 description from the string STR.

   A network description has the form ADDRESS/MASK, where the ADDRESS is a
   base address in numeric form, and the MASK is either a netmask in the same
   form, or an integer prefix length."
  (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)))))

(defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t))
  "Parse STR as a subnet of IPN.

   This is mostly a convenience interface over `parse-subnet'; we compute
   various of the parameters from IPN rather than requiring them to be passed
   in explicitly.

   Returns two values: the combined base address, as an `ipnaddr' and
   combined mask, as an integer."

  (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 (stringify str)
                      :start start :end end :slashp slashp)
      (check-subipnet ipn addr mask))))

(export 'string-subipnet)
(defun string-subipnet (ipn str &key (start 0) (end nil))
  "Parse an IP subnet from a parent net IPN and a suffix string STR.

   The (substring of) STR is expected to have the form ADDRESS/MASK, where
   ADDRESS is a relative subnet base address, and MASK is either a relative
   subnet mask or a (full) prefix length.  Returns the resulting ipnet.  If
   the relative base address overlaps with the existing subnet (because the
   base network's prefix length doesn't cover a whole number of components),
   then the subnet base must either agree in the overlapping portion with the
   parent base address or be zero.

   For example, if IPN is the network 172.29.0.0/16, then `199/24' or
   `199/255' both designate the subnet 172.29.199.0/24.  Similarly, starting
   from 2001:ba8:1d9:8000::/52, then `8042/ffff' and `42/64' both designate
   the network 2001:ba8:1d9:8042::/64."

  (multiple-value-bind (addr mask)
      (parse-subipnet ipn str :start start :end end)
    (ipaddr-ipnet 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)
(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 (- (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.

   The HOST may be a an integer index into the network (this works even with
   a non-contiguous netmask) or a string or symbolic suffix (as for
   `string-subnet')."
  (etypecase host
    (integer
     (ipnet-index-host (ipnet-host-map ipn) host))
    ((or symbol string)
     (multiple-value-bind (addr mask)
         (parse-subipnet ipn host :slashp nil)
       (unless (= mask (mask (ipaddr-width addr)))
         (error "Host address incomplete"))
       addr))))

(export 'ipaddr-networkp)
(defun ipaddr-networkp (ip ipn)
  "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 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-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)))

;;;--------------------------------------------------------------------------
;;; Domain names.

(export '(domain-name make-domain-name domain-name-p
          domain-name-labels domain-name-absolutep))
(defstruct domain-name
  "A domain name, which is a list of labels.

   The most significant (top-level) label is first, so they're in
   right-to-left order.."
  (labels nil :type list)
  (absolutep nil :type boolean))

(export 'quotify-label)
(defun quotify-label (string)
  "Quote an individual label STRING, using the RFC1035 rules.

   A string which contains only printable characters other than `.', `@',
   `\"', `\\', `;', `(' and `)' is returned as is.  Other strings are
   surrounded with quotes, and special characters (now only `\\', `\"' and
   unprintable things) are escaped -- printable characters are preceded by
   backslashes, and non-printable characters are represented as \\DDD decimal
   codes."

  (if (every (lambda (ch)
               (and (<= 33 (char-code ch) 126)
                    (not (member ch '(#\. #\@ #\" #\\ #\; #\( #\))))))
             string)
      string
      (with-output-to-string (out)
        (write-char #\" out)
        (dotimes (i (length string))
          (let ((ch (char string i)))
            (cond ((or (eql ch #\") (eql ch #\\))
                   (write-char #\\ out)
                   (write-char ch out))
                  ((<= 32 (char-code ch) 126)
                   (write-char ch out))
                  (t
                   (format out "\\~3,'0D" (char-code ch))))))
        (write-char #\" out))))

(defun unquotify-label (string &key (start 0) (end nil))
  "Parse and unquote a label from the STRING.

   Returns the parsed label, and the position of the next label."

  (let* ((end (or end (length string)))
         (i start)
         (label (with-output-to-string (out)
                  (labels
                      ((numeric-escape-char ()
                         ;; We've just seen a `\', and the next character is
                         ;; a digit.  Read the three-digit sequence, and
                         ;; return the appropriate character, or nil if the
                         ;; sequence was invalid.

                         (let* ((e (+ i 3))
                                (code
                                 (and (<= e end)
                                      (do ((j i (1+ j))
                                           (a 0
                                              (let ((d (digit-char-p
                                                        (char string j))))
                                                (and a d (+ (* 10 a) d)))))
                                          ((>= j e) a)))))
                           (unless (<= 0 code 255)
                             (error "Escape code out of range."))
                           (setf i e)
                           (and code (code-char code))))

                       (hack-backslash ()
                         ;; We've just seen a `\'.  Read the next character
                         ;; and write it to the output stream.

                         (let ((ch (cond ((>= i end) nil)
                                         ((not (digit-char-p
                                                (char string i)))
                                          (prog1 (char string i)
                                            (incf i)))
                                         (t (numeric-escape-char)))))
                           (unless ch
                             (error "Invalid escape in label."))
                           (write-char ch out)))

                       (munch (delim)
                         ;; Read characters until we reach an unescaped copy
                         ;; of DELIM, writing the unescaped versions to the
                         ;; output stream.  Return nil if we hit the end, or
                         ;; the delimiter character.

                         (loop
                           (when (>= i end) (return nil))
                           (let ((ch (char string i)))
                             (incf i)
                             (cond ((char= ch #\\)
                                    (hack-backslash))
                                   ((char= ch delim)
                                    (return ch))
                                   (t
                                    (write-char ch out)))))))

                    ;; If the label starts with a `"' then continue until we
                    ;; get to the next `"', which must either end the string,
                    ;; or be followed by a `.'.  If the label isn't quoted,
                    ;; then munch until the `.'.
                    (cond
                      ((and (< i end) (char= (char string i) #\"))
                       (incf i)
                       (let ((delim (munch #\")))
                         (unless (and delim
                                      (or (= i end)
                                          (char= (prog1 (char string i)
                                                   (incf i))
                                                 #\.)))
                           (error "Invalid quoting in label."))))
                      (t
                       (munch #\.)))))))

    ;; We're done.  Phew!
    (when (string= label "")
      (error "Empty labels aren't allowed."))
    (values label i)))

(export 'parse-domain-name)
(defun parse-domain-name (string &key (start 0) (end nil) absolutep)
  "Parse (a substring of) STRING as a possibly-relative domain name.

   If STRING doesn't end in an unquoted `.', then it's relative (to some
   unspecified parent domain).  The input may be the special symbol `@' to
   refer to the parent itself, `.' to mean the root, or a sequence of labels
   separated by `.'.  The final name is returned as a `domain-name' object."

  (let ((end (or end (length string)))
        (i start))
    (flet ((parse ()
             ;; Parse a sequence of labels.

             (let ((labels nil))
               (loop
                 (unless (< i end) (return))
                 (multiple-value-bind (label j)
                     (unquotify-label string :start i :end end)
                   (push label labels)
                   (setf i j)))
               (unless labels
                 (error "Empty domain names have special notations."))
               (make-domain-name :labels labels :absolutep absolutep))))

      (cond ((= (1+ i) end)
             ;; A single-character name.  Check for the magic things;
             ;; otherwise I guess it must just be short.

             (case (char string i)
               (#\@ (make-domain-name :labels nil :absolutep nil))
               (#\. (make-domain-name :labels nil :absolutep t))
               (t (parse))))

            (t
             ;; Something more complicated.  If the name ends with `.', but
             ;; not `\\.', then it must be absolute.
             (when (and (< i end)
                        (char= (char string (- end 1)) #\.)
                        (char/= (char string (- end 2)) #\\))
               (decf end)
               (setf absolutep t))
             (parse))))))

(defmethod print-object ((name domain-name) stream)
  "Print a domain NAME to a STREAM, using RFC1035 quoting rules."
  (let ((labels (mapcar #'quotify-label
                        (reverse (domain-name-labels name)))))
    (cond (*print-escape*
           (print-unreadable-object (name stream :type t)
             (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~@[.~]~]"
                     labels (domain-name-absolutep name))))
          (t
           (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~]"
                   labels (domain-name-absolutep name))))))

(export 'domain-name-concat)
(defun domain-name-concat (left right)
  "Concatenate the LEFT and RIGHT names."
  (if (domain-name-absolutep left)
      left
      (make-domain-name :labels (append (domain-name-labels right)
                                        (domain-name-labels left))
                        :absolutep (domain-name-absolutep right))))

(export 'domain-name<)
(defun domain-name< (name-a name-b)
  "Answer whether NAME-A precedes NAME-B in an ordering of domain names.

   Split the names into labels, and then lexicographically compare the
   sequences of labels, right to left, using `natural-string<'.

   Returns two values: whether NAME-A strictly precedes NAME-B, and whether
   NAME-A strictly follows NAME-B.

   This doesn't give useful answers on relative domains unless you know what
   you're doing."

  (let ((labels-a (domain-name-labels name-a))
        (labels-b (domain-name-labels name-b)))
    (loop (cond ((null labels-a)
                 (return (values (not (null labels-b)) (null labels-b))))
                ((null labels-b)
                 (return (values nil t)))
                (t
                 (multiple-value-bind (precp follp)
                     (natural-string< (pop labels-a) (pop labels-b))
                   (cond (precp (return (values t nil)))
                         (follp (return (values nil t))))))))))

(export 'root-domain)
(defparameter root-domain (make-domain-name :labels nil :absolutep t)
  "The root domain, as a convenient object.")

;;;--------------------------------------------------------------------------
;;; 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)))

      (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))
           (comps nil (cons (format nil "~(~vR~)" radix
                                    (ldb (byte comp-width i) addr))
                            comps)))
          ((>= i limit) (make-domain-name :labels comps))))))

(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)))
      (domain-name-concat (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 width)
                      (or prefix-len width)))))

;;;--------------------------------------------------------------------------
;;; Network names and specifiers.

(export 'net)
(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.")

(export 'net-find)
(defun net-find (name)
  "Find a network by NAME."
  (gethash (string-downcase (stringify name)) *networks*))
(defun (setf net-find) (net name)
  "Make NAME map to NET."
  (setf (gethash (string-downcase (stringify name)) *networks*) net))

(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.

   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 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)
  "Main network definition macro.

   None of the arguments is evaluated."
  `(progn
     ,@(mapcar (lambda (item)
                 (let ((name (car item)) (ipn (cdr item)))
                   `(net-create ',name ',ipn)))
               (process-net-form name net subnets))
     ',name))

(defun filter-by-family (func form family)
  "Handle a family-switch form.

   Here, FUNC is a function of two arguments ITEM and FAMILY.  FORM is either
   a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly
   acceptable to FUNC.  Return a list of the resulting outputs of FUNC."

  (if (and (listp form)
           (every (lambda (clause)
                    (and (listp clause)
                         (family-addrclass (car clause))))
                  form))
      (mapcan (lambda (clause)
                (let ((fam (car clause)))
                  (and (or (eq family t)
                           (eq family fam))
                       (list (funcall func (cdr clause) fam)))))
              form)
      (list (funcall func form family))))

(export 'net-parse-to-ipnets)
(defun net-parse-to-ipnets (form &optional (family t))
  "Parse FORM into a list of ipnet objects.

   The FORM can be any of the following.

     * NAME -- a named network, established using `net-create' or `defnet'

     * IPNET -- a network, in a form acceptable to `ipnet'

     * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY"

  (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 (apply #'append (filter-by-family #'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 addresses match ~S~:[ in family ~S~;~*~]."
                 form (eq family t) family)))))

(export 'net-host)
(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), a suffix (as a symbol or
   string, as for `string-subnet'), or one of the keywords:

   :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))
                   (if (integerp host)
                       (remove host ipns :key #'ipnet-hosts :test #'>=)
                       ipns))))
    (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 "~:[<anonymous>~;~@*~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* ((list (filter-by-family #'hack addr family))
           (host (if (and list (cdr list))
                     (make-instance 'host
                                    :addrs (reduce #'merge-addresses
                                                   (mapcar #'host-addrs
                                                           (reverse list))
                                                   :initial-value nil))
                     (car list))))
      (unless (host-addrs host)
        (error "No addresses match ~S~:[ in family ~S~;~*~]."
               addr (eq family t) family))
      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 --------------------------------------------------