zone: Allow definitions of subnets in defnet

This makes it rather easier to describe the distorted.org.uk zones.

diff --git a/zone.lisp b/zone.lisp
index 065e53ad36e0b54664bce9f1c3f983010282faf9..140ade5e573e17f15797992fac4fc926c41f6c1f 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -137,6 +137,13 @@ (defun iso-date (&optional time &key datep timep (sep #\ ))
       (when timep
        (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 
       (when timep
        (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 

+(defun count-low-zero-bits (n)
+  "Return the number of low-order zero bits in the integer N."
+  (if (zerop n) nil
+      (loop for i from 0
+           until (logbitp i n)
+           finally (return i))))
+

 ;;;--------------------------------------------------------------------------
 ;;; Simple messing with IP addresses.
 
 ;;;--------------------------------------------------------------------------
 ;;; Simple messing with IP addresses.
 


@@ -234,16 +241,14 @@ (defun string-ipnet (str &key (start 0) (end nil))
        (make-ipnet (parse-ipaddr (subseq str start end))
                    (integer-netmask 32)))))
 
        (make-ipnet (parse-ipaddr (subseq str start end))
                    (integer-netmask 32)))))
 

-(defun ipnet (net &optional mask)
-  "Construct an IP-network object from the given arguments.  A number of
+(defun ipnet (net)
+  "Construct an IP-network object from the given argument.  A number of

 forms are acceptable:
 
 forms are acceptable:
 

-  * NET MASK -- as for `make-ipnet'.

   * ADDR -- a single address (equivalent to ADDR 32)
   * (NET . MASK|nil) -- a single-object representation.
   * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
   * ADDR -- a single address (equivalent to ADDR 32)
   * (NET . MASK|nil) -- a single-object representation.
   * IPNET -- return an equivalent (`equal', not necessarily `eql') version."

-  (cond (mask (make-ipnet net mask))
-       ((or (stringp net) (symbolp net)) (string-ipnet net))
+  (cond ((or (stringp net) (symbolp net)) (string-ipnet net))

        (t (apply #'make-ipnet (pairify net 32)))))
 
 (defun ipnet-net (ipn)
        (t (apply #'make-ipnet (pairify net 32)))))
 
 (defun ipnet-net (ipn)


@@ -425,22 +430,50 @@ (defun net-get-as-ipnet (form)
     (if net (net-ipnet net)
        (ipnet form))))
 
     (if net (net-ipnet net)
        (ipnet form))))
 

-(defun net-create (name &rest args)
+(defun process-net-form (root addr subnets)
+  "Unpack a net-form.  The return value is a list of entries, each of which
+is a list of the form (NAME ADDR MASK).  The first entry is merely repeats
+the given ROOT and ADDR arguments (unpacking ADDR into separate network
+address and mask).  The SUBNETS are then processed: they are a list of items
+of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
+NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
+the same form.  An error is signalled if a net's subnets use up more hosts
+than the net has to start with."
+  (labels ((frob (subnets limit finger)
+            (when subnets
+              (destructuring-bind (name size &rest subs) (car subnets)
+                (when (> (count-low-zero-bits size)
+                         (count-low-zero-bits finger))
+                  (error "Bad subnet size for ~A." name))
+                (when (> (+ finger size) limit)
+                  (error "Subnet ~A out of range." name))
+                (append (and name
+                             (list (list name finger (- (ash 1 32) size))))
+                        (frob subs (+ finger size) finger)
+                        (frob (cdr subnets) limit (+ finger size)))))))
+    (let ((ipn (ipnet addr)))
+      (with-ipnet (net mask) ipn
+       (unless (ipmask-cidl-slash mask)
+         (error "Bad mask for subnet form."))
+       (cons (list root net mask)
+             (frob subnets (+ net (ipnet-hosts ipn) 1) net))))))
+
+(defun net-create (name net)

   "Construct a new network called NAME and add it to the map.  The ARGS
 describe the new network, in a form acceptable to the ipnet function."
   "Construct a new network called NAME and add it to the map.  The ARGS
 describe the new network, in a form acceptable to the ipnet function."

-  (let ((ipn (apply #'ipnet args)))
+  (let ((ipn (ipnet net)))

     (setf (net-find name)
          (make-net :name (string-downcase (stringify name))
                    :ipnet ipn
                    :hosts (ipnet-hosts ipn)
                    :next 1))))
 
     (setf (net-find name)
          (make-net :name (string-downcase (stringify name))
                    :ipnet ipn
                    :hosts (ipnet-hosts ipn)
                    :next 1))))
 

-(defmacro defnet (name &rest args)
-  "Main network definition macro.  Neither NAME nor any of the ARGS is
-evaluated."
+(defmacro defnet (name net &rest subnets)
+  "Main network definition macro.  None of the arguments is evaluated."

   `(progn
   `(progn

-     (net-create ',name ,@(mapcar (lambda (x) `',x) args))
-     ',name))
+    ,@(loop for (name addr mask) in (process-net-form name net subnets)
+           collect `(net-create ',name '(,addr . ,mask)))
+    ',name))

 
 (defun net-next-host (net)
   "Given a NET, return the IP address (as integer) of the next available
 
 (defun net-next-host (net)
   "Given a NET, return the IP address (as integer) of the next available