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