net.lisp: net.lisp: Refactor `string-subipnet' and its friends.

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

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

(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))
  (cond ((position #\: str :start start :end end) 'ip6addr)
	(t '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; 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 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 &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)
  (: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."
  (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 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)))))

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

   This works even with a non-contiguous netmask."
  (ipnet-index-host (ipnet-host-map ipn) host))

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

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

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

   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 "~:[<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 ((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 --------------------------------------------------