3 ;;; Network (numbering) tools
5 ;;; (c) 2006 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 2 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software Foundation,
22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 ;;;--------------------------------------------------------------------------
27 ;;; Various random utilities.
29 (declaim (inline mask))
31 "Return 2^N - 1: i.e., a mask of N set bits."
34 (defun find-first-bit-transition
35 (mask &optional (low 0) (high (integer-length mask)))
36 "Find the first (lowest bit-position) transition in MASK within the bounds.
38 The LOW bound is inclusive; the high bound is exclusive. A transition is
39 a change from zero to one, or vice-versa. The return value is the
40 upper (exclusive) bound on the initial run, and the lower (inclusive)
43 If there is no transition within the bounds, then return HIGH."
45 ;; Arrange that the initial run is ones.
46 (unless (logbitp low mask) (setf mask (lognot mask)))
48 ;; Now, note that MASK + 2^LOW is identical to MASK in all bit positions
49 ;; except for (a) the run of one bits starting at LOW, and (b) the zero bit
50 ;; just above it. So MASK xor (MASK + 2^LOW) is zero except for these
51 ;; bits; so all we need now is to find the position of its most significant
53 (let ((pos (1- (integer-length (logxor mask (+ mask (ash 1 low)))))))
54 (if (<= low pos high) pos high)))
56 (defun count-low-zero-bits (n)
57 "Return the number of low-order zero bits in the integer N."
60 (t (find-first-bit-transition n))))
62 (declaim (inline round-down))
63 (defun round-down (n step)
64 "Return the largest multiple of STEP not greater than N."
65 (* step (floor n step)))
67 (declaim (inline round-up))
68 (defun round-up (n step)
69 "Return the smallest multiple of STEP not less than N."
70 (* step (ceiling n step)))
72 (defgeneric extract-class-name (object)
73 (:documentation "Turn OBJECT into a class name.")
74 (:method ((instance standard-object))
75 (extract-class-name (class-of instance)))
76 (:method ((class standard-class))
78 (:method ((name symbol))
81 (defclass savable-object ()
83 (defmethod make-load-form ((object savable-object) &optional environment)
84 (make-load-form-saving-slots object :environment environment))
86 (defun natural-string< (string1 string2
87 &key (start1 0) (end1 nil)
88 (start2 0) (end2 nil))
89 "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
91 In particular, digit sequences are handled in a moderately sensible way.
92 Split the strings into maximally long alternating sequences of non-numeric
93 and numeric characters, such that the non-numeric sequences are
94 non-empty. Compare these lexicographically; numeric sequences order
95 according to their integer values, non-numeric sequences in the usual
96 lexicographic ordering.
98 Returns two values: whether STRING1 strictly precedes STRING2, and whether
99 STRING1 strictly follows STRING2."
101 (let ((end1 (or end1 (length string1)))
102 (end2 (or end2 (length string2))))
104 (cond ((>= start1 end1)
105 (let ((eqp (>= start2 end2)))
106 (return (values (not eqp) nil))))
108 (return (values nil t)))
109 ((and (digit-char-p (char string1 start1))
110 (digit-char-p (char string2 start2)))
111 (let* ((lim1 (or (position-if-not #'digit-char-p string1
112 :start start1 :end end1)
114 (n1 (parse-integer string1 :start start1 :end lim1))
115 (lim2 (or (position-if-not #'digit-char-p string2
116 :start start2 :end end2)
118 (n2 (parse-integer string2 :start start2 :end lim2)))
119 (cond ((< n1 n2) (return (values t nil)))
120 ((> n1 n2) (return (values nil t))))
124 (let ((lim1 (or (position-if #'digit-char-p string1
125 :start start1 :end end1)
127 (lim2 (or (position-if #'digit-char-p string2
128 :start start2 :end end2)
130 (cond ((string< string1 string2
131 :start1 start1 :end1 lim1
132 :start2 start2 :end2 lim2)
133 (return (values t nil)))
134 ((string> string1 string2
135 :start1 start1 :end1 lim1
136 :start2 start2 :end2 lim2)
137 (return (values nil t))))
141 ;;;--------------------------------------------------------------------------
142 ;;; Parsing primitives for addresses.
144 (defun parse-partial-address
146 &key (start 0) (end nil) (delim #\.)
147 (width 8) (radix 10) (min 1) (max 32) (shiftp t)
149 "Parse a partial address from STR, which should be a sequence of integers
150 in the given RADIX, separated by the DELIM character, with each integer
151 N_i in the interval 0 <= N_i < 2^WIDTH. If the sequence is N_1, N_2, ...,
152 N_k, then the basic partial address BPA is the sum
154 SUM_{1<=i<=k} 2^{WIDTH (k-i)} N_i
156 If SHIFTP is true (the default) then let OFFSET be the smallest multiple
157 of WIDTH not less than MAX - k WIDTH; otherwise, let OFFSET be zero. The
158 partial address PA is BPA 2^SHIFT.
160 The return values are: PA, OFFSET, k WIDTH + OFFSET; i.e., the partial
161 address, and (inclusive) lower and (exclusive) upper bounds on the bits
164 (setf-default end (length str))
165 (let ((addr 0) (nbits 0) (limit (ash 1 width)))
169 (error "Too many elements in ~A" what))
170 (let* ((pos (position delim str :start start :end end))
171 (w (parse-integer str :radix radix
172 :start start :end (or pos end))))
173 (unless (and (<= 0 w) (< w limit))
174 (error "Element out of range in ~A" what))
175 (setf addr (logior (ash addr width) w))
177 (unless pos (return))
178 (setf start (1+ pos)))))
180 (error "Not enough elements in ~A" what))
182 (let* ((top (round-up max width))
183 (shift (- top nbits)))
184 (values (ash addr shift) shift top))
185 (values addr 0 nbits))))
187 ;;;--------------------------------------------------------------------------
188 ;;; Simple messing about with IP addresses.
191 (export 'ipaddr-addr)
192 (defclass ipaddr (savable-object)
195 "Base class for IP addresses."))
197 (export 'ipaddr-family)
198 (defgeneric ipaddr-family (addr)
199 (:documentation "Return the address family of ADDR, as a keyword."))
201 (export 'family-addrclass)
202 (defgeneric family-addrclass (family)
203 (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.")
204 (:method ((af symbol)) nil))
206 (export 'ipaddr-width)
207 (defgeneric ipaddr-width (class)
208 (:documentation "Return the width, in bits, of addresses from CLASS.
210 Alternatively, the CLASS may be given as an example object.")
211 (:method ((object t)) (ipaddr-width (extract-class-name object))))
213 (export 'ipaddr-comparable-p)
214 (defgeneric ipaddr-comparable-p (addr-a addr-b)
215 (:documentation "Is it meaningful to compare ADDR-A and ADDR-B?")
216 (:method ((addr-a ipaddr) (addr-b ipaddr))
217 (eq (class-of addr-a) (class-of addr-b))))
219 (defun guess-address-class (str &key (start 0) (end nil))
220 "Return a class name for the address in (the given substring of) STR.
222 This ought to be an extension point for additional address families, but
223 it isn't at the moment."
224 (cond ((position #\: str :start start :end end) 'ip6addr)
227 (defgeneric parse-partial-ipaddr (class str &key start end min max)
229 "Parse (a substring of) STR into a partial address of the given CLASS.
231 Returns three values: the parsed address fragment, as an integer; and the
232 low and high bit positions covered by the response.
234 The CLASS may instead be an example object of the required class. The MIN
235 and MAX arguments bound the number of bits acceptable in the response; the
236 result is shifted so that the most significant component of the returned
237 address is in the same component as bit position MAX.")
238 (:method ((object t) str &rest keywords)
239 (apply #'parse-partial-ipaddr (extract-class-name object) str keywords)))
241 (export 'string-ipaddr)
242 (defun string-ipaddr (str &key (start 0) (end nil))
243 "Parse STR into an address; guess what kind is intended by the user.
245 STR may be anything at all: it's converted as if by `stringify'.
246 The START and END arguments may be used to parse out a substring."
247 (setf str (stringify str))
248 (let* ((class (guess-address-class str :start start :end end))
249 (width (ipaddr-width class)))
250 (make-instance class :addr
251 (parse-partial-ipaddr class str
252 :start start :end end
253 :min width :max width))))
255 (export 'integer-ipaddr)
256 (defgeneric integer-ipaddr (int like)
257 (:documentation "Convert INT into an address of type indicated by LIKE.
259 Specifically, if LIKE is an address object, then use its type; if it's
260 a class, then use it directly; if it's a symbol, then use the class it
262 (:method (int (like t)) (integer-ipaddr int (class-of like)))
263 (:method (int (like symbol))
264 (make-instance (or (family-addrclass like) like) :addr int))
265 (:method (int (like standard-class)) (make-instance like :addr int)))
267 (export 'ipaddr-string)
268 (defgeneric ipaddr-string (ip)
269 (:documentation "Transform the address IP into a numeric textual form."))
271 (defmethod print-object ((addr ipaddr) stream)
273 (print-unreadable-object (addr stream :type t)
274 (write-string (ipaddr-string addr) stream))
275 (write-string (ipaddr-string addr) stream)))
279 "Answer true if IP is a valid IP address in integer form."
282 (defun ipaddr (ip &optional like)
283 "Convert IP to an IP address, of type similar to LIKE.
285 If it's an IP address, just return it unchanged; If it's an integer,
286 capture it; otherwise convert by `string-ipaddr'."
289 (integer (integer-ipaddr ip like))
290 (t (string-ipaddr ip))))
292 (export 'ipaddr-rrtype)
293 (defgeneric ipaddr-rrtype (addr)
294 (:documentation "Return the proper resource record type for ADDR."))
296 ;;;--------------------------------------------------------------------------
299 (export 'integer-netmask)
300 (defun integer-netmask (n i)
301 "Given an integer I, return an N-bit netmask with its I top bits set."
302 (- (ash 1 n) (ash 1 (- n i))))
304 (export 'ipmask-cidr-slash)
305 (defun ipmask-cidr-slash (width mask)
306 "Given a netmask MASK, try to compute a prefix length.
308 Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if
310 (let* ((low (logxor mask (mask width)))
311 (bits (integer-length low)))
312 (and (= low (mask bits)) (- width bits))))
315 (defgeneric ipmask (addr mask)
316 (:documentation "Convert MASK into a suitable netmask for ADDR.")
317 (:method ((addr ipaddr) (mask null))
318 (mask (ipaddr-width addr)))
319 (:method ((addr ipaddr) (mask integer))
320 (let ((w (ipaddr-width addr)))
322 (integer-netmask w mask)
323 (error "Prefix length out of range.")))))
325 (export 'mask-ipaddr)
326 (defun mask-ipaddr (addr mask)
327 "Apply the MASK to the ADDR, returning the base address."
328 (integer-ipaddr (logand mask (ipaddr-addr addr)) addr))
330 ;;;--------------------------------------------------------------------------
331 ;;; Networks: pairing an address and netmask.
336 (defclass ipnet (savable-object)
338 (:documentation "Base class for IP networks."))
340 (export 'ipnet-family)
341 (defgeneric ipnet-family (ipn)
342 (:documentation "Return the address family of IPN, as a keyword.")
343 (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn))))
346 (defun ipnet-addr (ipn)
347 "Return the base network address of IPN as a raw integer."
348 (ipaddr-addr (ipnet-net ipn)))
350 (export 'ipaddr-ipnet)
351 (defgeneric ipaddr-ipnet (addr mask)
352 (:documentation "Construct an `ipnet' object given a base ADDR and MASK."))
355 (defun make-ipnet (net mask)
356 "Construct an IP-network object given the NET and MASK.
358 These are transformed as though by `ipaddr' and `ipmask'."
359 (let* ((net (ipaddr net))
360 (mask (ipmask net mask)))
361 (ipaddr-ipnet (mask-ipaddr net mask) mask)))
364 (defmacro with-ipnet ((net addr mask) ipn &body body)
365 "Evaluate the BODY with components of IPN in scope.
367 The NET is bound to the underlying network base address, as an `ipaddr';
368 ADDR is bound to the integer value of this address; and MASK is bound to
369 the netmask, again as an integer. Any (or all) of these may be nil if not
373 (let (,@(and net `((,net (ipnet-net ,tmp))))
374 ,@(and addr `((,addr (ipnet-addr ,tmp))))
375 ,@(and mask `((,mask (ipnet-mask ,tmp)))))
378 (export 'ipnet-width)
379 (defun ipnet-width (ipn)
380 "Return the underlying bit width of the addressing system."
381 (ipaddr-width (ipnet-net ipn)))
383 (export 'ipnet-string)
384 (defun ipnet-string (ipn)
385 "Convert IPN to a string."
386 (with-ipnet (net nil mask) ipn
389 (or (ipmask-cidr-slash (ipnet-width ipn) mask)
390 (ipaddr-string (make-instance (class-of net) :addr mask))))))
392 (defmethod print-object ((ipn ipnet) stream)
394 (print-unreadable-object (ipn stream :type t)
395 (write-string (ipnet-string ipn) stream))
396 (write-string (ipnet-string ipn) stream)))
398 (defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
399 "Parse a subnet description from (a substring of) STR.
401 Suppose we have a parent network, with a prefix length of MAX. The WIDTH
402 gives the overall length of addresses of the appropriate class, i.e.,
403 (ipaddr-width WIDTH), but in fact callers have already computed this for
406 Parse (the designated substring of) STR to construct the base address of a
407 subnet. The string should have the form BASE/MASK, where the MASK is
408 either a literal bitmask (in the usual syntax for addresses) or an integer
409 prefix length. An explicit prefix length is expected to cover the entire
410 address including the parent prefix: an error is signalled if the prefix
411 isn't long enough to cover any of the subnet. A mask is parsed relative
412 to the end of the parent address, just as the subnet base address is.
414 Returns the relative base address and mask as two integer values."
416 (setf-default end (length str))
417 (let ((sl (and slashp (position #\/ str :start start :end end))))
418 (multiple-value-bind (addr lo hi)
419 (parse-partial-ipaddr class str :max max
420 :start start :end (or sl end))
421 (let* ((present (integer-netmask hi (- hi lo)))
422 (mask (cond ((not sl)
424 ((every #'digit-char-p (subseq str (1+ sl) end))
425 (let ((length (parse-integer str
428 (unless (>= length (- width max))
429 (error "Mask doesn't reach subnet boundary"))
430 (integer-netmask max (- length (- width max)))))
432 (parse-partial-ipaddr class str :max max
433 :start (1+ sl) :end end)))))
434 (unless (zerop (logandc2 mask present))
435 (error "Mask selects bits not present in base address"))
436 (values addr mask)))))
438 (defun check-subipnet (base-ipn sub-addr sub-mask)
439 "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN.
441 The BASE-IPN is an `ipnet'; SUB-ADDR and SUB-MASK are plain integers. If
442 the subnet is invalid (i.e., the subnet disagrees with its putative parent
443 over some of the fixed address bits) then an error is signalled; otherwise
444 return the combined base address (as an `ipaddr') and mask (as an
446 (with-ipnet (base-net base-addr base-mask) base-ipn
447 (let* ((common (logand base-mask sub-mask))
448 (base-overlap (logand base-addr common))
449 (sub-overlap (logand sub-addr common))
450 (full-mask (logior base-mask sub-mask)))
451 (unless (or (zerop sub-overlap) (= sub-overlap base-overlap))
452 (error "Subnet doesn't match base network"))
453 (values (integer-ipaddr (logand full-mask (logior base-addr sub-addr))
457 (export 'string-ipnet)
458 (defun string-ipnet (str &key (start 0) (end nil))
459 "Parse an IP network description from the string STR.
461 A network description has the form ADDRESS/MASK, where the ADDRESS is a
462 base address in numeric form, and the MASK is either a netmask in the same
463 form, or an integer prefix length."
464 (setf str (stringify str))
465 (setf-default end (length str))
466 (let ((addr-class (guess-address-class str :start start :end end)))
467 (multiple-value-bind (addr mask)
468 (let ((width (ipaddr-width addr-class)))
469 (parse-subnet addr-class width width str
470 :start start :end end))
471 (make-ipnet (make-instance addr-class :addr addr)
472 (make-instance addr-class :addr mask)))))
474 (defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t))
475 "Parse STR as a subnet of IPN.
477 This is mostly a convenience interface over `parse-subnet'; we compute
478 various of the parameters from IPN rather than requiring them to be passed
481 Returns two values: the combined base address, as an `ipnaddr' and
482 combined mask, as an integer."
484 (let* ((addr-class (extract-class-name (ipnet-net ipn)))
485 (width (ipaddr-width addr-class))
487 (or (ipmask-cidr-slash width (ipnet-mask ipn))
488 (error "Base network has complex netmask")))))
489 (multiple-value-bind (addr mask)
490 (parse-subnet addr-class width max (stringify str)
491 :start start :end end :slashp slashp)
492 (check-subipnet ipn addr mask))))
494 (export 'string-subipnet)
495 (defun string-subipnet (ipn str &key (start 0) (end nil))
496 "Parse an IP subnet from a parent net IPN and a suffix string STR.
498 The (substring of) STR is expected to have the form ADDRESS/MASK, where
499 ADDRESS is a relative subnet base address, and MASK is either a relative
500 subnet mask or a (full) prefix length. Returns the resulting ipnet. If
501 the relative base address overlaps with the existing subnet (because the
502 base network's prefix length doesn't cover a whole number of components),
503 then the subnet base must either agree in the overlapping portion with the
504 parent base address or be zero.
506 For example, if IPN is the network 172.29.0.0/16, then `199/24' or
507 `199/255' both designate the subnet 172.29.199.0/24. Similarly, starting
508 from 2001:ba8:1d9:8000::/52, then `8042/ffff' and `42/64' both designate
509 the network 2001:ba8:1d9:8042::/64."
511 (multiple-value-bind (addr mask)
512 (parse-subipnet ipn str :start start :end end)
513 (ipaddr-ipnet addr mask)))
516 "Construct an IP-network object from the given argument.
518 A number of forms are acceptable:
520 * ADDR -- a single address, equivalent to (ADDR . N).
521 * (NET . MASK|nil) -- a single-object representation.
522 * IPNET -- return an equivalent (`equal', not necessarily `eql')
526 ((or string symbol) (string-ipnet net))
527 (t (apply #'make-ipnet (pairify net nil)))))
529 (export 'ipnet-broadcast)
530 (defgeneric ipnet-broadcast (ipn)
531 (:documentation "Return the broadcast address for the network IPN.
533 Returns nil if there isn't one."))
535 (export 'ipnet-hosts)
536 (defun ipnet-hosts (ipn)
537 "Return the number of available addresses in network IPN."
538 (ash 1 (- (ipnet-width ipn) (logcount (ipnet-mask ipn)))))
541 "An internal object used by `ipnet-index-host' and `ipnet-host-index'.
543 Our objective is to be able to convert between flat host indices and a
544 possibly crazy non-flat host space. We record the underlying IPNET for
545 convenience, and a list of byte-specifications for the runs of zero bits
546 in the netmask, in ascending order."
550 (export 'ipnet-host-map)
551 (defun ipnet-host-map (ipn)
552 "Work out how to enumerate the variable portion of IPN.
554 Returns an object which can be passed to `ipnet-index-host' and
556 (let* ((mask (ipnet-mask ipn)) (bytes nil) (i 0)
557 (len (integer-length mask)) (width (ipnet-width ipn)))
558 (when (logbitp i mask) (setf i (find-first-bit-transition mask i)))
560 (unless (< i len) (return))
561 (let ((next (find-first-bit-transition mask i width)))
562 (push (byte (- next i) i) bytes)
563 (setf i (find-first-bit-transition mask next width))))
564 (when (< len width) (push (byte (- width len) len) bytes))
565 (make-host-map :ipnet ipn :bytes (nreverse bytes))))
567 (export 'ipnet-index-host)
568 (defun ipnet-index-host (map host)
569 "Convert a HOST index to its address."
570 (let* ((ipn (host-map-ipnet map))
571 (addr (logand (ipnet-addr ipn) (ipnet-mask ipn))))
572 (dolist (byte (host-map-bytes map))
573 (setf (ldb byte addr) host
574 host (ash host (- (byte-size byte)))))
576 (error "Host index out of range."))
577 (integer-ipaddr addr (ipnet-net ipn))))
579 (export 'ipnet-host-index)
580 (defun ipnet-host-index (map addr)
581 "Convert an ADDR into a host index."
582 (let ((addr (ipaddr-addr addr))
584 (dolist (byte (host-map-bytes map))
585 (setf host (logior host
586 (ash (ldb byte addr) offset))
587 offset (+ offset (byte-size byte))))
590 (export 'ipnet-index-bounds)
591 (defun ipnet-index-bounds (map start end)
592 "Return host-index bounds corresponding to the given bit-position bounds."
593 (flet ((hack (frob-map good-byte tweak-addr)
594 (dolist (byte (funcall frob-map (host-map-bytes map)))
595 (let* ((low (byte-position byte))
596 (high (+ low (byte-size byte)))
597 (good (funcall good-byte low high)))
600 (ipnet-host-index map
601 (ipaddr (funcall tweak-addr
604 (host-map-ipnet map))))))))
605 (error "No variable bits in range.")))
606 (values (hack #'identity
608 (and (< start high) (max start low)))
612 (and (>= end low) (min end high)))
616 (defun ipnet-host (ipn host)
617 "Return the address of the given HOST in network IPN.
619 The HOST may be a an integer index into the network (this works even with
620 a non-contiguous netmask) or a string or symbolic suffix (as for
624 (ipnet-index-host (ipnet-host-map ipn) host))
626 (multiple-value-bind (addr mask)
627 (parse-subipnet ipn host :slashp nil)
628 (unless (= mask (mask (ipaddr-width addr)))
629 (error "Host address incomplete"))
632 (export 'ipaddr-networkp)
633 (defun ipaddr-networkp (ip ipn)
634 "Returns true if numeric address IP is within network IPN."
635 (with-ipnet (nil addr mask) ipn
636 (= addr (logand ip mask))))
638 (export 'ipnet-subnetp)
639 (defun ipnet-subnetp (ipn subn)
640 "Returns true if SUBN is a (non-strict) subnet of IPN."
641 (with-ipnet (net addr mask) ipn
642 (with-ipnet (subnet subaddr submask) subn
643 (and (ipaddr-comparable-p net subnet)
644 (= addr (logand subaddr mask))
645 (= submask (logior mask submask))))))
647 (export 'ipnet-overlapp)
648 (defun ipnet-overlapp (ipn-a ipn-b)
649 "Returns true if IPN-A and IPN-B have any addresses in common."
650 (with-ipnet (net-a addr-a mask-a) ipn-a
651 (with-ipnet (net-b addr-b mask-b) ipn-b
653 ;; In the case of an overlap, we explicitly construct a common
654 ;; address. If this fails, we know that the networks don't overlap
656 (flet ((narrow (addr-a mask-a addr-b mask-b)
657 ;; Narrow network A towards B, by setting bits in A's base
658 ;; address towards which A is indifferent, but B is not;
659 ;; return the resulting base address. This address is still
660 ;; within network A, since we only set bits to which A is
662 (logior addr-a (logand addr-b (logandc2 mask-a mask-b)))))
664 (and (ipaddr-comparable-p net-a net-b)
665 (= (narrow addr-a mask-a addr-b mask-b)
666 (narrow addr-b mask-b addr-a mask-a)))))))
668 (export 'ipnet-changeable-bits)
669 (defun ipnet-changeable-bits (width mask)
670 "Work out the number of changeable bits in a network, given its MASK.
672 This is a conservative estimate in the case of noncontiguous masks. The
673 WIDTH is the total width of an address."
675 ;; We bisect the address. If the low-order bits are changeable then we
676 ;; recurse on them; otherwise we look at the high-order bits. A mask M of
677 ;; width W is changeable if it's not all-ones, i.e., if M /= 2^W. If the
678 ;; top half is changeable then we don't need to look at the bottom half.
679 (labels ((recurse (width mask offset)
681 (if (zerop mask) (1+ offset) offset)
682 (let* ((lowwidth (floor width 2))
683 (highwidth (- width lowwidth))
684 (highmask (ash mask (- lowwidth))))
685 (if (logbitp highwidth (1+ highmask))
687 (logand mask (mask lowwidth))
689 (recurse highwidth highmask (+ offset lowwidth)))))))
690 (recurse width mask 0)))
692 ;;;--------------------------------------------------------------------------
695 (export '(domain-name make-domain-name domain-name-p
696 domain-name-labels domain-name-absolutep))
697 (defstruct domain-name
698 "A domain name, which is a list of labels.
700 The most significant (top-level) label is first, so they're in
701 right-to-left order.."
702 (labels nil :type list)
703 (absolutep nil :type boolean))
705 (export 'quotify-label)
706 (defun quotify-label (string)
707 "Quote an individual label STRING, using the RFC1035 rules.
709 A string which contains only printable characters other than `.', `@',
710 `\"', `\\', `;', `(' and `)' is returned as is. Other strings are
711 surrounded with quotes, and special characters (now only `\\', `\"' and
712 unprintable things) are escaped -- printable characters are preceded by
713 backslashes, and non-printable characters are represented as \\DDD decimal
716 (if (every (lambda (ch)
717 (and (<= 33 (char-code ch) 126)
718 (not (member ch '(#\. #\@ #\" #\\ #\; #\( #\))))))
721 (with-output-to-string (out)
723 (dotimes (i (length string))
724 (let ((ch (char string i)))
725 (cond ((or (eql ch #\") (eql ch #\\))
728 ((<= 32 (char-code ch) 126)
731 (format out "\\~3,'0D" (char-code ch))))))
732 (write-char #\" out))))
734 (defun unquotify-label (string &key (start 0) (end nil))
735 "Parse and unquote a label from the STRING.
737 Returns the parsed label, and the position of the next label."
739 (let* ((end (or end (length string)))
741 (label (with-output-to-string (out)
743 ((numeric-escape-char ()
744 ;; We've just seen a `\', and the next character is
745 ;; a digit. Read the three-digit sequence, and
746 ;; return the appropriate character, or nil if the
747 ;; sequence was invalid.
754 (let ((d (digit-char-p
756 (and a d (+ (* 10 a) d)))))
758 (unless (<= 0 code 255)
759 (error "Escape code out of range."))
761 (and code (code-char code))))
764 ;; We've just seen a `\'. Read the next character
765 ;; and write it to the output stream.
767 (let ((ch (cond ((>= i end) nil)
770 (prog1 (char string i)
772 (t (numeric-escape-char)))))
774 (error "Invalid escape in label."))
775 (write-char ch out)))
778 ;; Read characters until we reach an unescaped copy
779 ;; of DELIM, writing the unescaped versions to the
780 ;; output stream. Return nil if we hit the end, or
781 ;; the delimiter character.
784 (when (>= i end) (return nil))
785 (let ((ch (char string i)))
787 (cond ((char= ch #\\)
792 (write-char ch out)))))))
794 ;; If the label starts with a `"' then continue until we
795 ;; get to the next `"', which must either end the string,
796 ;; or be followed by a `.'. If the label isn't quoted,
797 ;; then munch until the `.'.
799 ((and (< i end) (char= (char string i) #\"))
801 (let ((delim (munch #\")))
804 (char= (prog1 (char string i)
807 (error "Invalid quoting in label."))))
812 (when (string= label "")
813 (error "Empty labels aren't allowed."))
816 (export 'parse-domain-name)
817 (defun parse-domain-name (string &key (start 0) (end nil) absolutep)
818 "Parse (a substring of) STRING as a possibly-relative domain name.
820 If STRING doesn't end in an unquoted `.', then it's relative (to some
821 unspecified parent domain). The input may be the special symbol `@' to
822 refer to the parent itself, `.' to mean the root, or a sequence of labels
823 separated by `.'. The final name is returned as a `domain-name' object."
825 (let ((end (or end (length string)))
828 ;; Parse a sequence of labels.
832 (unless (< i end) (return))
833 (multiple-value-bind (label j)
834 (unquotify-label string :start i :end end)
838 (error "Empty domain names have special notations."))
839 (make-domain-name :labels labels :absolutep absolutep))))
841 (cond ((= (1+ i) end)
842 ;; A single-character name. Check for the magic things;
843 ;; otherwise I guess it must just be short.
845 (case (char string i)
846 (#\@ (make-domain-name :labels nil :absolutep nil))
847 (#\. (make-domain-name :labels nil :absolutep t))
851 ;; Something more complicated. If the name ends with `.', but
852 ;; not `\\.', then it must be absolute.
854 (char= (char string (- end 1)) #\.)
855 (char/= (char string (- end 2)) #\\))
860 (defmethod print-object ((name domain-name) stream)
861 "Print a domain NAME to a STREAM, using RFC1035 quoting rules."
862 (let ((labels (mapcar #'quotify-label
863 (reverse (domain-name-labels name)))))
864 (cond (*print-escape*
865 (print-unreadable-object (name stream :type t)
866 (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~@[.~]~]"
867 labels (domain-name-absolutep name))))
869 (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~]"
870 labels (domain-name-absolutep name))))))
872 (export 'domain-name-concat)
873 (defun domain-name-concat (left right)
874 "Concatenate the LEFT and RIGHT names."
875 (if (domain-name-absolutep left)
877 (make-domain-name :labels (append (domain-name-labels right)
878 (domain-name-labels left))
879 :absolutep (domain-name-absolutep right))))
881 (export 'domain-name<)
882 (defun domain-name< (name-a name-b)
883 "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
885 Split the names into labels, and then lexicographically compare the
886 sequences of labels, right to left, using `natural-string<'.
888 Returns two values: whether NAME-A strictly precedes NAME-B, and whether
889 NAME-A strictly follows NAME-B.
891 This doesn't give useful answers on relative domains unless you know what
894 (let ((labels-a (domain-name-labels name-a))
895 (labels-b (domain-name-labels name-b)))
896 (loop (cond ((null labels-a)
897 (return (values (not (null labels-b)) (null labels-b))))
899 (return (values nil t)))
901 (multiple-value-bind (precp follp)
902 (natural-string< (pop labels-a) (pop labels-b))
903 (cond (precp (return (values t nil)))
904 (follp (return (values nil t))))))))))
906 (export 'root-domain)
907 (defparameter root-domain (make-domain-name :labels nil :absolutep t)
908 "The root domain, as a convenient object.")
910 ;;;--------------------------------------------------------------------------
913 (export 'reverse-domain-component-width)
914 (defgeneric reverse-domain-component-width (ipaddr)
915 (:documentation "Return the component width for splitting IPADDR."))
917 (export 'reverse-domain-component-radix)
918 (defgeneric reverse-domain-radix (ipaddr)
919 (:documentation "Return the radix for representing IPADDR components."))
921 (export 'reverse-domain-component-suffix)
922 (defgeneric reverse-domain-suffix (ipaddr)
923 (:documentation "Return the reverse-lookup domain suffix for IPADDR."))
925 (export 'reverse-domain-fragment)
926 (defgeneric reverse-domain-fragment (ipaddr start end &key partialp)
928 "Return a portion of an IPADDR's reverse-resolution domain name.
930 Specifically, return the portion of the name which covers the bits of an
931 IPADDR between bits START (inclusive) and END (exclusive). Address
932 components which are only partially within the given bounds are included
933 unless PARTIALP is nil.")
935 (:method ((ipaddr ipaddr) start end &key (partialp t))
937 (let ((addr (ipaddr-addr ipaddr))
938 (comp-width (reverse-domain-component-width ipaddr))
939 (radix (reverse-domain-radix ipaddr)))
941 (do ((i (funcall (if partialp #'round-down #'round-up)
944 (limit (funcall (if partialp #'round-up #'round-down)
946 (comps nil (cons (format nil "~(~vR~)" radix
947 (ldb (byte comp-width i) addr))
949 ((>= i limit) (make-domain-name :labels comps))))))
951 (export 'reverse-domain)
952 (defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
953 (:documentation "Return a reverse-resolution domain name for IPADDR-OR-IPN.
955 If PREFIX-LEN is nil then it defaults to the length of the network's fixed
958 (:method ((ipn ipnet) &optional prefix-len)
959 (let* ((addr (ipnet-net ipn))
960 (mask (ipnet-mask ipn))
961 (width (ipaddr-width addr)))
962 (domain-name-concat (reverse-domain-fragment
966 (ipnet-changeable-bits width mask))
969 (reverse-domain-suffix addr))))
971 (:method ((addr ipaddr) &optional prefix-len)
972 (let* ((width (ipaddr-width addr)))
973 (reverse-domain (make-ipnet addr width)
974 (or prefix-len width)))))
976 ;;;--------------------------------------------------------------------------
977 ;;; Network names and specifiers.
983 ((name :type string :initarg :name :reader net-name)
984 (ipnets :type list :initarg :ipnets :initform nil :accessor net-ipnets)
985 (next :type unsigned-byte :initform 1 :accessor net-next)))
987 (defmethod print-object ((net net) stream)
988 (print-unreadable-object (net stream :type t)
989 (format stream "~A~@[ = ~{~A~^, ~}~]"
991 (mapcar #'ipnet-string (net-ipnets net)))))
993 (defvar *networks* (make-hash-table :test #'equal)
994 "The table of known networks.")
997 (defun net-find (name)
998 "Find a network by NAME."
999 (gethash (string-downcase (stringify name)) *networks*))
1000 (defun (setf net-find) (net name)
1001 "Make NAME map to NET."
1002 (setf (gethash (string-downcase (stringify name)) *networks*) net))
1004 (export 'net-must-find)
1005 (defun net-must-find (name)
1007 (error "Unknown network ~A." name)))
1009 (defun net-ipnet (net family)
1010 (find family (net-ipnets net) :key #'ipnet-family))
1011 (defun (setf net-ipnet) (ipnet net family)
1012 (assert (eq (ipnet-family ipnet) family))
1013 (let ((ipns (net-ipnets net)))
1014 (if (find family ipns :key #'ipnet-family)
1015 (nsubstitute ipnet family ipns :key #'ipnet-family)
1016 (setf (net-ipnets net) (cons ipnet ipns)))))
1018 (defun process-net-form (name addr subnets)
1021 A net-form looks like (NAME ADDR [SUBNET ...]) where:
1023 * NAME is the name for the network.
1025 * ADDR is the subnet address (acceptable to `string-subipnet'); at
1026 top-level, this is a plain network address (acceptable to
1027 `string-ipnet'). Alternatively (for compatibility) the ADDR for a
1028 non-top-level network can be an integer number of addresses to
1029 allocate to this subnet; the subnet's base address is implicitly just
1030 past the previous subnet's limit address (or, for the first subnet,
1031 it's the parent network's base address). This won't work at all well
1032 if your subnets have crazy netmasks.
1034 * The SUBNETs are further net-forms, of the same form, whose addresses
1035 are interpreted relative to the parent network's address.
1037 The return value is a list of items of the form (NAME . IPNET)."
1039 (labels ((process-subnets (subnets parent)
1040 (let ((finger (ipnet-addr parent))
1042 (dolist (subnet subnets list)
1043 (destructuring-bind (name addr &rest subs) subnet
1044 (let ((net (etypecase addr
1046 (when (or (> (count-low-zero-bits addr)
1047 (count-low-zero-bits finger))
1048 (not (zerop (logand addr
1050 (error "Bad subnet size for ~A." name))
1052 (ipaddr finger (ipnet-net parent))
1053 (ipaddr (- (ash 1 (ipnet-width parent))
1055 (ipnet-net parent))))
1057 (string-subipnet parent addr)))))
1059 (unless (ipnet-subnetp parent net)
1060 (error "Network `~A' (~A) falls outside parent ~A."
1061 name (ipnet-string net) (ipnet-string parent)))
1063 (dolist (entry list nil)
1064 (let ((ipn (cdr entry)))
1065 (when (ipnet-overlapp ipn net)
1066 (error "Network `~A' (~A) overlaps `~A' (~A)."
1067 name (ipnet-string net)
1068 (car entry) (ipnet-string ipn)))))
1073 (logxor (ipnet-mask net)
1074 (1- (ash 1 (ipnet-width net)))))))
1077 (push (cons name net) list))
1080 (setf list (nconc (process-subnets subs net)
1083 (let* ((top (string-ipnet addr))
1084 (list (nreverse (process-subnets subnets top))))
1085 (when name (push (cons name top) list))
1088 (export 'net-create)
1089 (defun net-create (name net)
1090 "Construct a new network called NAME and add it to the map.
1092 The NET describes the new network, in a form acceptable to the `ipnet'
1093 function. A named network may have multiple addresses with different
1094 families: each `net-create' call adds a new family, or modifies the net's
1095 address in an existing family."
1096 (let ((ipn (ipnet net))
1097 (net (net-find name)))
1099 (progn (setf (net-ipnet net (ipnet-family ipn)) ipn) net)
1100 (setf (net-find name)
1102 :name (string-downcase (stringify name))
1103 :ipnets (list ipn))))))
1106 (defmacro defnet (name net &rest subnets)
1107 "Main network definition macro.
1109 None of the arguments is evaluated."
1111 ,@(mapcar (lambda (item)
1112 (let ((name (car item)) (ipn (cdr item)))
1113 `(net-create ',name ',ipn)))
1114 (process-net-form name net subnets))
1117 (defun filter-by-family (func form family)
1118 "Handle a family-switch form.
1120 Here, FUNC is a function of two arguments ITEM and FAMILY. FORM is either
1121 a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly
1122 acceptable to FUNC. Return a list of the resulting outputs of FUNC."
1124 (if (and (listp form)
1125 (every (lambda (clause)
1127 (family-addrclass (car clause))))
1129 (mapcan (lambda (clause)
1130 (let ((fam (car clause)))
1131 (and (or (eq family t)
1133 (list (funcall func (cdr clause) fam)))))
1135 (list (funcall func form family))))
1137 (export 'net-parse-to-ipnets)
1138 (defun net-parse-to-ipnets (form &optional (family t))
1139 "Parse FORM into a list of ipnet objects.
1141 The FORM can be any of the following.
1143 * NAME -- a named network, established using `net-create' or `defnet'
1145 * IPNET -- a network, in a form acceptable to `ipnet'
1147 * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY"
1149 (flet ((hack (form family)
1150 (let* ((form (if (and (consp form)
1154 (net (net-find form))
1155 (ipns (if net (net-ipnets net)
1156 (list (ipnet form)))))
1157 (if (eq family t) ipns
1161 (let* ((ipns (apply #'append (filter-by-family #'hack form family)))
1162 (merged (reduce (lambda (ipns ipn)
1163 (if (find (ipnet-family ipn) ipns
1164 :key #'ipnet-family)
1168 :initial-value nil)))
1170 (error "No addresses match ~S~:[ in family ~S~;~*~]."
1171 form (eq family t) family)))))
1174 (defun net-host (net-form host &optional (family t))
1175 "Return the given HOST on the NET, as an anonymous `host' object.
1177 HOST may be an index (in range, of course), a suffix (as a symbol or
1178 string, as for `string-subnet'), or one of the keywords:
1180 :next next host, as by net-next-host
1181 :net network base address
1182 :broadcast network broadcast address
1184 If FAMILY is not `t', then only return an address with that family;
1185 otherwise return all available addresses."
1186 (flet ((hosts (ipns host)
1187 (mapcar (lambda (ipn) (ipnet-host ipn host))
1189 (remove host ipns :key #'ipnet-hosts :test #'>=)
1191 (let* ((net (and (typep net-form '(or string symbol))
1192 (net-find net-form)))
1193 (ipns (net-parse-to-ipnets net-form family))
1197 (prog1 (hosts ipns (net-next net))
1198 (incf (net-next net)))
1199 (error "Can't use `:next' without a named net.")))
1200 (:net (mapcar #'ipnet-net ipns))
1201 (:broadcast (remove nil (mapcar #'ipnet-broadcast ipns)))
1202 (t (hosts ipns host)))))
1204 (error "No networks have that address."))
1205 (make-instance 'host :addrs addrs))))
1207 ;;;--------------------------------------------------------------------------
1208 ;;; Host names and specifiers.
1212 (export 'host-addrs)
1214 ((name :type (or string null) :initform nil
1215 :initarg :name :reader host-name)
1216 (addrs :type list :initarg :addrs :initform nil :accessor host-addrs)))
1218 (defmethod print-object ((host host) stream)
1219 (print-unreadable-object (host stream :type t)
1220 (format stream "~:[<anonymous>~;~@*~A~]~@[ = ~{~A~^, ~}~]"
1222 (mapcar #'ipaddr-string (host-addrs host)))))
1224 (defvar *hosts* (make-hash-table :test #'equal)
1225 "The table of known hostnames.")
1228 (defun host-find (name)
1229 "Find a host by NAME."
1230 (gethash (string-downcase (stringify name)) *hosts*))
1231 (defun (setf host-find) (addr name)
1232 "Make NAME map to ADDR (must be an ipaddr in integer form)."
1233 (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
1235 (defun merge-addresses (addrs-a addrs-b)
1236 (append (remove-if (lambda (addr)
1237 (member (ipaddr-family addr) addrs-b
1238 :key #'ipaddr-family))
1242 (export 'host-parse)
1243 (defun host-parse (addr &optional (family t))
1244 "Convert the ADDR into a (possibly anonymous) `host' object.
1246 The ADDR can be one of a number of different things.
1248 HOST a host name defined using `defhost'
1250 (NET INDEX) a particular host in a network
1252 IPADDR an address form acceptable to `ipnet'
1254 ((FAMILY . ADDR) ...) the above, restricted to a particular address
1255 FAMILY (i.e., one of the keywords `:ipv4',
1258 (labels ((filter-addresses (addrs family)
1259 (make-instance 'host
1260 :addrs (if (eq family t) addrs
1261 (remove family addrs
1262 :key #'ipaddr-family
1264 (host-addresses (host family)
1265 (if (eq family t) host
1266 (filter-addresses (host-addrs host) family)))
1268 (let* ((form (listify addr))
1270 (host (and (null (cdr form))
1271 (host-find indic))))
1273 (host-addresses host family))
1274 ((and (consp (cdr form))
1276 (net-host (car form) (cadr form) family))
1278 (filter-addresses (list (ipaddr indic)) family))))))
1279 (let* ((list (filter-by-family #'hack addr family))
1280 (host (if (and list (cdr list))
1281 (make-instance 'host
1282 :addrs (reduce #'merge-addresses
1283 (mapcar #'host-addrs
1285 :initial-value nil))
1287 (unless (host-addrs host)
1288 (error "No addresses match ~S~:[ in family ~S~;~*~]."
1289 addr (eq family t) family))
1292 (export 'host-create)
1293 (defun host-create (name addr)
1294 "Make host NAME map to ADDR (anything acceptable to `host-parse')."
1295 (let ((existing (host-find name))
1296 (new (host-parse addr)))
1298 (setf (host-find name)
1299 (make-instance 'host
1300 :name (string-downcase (stringify name))
1301 :addrs (host-addrs new)))
1303 (setf (host-addrs existing)
1304 (merge-addresses (host-addrs existing) (host-addrs new)))
1308 (defmacro defhost (name addr)
1309 "Main host definition macro. Neither NAME nor ADDR is evaluated."
1311 (host-create ',name ',addr)
1314 ;;;----- That's all, folks --------------------------------------------------