chiark / gitweb /
zone.lisp: Stringify the zone name at construction time.
[zone] / net.lisp
CommitLineData
9c44003b
MW
1;;; -*-lisp-*-
2;;;
9c44003b
MW
3;;; Network (numbering) tools
4;;;
5;;; (c) 2006 Straylight/Edgeware
6;;;
7
8;;;----- Licensing notice ---------------------------------------------------
9;;;
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.
7fff3797 14;;;
9c44003b
MW
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.
7fff3797 19;;;
9c44003b
MW
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.
23
9c44003b
MW
24(in-package #:net)
25
26;;;--------------------------------------------------------------------------
32ebbe9b 27;;; Various random utilities.
9c44003b 28
32ebbe9b 29(declaim (inline mask))
9c44003b
MW
30(defun mask (n)
31 "Return 2^N - 1: i.e., a mask of N set bits."
32 (1- (ash 1 n)))
33
32ebbe9b
MW
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.
9c44003b 37
32ebbe9b
MW
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)
41 bound on the new run.
9c44003b 42
32ebbe9b
MW
43 If there is no transition within the bounds, then return HIGH."
44
45 ;; Arrange that the initial run is ones.
46 (unless (logbitp low mask) (setf mask (lognot mask)))
47
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
52 ;; set bit.
53 (let ((pos (1- (integer-length (logxor mask (+ mask (ash 1 low)))))))
54 (if (<= low pos high) pos high)))
9c44003b
MW
55
56(defun count-low-zero-bits (n)
57 "Return the number of low-order zero bits in the integer N."
32ebbe9b
MW
58 (cond ((zerop n) nil)
59 ((oddp n) 0)
60 (t (find-first-bit-transition n))))
61
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)))
66
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)))
71
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))
77 (class-name class))
78 (:method ((name symbol))
79 name))
80
81(defclass savable-object ()
82 ())
83(defmethod make-load-form ((object savable-object) &optional environment)
84 (make-load-form-saving-slots object :environment environment))
85
86;;;--------------------------------------------------------------------------
87;;; Parsing primitives for addresses.
88
89(defun parse-partial-address
90 (str
91 &key (start 0) (end nil) (delim #\.)
92 (width 8) (radix 10) (min 1) (max 32) (shiftp t)
93 (what "address"))
94 "Parse a partial address from STR, which should be a sequence of integers
95 in the given RADIX, separated by the DELIM character, with each integer
96 N_i in the interval 0 <= N_i < 2^WIDTH. If the sequence is N_1, N_2, ...,
97 N_k, then the basic partial address BPA is the sum
98
99 SUM_{1<=i<=k} 2^{WIDTH (k-i)} N_i
100
101 If SHIFTP is true (the default) then let OFFSET be the smallest multiple
102 of WIDTH not less than MAX - k WIDTH; otherwise, let OFFSET be zero. The
103 partial address PA is BPA 2^SHIFT.
104
105 The return values are: PA, OFFSET, k WIDTH + OFFSET; i.e., the partial
106 address, and (inclusive) lower and (exclusive) upper bounds on the bits
107 specified by STR."
108
109 (setf-default end (length str))
110 (let ((addr 0) (nbits 0) (limit (ash 1 width)))
111 (when (< start end)
112 (loop
113 (when (>= nbits max)
114 (error "Too many elements in ~A" what))
115 (let* ((pos (position delim str :start start :end end))
116 (w (parse-integer str :radix radix
117 :start start :end (or pos end))))
118 (unless (and (<= 0 w) (< w limit))
119 (error "Element out of range in ~A" what))
120 (setf addr (logior (ash addr width) w))
121 (incf nbits width)
122 (unless pos (return))
123 (setf start (1+ pos)))))
124 (when (< nbits min)
125 (error "Not enough elements in ~A" what))
126 (if shiftp
127 (let* ((top (round-up max width))
128 (shift (- top nbits)))
129 (values (ash addr shift) shift top))
130 (values addr 0 nbits))))
9c44003b
MW
131
132;;;--------------------------------------------------------------------------
32ebbe9b
MW
133;;; Simple messing about with IP addresses.
134
135(export 'ipaddr)
136(export 'ipaddr-addr)
137(defclass ipaddr (savable-object)
138 ()
139 (:documentation
140 "Base class for IP addresses."))
141
142(export 'ipaddr-family)
6a26c716
MW
143(defgeneric ipaddr-family (addr)
144 (:documentation "Return the address family of ADDR, as a keyword."))
32ebbe9b
MW
145
146(export 'family-addrclass)
147(defgeneric family-addrclass (family)
6a26c716 148 (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.")
32ebbe9b
MW
149 (:method ((af symbol)) nil))
150
151(export 'ipaddr-width)
152(defgeneric ipaddr-width (class)
6a26c716
MW
153 (:documentation "Return the width, in bits, of addresses from CLASS.
154
155 Alternatively, the CLASS may be given as an example object.")
32ebbe9b
MW
156 (:method ((object t)) (ipaddr-width (extract-class-name object))))
157
158(export 'ipaddr-comparable-p)
159(defgeneric ipaddr-comparable-p (addr-a addr-b)
6a26c716 160 (:documentation "Is it meaningful to compare ADDR-A and ADDR-B?")
32ebbe9b
MW
161 (:method ((addr-a ipaddr) (addr-b ipaddr))
162 (eq (class-of addr-a) (class-of addr-b))))
163
164(defun guess-address-class (str &key (start 0) (end nil))
6a26c716
MW
165 "Return a class name for the address in (the given substring of) STR.
166
167 This ought to be an extension point for additional address families, but
168 it isn't at the moment."
a2267e14
MW
169 (cond ((position #\: str :start start :end end) 'ip6addr)
170 (t 'ip4addr)))
32ebbe9b
MW
171
172(defgeneric parse-partial-ipaddr (class str &key start end min max)
6a26c716
MW
173 (:documentation
174 "Parse (a substring of) STR into a partial address of the given CLASS.
175
176 Returns three values: the parsed address fragment, as an integer; and the
177 low and high bit positions covered by the response.
178
179 The CLASS may instead be an example object of the required class. The MIN
180 and MAX arguments bound the number of bits acceptable in the response; the
181 result is shifted so that the most significant component of the returned
182 address is in the same component as bit position MAX.")
32ebbe9b
MW
183 (:method ((object t) str &rest keywords)
184 (apply #'parse-partial-ipaddr (extract-class-name object) str keywords)))
9c44003b 185
e1528fd6 186(export 'string-ipaddr)
9c44003b 187(defun string-ipaddr (str &key (start 0) (end nil))
32ebbe9b 188 "Parse STR into an address; guess what kind is intended by the user.
f4e0c48f
MW
189
190 STR may be anything at all: it's converted as if by `stringify'.
191 The START and END arguments may be used to parse out a substring."
9c44003b 192 (setf str (stringify str))
32ebbe9b
MW
193 (let* ((class (guess-address-class str :start start :end end))
194 (width (ipaddr-width class)))
195 (make-instance class :addr
196 (parse-partial-ipaddr class str
197 :start start :end end
198 :min width :max width))))
199
200(export 'integer-ipaddr)
201(defgeneric integer-ipaddr (int like)
202 (:documentation "Convert INT into an address of type indicated by LIKE.
203
204 Specifically, if LIKE is an address object, then use its type; if it's
205 a class, then use it directly; if it's a symbol, then use the class it
206 names.")
207 (:method (int (like t)) (integer-ipaddr int (class-of like)))
208 (:method (int (like symbol))
209 (make-instance (or (family-addrclass like) like) :addr int))
210 (:method (int (like standard-class)) (make-instance like :addr int)))
9c44003b 211
e1528fd6 212(export 'ipaddr-string)
32ebbe9b 213(defgeneric ipaddr-string (ip)
6a26c716 214 (:documentation "Transform the address IP into a numeric textual form."))
32ebbe9b
MW
215
216(defmethod print-object ((addr ipaddr) stream)
217 (print-unreadable-object (addr stream :type t)
218 (write-string (ipaddr-string addr) stream)))
9c44003b 219
e1528fd6 220(export 'ipaddrp)
9c44003b
MW
221(defun ipaddrp (ip)
222 "Answer true if IP is a valid IP address in integer form."
223 (typep ip 'ipaddr))
224
32ebbe9b
MW
225(defun ipaddr (ip &optional like)
226 "Convert IP to an IP address, of type similar to LIKE.
f4e0c48f 227
32ebbe9b
MW
228 If it's an IP address, just return it unchanged; If it's an integer,
229 capture it; otherwise convert by `string-ipaddr'."
9c44003b
MW
230 (typecase ip
231 (ipaddr ip)
32ebbe9b 232 (integer (integer-ipaddr ip like))
9c44003b
MW
233 (t (string-ipaddr ip))))
234
32ebbe9b
MW
235(export 'ipaddr-rrtype)
236(defgeneric ipaddr-rrtype (addr)
237 (:documentation "Return the proper resource record type for ADDR."))
238
9c44003b
MW
239;;;--------------------------------------------------------------------------
240;;; Netmasks.
241
e1528fd6 242(export 'integer-netmask)
32ebbe9b
MW
243(defun integer-netmask (n i)
244 "Given an integer I, return an N-bit netmask with its I top bits set."
245 (- (ash 1 n) (ash 1 (- n i))))
9c44003b 246
e1528fd6 247(export 'ipmask-cidl-slash)
32ebbe9b 248(defun ipmask-cidl-slash (width mask)
f4e0c48f
MW
249 "Given a netmask MASK, try to compute a prefix length.
250
32ebbe9b
MW
251 Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if
252 this is impossible."
253 (let* ((low (logxor mask (mask width)))
254 (bits (integer-length low)))
255 (and (= low (mask bits)) (- width bits))))
256
257(export 'ipmask)
258(defgeneric ipmask (addr mask)
259 (:documentation "Convert MASK into a suitable netmask for ADDR.")
260 (:method ((addr ipaddr) (mask null))
261 (mask (ipaddr-width addr)))
262 (:method ((addr ipaddr) (mask integer))
263 (let ((w (ipaddr-width addr)))
264 (if (<= 0 mask w)
265 (integer-netmask w mask)
b496b60f 266 (error "Prefix length out of range.")))))
32ebbe9b
MW
267
268(export 'mask-ipaddr)
269(defun mask-ipaddr (addr mask)
270 "Apply the MASK to the ADDR, returning the base address."
271 (integer-ipaddr (logand mask (ipaddr-addr addr)) addr))
9c44003b
MW
272
273;;;--------------------------------------------------------------------------
274;;; Networks: pairing an address and netmask.
275
e1528fd6 276(export 'ipnet)
32ebbe9b
MW
277(export 'ipnet-net)
278(export 'ipnet-mask)
279(defclass ipnet (savable-object)
280 ()
281 (:documentation "Base class for IP networks."))
9c44003b 282
32ebbe9b
MW
283(export 'ipnet-family)
284(defgeneric ipnet-family (ipn)
6a26c716 285 (:documentation "Return the address family of IPN, as a keyword.")
32ebbe9b 286 (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn))))
9c44003b 287
32ebbe9b
MW
288(export 'ipnet-addr)
289(defun ipnet-addr (ipn)
290 "Return the base network address of IPN as a raw integer."
291 (ipaddr-addr (ipnet-net ipn)))
9c44003b 292
32ebbe9b
MW
293(export 'ipaddr-ipnet)
294(defgeneric ipaddr-ipnet (addr mask)
295 (:documentation "Construct an `ipnet' object given a base ADDR and MASK."))
296
297(export 'make-ipnet)
298(defun make-ipnet (net mask)
6a26c716
MW
299 "Construct an IP-network object given the NET and MASK.
300
301 These are transformed as though by `ipaddr' and `ipmask'."
32ebbe9b
MW
302 (let* ((net (ipaddr net))
303 (mask (ipmask net mask)))
304 (ipaddr-ipnet (mask-ipaddr net mask) mask)))
9c44003b 305
e1528fd6 306(export 'with-ipnet)
32ebbe9b 307(defmacro with-ipnet ((net addr mask) ipn &body body)
f4e0c48f
MW
308 "Evaluate the BODY with components of IPN in scope.
309
32ebbe9b
MW
310 The NET is bound to the underlying network base address, as an `ipaddr';
311 ADDR is bound to the integer value of this address; and MASK is bound to
312 the netmask, again as an integer. Any (or all) of these may be nil if not
313 wanted."
9c44003b
MW
314 (with-gensyms tmp
315 `(let ((,tmp ,ipn))
316 (let (,@(and net `((,net (ipnet-net ,tmp))))
32ebbe9b 317 ,@(and addr `((,addr (ipnet-addr ,tmp))))
9c44003b
MW
318 ,@(and mask `((,mask (ipnet-mask ,tmp)))))
319 ,@body))))
320
32ebbe9b
MW
321(export 'ipnet-width)
322(defun ipnet-width (ipn)
323 "Return the underlying bit width of the addressing system."
324 (ipaddr-width (ipnet-net ipn)))
9c44003b 325
e1528fd6 326(export 'ipnet-string)
9c44003b
MW
327(defun ipnet-string (ipn)
328 "Convert IPN to a string."
32ebbe9b 329 (with-ipnet (net nil mask) ipn
9c44003b
MW
330 (format nil "~A/~A"
331 (ipaddr-string net)
32ebbe9b
MW
332 (or (ipmask-cidl-slash (ipnet-width ipn) mask)
333 (ipaddr-string (make-instance (class-of net) :addr mask))))))
334
335(defmethod print-object ((ipn ipnet) stream)
336 (print-unreadable-object (ipn stream :type t)
337 (write-string (ipnet-string ipn) stream)))
338
6343e7bf 339(defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
6a26c716
MW
340 "Parse a subnet description from (a substring of) STR.
341
342 Suppose we have a parent network, with a prefix length of MAX. The WIDTH
343 gives the overall length of addresses of the appropriate class, i.e.,
344 (ipaddr-width WIDTH), but in fact callers have already computed this for
345 their own reasons.
346
347 Parse (the designated substring of) STR to construct the base address of a
348 subnet. The string should have the form BASE/MASK, where the MASK is
349 either a literal bitmask (in the usual syntax for addresses) or an integer
350 prefix length. An explicit prefix length is expected to cover the entire
351 address including the parent prefix: an error is signalled if the prefix
352 isn't long enough to cover any of the subnet. A mask is parsed relative
353 to the end of the parent address, just as the subnet base address is.
354
355 Returns the relative base address and mask as two integer values."
356
32ebbe9b 357 (setf-default end (length str))
6343e7bf 358 (let ((sl (and slashp (position #\/ str :start start :end end))))
32ebbe9b
MW
359 (multiple-value-bind (addr lo hi)
360 (parse-partial-ipaddr class str :max max
361 :start start :end (or sl end))
362 (let* ((present (integer-netmask hi (- hi lo)))
363 (mask (cond ((not sl)
364 present)
365 ((every #'digit-char-p (subseq str (1+ sl) end))
366 (let ((length (parse-integer str
367 :start (1+ sl)
368 :end end)))
369 (unless (>= length (- width max))
370 (error "Mask doesn't reach subnet boundary"))
371 (integer-netmask max (- length (- width max)))))
372 (t
373 (parse-partial-ipaddr class str :max max
374 :start (1+ sl) :end end)))))
375 (unless (zerop (logandc2 mask present))
376 (error "Mask selects bits not present in base address"))
377 (values addr mask)))))
378
6343e7bf
MW
379(defun check-subipnet (base-ipn sub-addr sub-mask)
380 "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN.
32ebbe9b 381
6343e7bf
MW
382 The BASE-IPN is an `ipnet'; SUB-ADDR and SUB-MASK are plain integers. If
383 the subnet is invalid (i.e., the subnet disagrees with its putative parent
384 over some of the fixed address bits) then an error is signalled; otherwise
385 return the combined base address (as an `ipaddr') and mask (as an
386 integer)."
32ebbe9b 387 (with-ipnet (base-net base-addr base-mask) base-ipn
6343e7bf 388 (let* ((common (logand base-mask sub-mask))
32ebbe9b
MW
389 (base-overlap (logand base-addr common))
390 (sub-overlap (logand sub-addr common))
391 (full-mask (logior base-mask sub-mask)))
6343e7bf 392 (unless (or (zerop sub-overlap) (= sub-overlap base-overlap))
32ebbe9b 393 (error "Subnet doesn't match base network"))
6343e7bf
MW
394 (values (integer-ipaddr (logand full-mask (logior base-addr sub-addr))
395 base-net)
396 full-mask))))
32ebbe9b
MW
397
398(export 'string-ipnet)
399(defun string-ipnet (str &key (start 0) (end nil))
6a26c716
MW
400 "Parse an IP network description from the string STR.
401
402 A network description has the form ADDRESS/MASK, where the ADDRESS is a
403 base address in numeric form, and the MASK is either a netmask in the same
404 form, or an integer prefix length."
32ebbe9b
MW
405 (setf str (stringify str))
406 (setf-default end (length str))
407 (let ((addr-class (guess-address-class str :start start :end end)))
408 (multiple-value-bind (addr mask)
409 (let ((width (ipaddr-width addr-class)))
410 (parse-subnet addr-class width width str
411 :start start :end end))
412 (make-ipnet (make-instance addr-class :addr addr)
413 (make-instance addr-class :addr mask)))))
414
6343e7bf
MW
415(defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t))
416 "Parse STR as a subnet of IPN.
417
6a26c716
MW
418 This is mostly a convenience interface over `parse-subnet'; we compute
419 various of the parameters from IPN rather than requiring them to be passed
420 in explicitly.
421
422 Returns two values: the combined base address, as an `ipnaddr' and
423 combined mask, as an integer."
424
32ebbe9b
MW
425 (let* ((addr-class (extract-class-name (ipnet-net ipn)))
426 (width (ipaddr-width addr-class))
427 (max (- width
428 (or (ipmask-cidl-slash width (ipnet-mask ipn))
429 (error "Base network has complex netmask")))))
430 (multiple-value-bind (addr mask)
6343e7bf
MW
431 (parse-subnet addr-class width max (stringify str)
432 :start start :end end :slashp slashp)
433 (check-subipnet ipn addr mask))))
434
435(export 'string-subipnet)
436(defun string-subipnet (ipn str &key (start 0) (end nil))
6a26c716
MW
437 "Parse an IP subnet from a parent net IPN and a suffix string STR.
438
439 The (substring of) STR is expected to have the form ADDRESS/MASK, where
440 ADDRESS is a relative subnet base address, and MASK is either a relative
441 subnet mask or a (full) prefix length. Returns the resulting ipnet. If
442 the relative base address overlaps with the existing subnet (because the
443 base network's prefix length doesn't cover a whole number of components),
444 then the subnet base must either agree in the overlapping portion with the
445 parent base address or be zero.
446
447 For example, if IPN is the network 172.29.0.0/16, then `199/24' or
448 `199/255' both designate the subnet 172.29.199.0/24. Similarly, starting
449 from 2001:ba8:1d9:8000::/52, then `8042/ffff' and `42/64' both designate
450 the network 2001:ba8:1d9:8042::/64."
451
6343e7bf
MW
452 (multiple-value-bind (addr mask)
453 (parse-subipnet ipn str :start start :end end)
454 (ipaddr-ipnet addr mask)))
32ebbe9b
MW
455
456(defun ipnet (net)
457 "Construct an IP-network object from the given argument.
458
459 A number of forms are acceptable:
460
461 * ADDR -- a single address, equivalent to (ADDR . N).
462 * (NET . MASK|nil) -- a single-object representation.
463 * IPNET -- return an equivalent (`equal', not necessarily `eql')
464 version."
465 (typecase net
466 (ipnet net)
467 ((or string symbol) (string-ipnet net))
468 (t (apply #'make-ipnet (pairify net nil)))))
9c44003b 469
e1528fd6 470(export 'ipnet-broadcast)
32ebbe9b
MW
471(defgeneric ipnet-broadcast (ipn)
472 (:documentation "Return the broadcast address for the network IPN.
473
474 Returns nil if there isn't one."))
9c44003b 475
e1528fd6 476(export 'ipnet-hosts)
9c44003b
MW
477(defun ipnet-hosts (ipn)
478 "Return the number of available addresses in network IPN."
32ebbe9b
MW
479 (ash 1 (- (ipnet-width ipn) (logcount (ipnet-mask ipn)))))
480
481(defstruct host-map
482 "An internal object used by `ipnet-index-host' and `ipnet-host-index'.
483
484 Our objective is to be able to convert between flat host indices and a
485 possibly crazy non-flat host space. We record the underlying IPNET for
486 convenience, and a list of byte-specifications for the runs of zero bits
487 in the netmask, in ascending order."
488 ipnet
489 bytes)
490
491(export 'ipnet-host-map)
492(defun ipnet-host-map (ipn)
493 "Work out how to enumerate the variable portion of IPN.
494
495 Returns an object which can be passed to `ipnet-index-host' and
496 `ipnet-host-index'."
497 (let* ((mask (ipnet-mask ipn)) (bytes nil) (i 0)
498 (len (integer-length mask)) (width (ipnet-width ipn)))
499 (when (logbitp i mask) (setf i (find-first-bit-transition mask i)))
500 (loop
501 (unless (< i len) (return))
502 (let ((next (find-first-bit-transition mask i width)))
503 (push (byte (- next i) i) bytes)
504 (setf i (find-first-bit-transition mask next width))))
505 (when (< len width) (push (byte (- width len) len) bytes))
506 (make-host-map :ipnet ipn :bytes (nreverse bytes))))
507
508(export 'ipnet-index-host)
509(defun ipnet-index-host (map host)
510 "Convert a HOST index to its address."
511 (let* ((ipn (host-map-ipnet map))
512 (addr (logand (ipnet-addr ipn) (ipnet-mask ipn))))
513 (dolist (byte (host-map-bytes map))
514 (setf (ldb byte addr) host
515 host (ash host (- (byte-size byte)))))
516 (unless (zerop host)
517 (error "Host index out of range."))
518 (integer-ipaddr addr (ipnet-net ipn))))
519
520(export 'ipnet-host-index)
521(defun ipnet-host-index (map addr)
522 "Convert an ADDR into a host index."
523 (let ((addr (ipaddr-addr addr))
524 (host 0) (offset 0))
525 (dolist (byte (host-map-bytes map))
526 (setf host (logior host
527 (ash (ldb byte addr) offset))
528 offset (+ offset (byte-size byte))))
529 host))
530
531(export 'ipnet-index-bounds)
532(defun ipnet-index-bounds (map start end)
533 "Return host-index bounds corresponding to the given bit-position bounds."
534 (flet ((hack (frob-map good-byte tweak-addr)
535 (dolist (byte (funcall frob-map (host-map-bytes map)))
536 (let* ((low (byte-position byte))
537 (high (+ low (byte-size byte)))
538 (good (funcall good-byte low high)))
539 (when good
540 (return-from hack
541 (ipnet-host-index map
542 (ipaddr (funcall tweak-addr
543 (ash 1 good))
544 (ipnet-net
545 (host-map-ipnet map))))))))
546 (error "No variable bits in range.")))
547 (values (hack #'identity
548 (lambda (low high)
549 (and (< start high) (max start low)))
550 #'identity)
551 (hack #'reverse
552 (lambda (low high)
553 (and (>= end low) (min end high)))
554 #'1-))))
9c44003b 555
e1528fd6 556(export 'ipnet-host)
9c44003b 557(defun ipnet-host (ipn host)
f4e0c48f
MW
558 "Return the address of the given HOST in network IPN.
559
88867b1a
MW
560 The HOST may be a an integer index into the network (this works even with
561 a non-contiguous netmask) or a string or symbolic suffix (as for
562 `string-subnet')."
563 (etypecase host
564 (integer
565 (ipnet-index-host (ipnet-host-map ipn) host))
566 ((or symbol string)
567 (multiple-value-bind (addr mask)
568 (parse-subipnet ipn host :slashp nil)
569 (unless (= mask (mask (ipaddr-width addr)))
570 (error "Host address incomplete"))
571 addr))))
9c44003b 572
e1528fd6 573(export 'ipaddr-networkp)
9c44003b 574(defun ipaddr-networkp (ip ipn)
32ebbe9b
MW
575 "Returns true if numeric address IP is within network IPN."
576 (with-ipnet (nil addr mask) ipn
577 (= addr (logand ip mask))))
9c44003b 578
e1528fd6 579(export 'ipnet-subnetp)
9c44003b
MW
580(defun ipnet-subnetp (ipn subn)
581 "Returns true if SUBN is a (non-strict) subnet of IPN."
32ebbe9b
MW
582 (with-ipnet (net addr mask) ipn
583 (with-ipnet (subnet subaddr submask) subn
584 (and (ipaddr-comparable-p net subnet)
585 (= addr (logand subaddr mask))
9c44003b
MW
586 (= submask (logior mask submask))))))
587
32ebbe9b
MW
588(export 'ipnet-overlapp)
589(defun ipnet-overlapp (ipn-a ipn-b)
590 "Returns true if IPN-A and IPN-B have any addresses in common."
591 (with-ipnet (net-a addr-a mask-a) ipn-a
592 (with-ipnet (net-b addr-b mask-b) ipn-b
593
594 ;; In the case of an overlap, we explicitly construct a common
595 ;; address. If this fails, we know that the networks don't overlap
596 ;; after all.
597 (flet ((narrow (addr-a mask-a addr-b mask-b)
598 ;; Narrow network A towards B, by setting bits in A's base
599 ;; address towards which A is indifferent, but B is not;
600 ;; return the resulting base address. This address is still
601 ;; within network A, since we only set bits to which A is
602 ;; indifferent.
603 (logior addr-a (logand addr-b (logandc2 mask-a mask-b)))))
604
605 (and (ipaddr-comparable-p net-a net-b)
606 (= (narrow addr-a mask-a addr-b mask-b)
607 (narrow addr-b mask-b addr-a mask-a)))))))
608
609(export 'ipnet-changeable-bits)
610(defun ipnet-changeable-bits (width mask)
611 "Work out the number of changeable bits in a network, given its MASK.
612
613 This is a conservative estimate in the case of noncontiguous masks. The
614 WIDTH is the total width of an address."
615
616 ;; We bisect the address. If the low-order bits are changeable then we
617 ;; recurse on them; otherwise we look at the high-order bits. A mask M of
618 ;; width W is changeable if it's not all-ones, i.e., if M /= 2^W. If the
619 ;; top half is changeable then we don't need to look at the bottom half.
620 (labels ((recurse (width mask offset)
621 (if (= width 1)
622 (if (zerop mask) (1+ offset) offset)
623 (let* ((lowwidth (floor width 2))
624 (highwidth (- width lowwidth))
625 (highmask (ash mask (- lowwidth))))
626 (if (logbitp highwidth (1+ highmask))
627 (recurse lowwidth
628 (logand mask (mask lowwidth))
629 offset)
630 (recurse highwidth highmask (+ offset lowwidth)))))))
631 (recurse width mask 0)))
9c44003b
MW
632
633;;;--------------------------------------------------------------------------
32ebbe9b
MW
634;;; Reverse lookups.
635
636(export 'reverse-domain-component-width)
637(defgeneric reverse-domain-component-width (ipaddr)
638 (:documentation "Return the component width for splitting IPADDR."))
639
640(export 'reverse-domain-component-radix)
641(defgeneric reverse-domain-radix (ipaddr)
642 (:documentation "Return the radix for representing IPADDR components."))
643
644(export 'reverse-domain-component-suffix)
645(defgeneric reverse-domain-suffix (ipaddr)
646 (:documentation "Return the reverse-lookup domain suffix for IPADDR."))
647
648(export 'reverse-domain-fragment)
649(defgeneric reverse-domain-fragment (ipaddr start end &key partialp)
650 (:documentation
651 "Return a portion of an IPADDR's reverse-resolution domain name.
652
653 Specifically, return the portion of the name which covers the bits of an
654 IPADDR between bits START (inclusive) and END (exclusive). Address
655 components which are only partially within the given bounds are included
656 unless PARTIALP is nil.")
657 (:method ((ipaddr ipaddr) start end &key (partialp t))
658
659 (let ((addr (ipaddr-addr ipaddr))
660 (comp-width (reverse-domain-component-width ipaddr))
661 (radix (reverse-domain-radix ipaddr)))
662
663 (with-output-to-string (out)
664 (do ((i (funcall (if partialp #'round-down #'round-up)
665 start comp-width)
666 (+ i comp-width))
667 (limit (funcall (if partialp #'round-up #'round-down)
668 end comp-width))
669 (sep nil t))
670 ((>= i limit))
671 (format out "~:[~;.~]~(~vR~)"
672 sep radix (ldb (byte comp-width i) addr)))))))
673
674(export 'reverse-domain)
675(defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
676 (:documentation "Return a reverse-resolution domain name for IPADDR-OR-IPN.
677
678 If PREFIX-LEN is nil then it defaults to the length of the network's fixed
679 prefix.")
680 (:method ((ipn ipnet) &optional prefix-len)
681 (let* ((addr (ipnet-net ipn))
682 (mask (ipnet-mask ipn))
683 (width (ipaddr-width addr)))
684 (concatenate 'string
685 (reverse-domain-fragment
686 addr
687 (if prefix-len
688 (- width prefix-len)
689 (ipnet-changeable-bits width mask))
690 width
691 :partialp nil)
692 "."
693 (reverse-domain-suffix addr))))
694 (:method ((addr ipaddr) &optional prefix-len)
695 (let* ((width (ipaddr-width addr)))
696 (reverse-domain (make-ipnet addr (mask width))
697 (or prefix-len width)))))
9c44003b
MW
698
699;;;--------------------------------------------------------------------------
700;;; Network names and specifiers.
701
e1528fd6 702(export 'net)
32ebbe9b
MW
703(export 'net-name)
704(export 'net-ipnets)
705(defclass net ()
706 ((name :type string :initarg :name :reader net-name)
707 (ipnets :type list :initarg :ipnets :initform nil :accessor net-ipnets)
708 (next :type unsigned-byte :initform 1 :accessor net-next)))
709
710(defmethod print-object ((net net) stream)
711 (print-unreadable-object (net stream :type t)
712 (format stream "~A~@[ = ~{~A~^, ~}~]"
713 (net-name net)
714 (mapcar #'ipnet-string (net-ipnets net)))))
9c44003b
MW
715
716(defvar *networks* (make-hash-table :test #'equal)
717 "The table of known networks.")
718
e1528fd6 719(export 'net-find)
9c44003b
MW
720(defun net-find (name)
721 "Find a network by NAME."
722 (gethash (string-downcase (stringify name)) *networks*))
9c44003b
MW
723(defun (setf net-find) (net name)
724 "Make NAME map to NET."
725 (setf (gethash (string-downcase (stringify name)) *networks*) net))
726
32ebbe9b
MW
727(export 'net-must-find)
728(defun net-must-find (name)
729 (or (net-find name)
730 (error "Unknown network ~A." name)))
731
732(defun net-ipnet (net family)
733 (find family (net-ipnets net) :key #'ipnet-family))
734(defun (setf net-ipnet) (ipnet net family)
735 (assert (eq (ipnet-family ipnet) family))
736 (let ((ipns (net-ipnets net)))
737 (if (find family ipns :key #'ipnet-family)
738 (nsubstitute ipnet family ipns :key #'ipnet-family)
739 (setf (net-ipnets net) (cons ipnet ipns)))))
740
741(defun process-net-form (name addr subnets)
f4e0c48f
MW
742 "Unpack a net-form.
743
32ebbe9b
MW
744 A net-form looks like (NAME ADDR [SUBNET ...]) where:
745
746 * NAME is the name for the network.
747
748 * ADDR is the subnet address (acceptable to `string-subipnet'); at
749 top-level, this is a plain network address (acceptable to
750 `string-ipnet'). Alternatively (for compatibility) the ADDR for a
751 non-top-level network can be an integer number of addresses to
752 allocate to this subnet; the subnet's base address is implicitly just
753 past the previous subnet's limit address (or, for the first subnet,
754 it's the parent network's base address). This won't work at all well
755 if your subnets have crazy netmasks.
756
757 * The SUBNETs are further net-forms, of the same form, whose addresses
758 are interpreted relative to the parent network's address.
759
760 The return value is a list of items of the form (NAME . IPNET)."
761
762 (labels ((process-subnets (subnets parent)
763 (let ((finger (ipnet-addr parent))
764 (list nil))
765 (dolist (subnet subnets list)
766 (destructuring-bind (name addr &rest subs) subnet
767 (let ((net (etypecase addr
768 (integer
769 (when (or (> (count-low-zero-bits addr)
770 (count-low-zero-bits finger))
771 (not (zerop (logand addr
772 (1- addr)))))
773 (error "Bad subnet size for ~A." name))
774 (make-ipnet
775 (ipaddr finger (ipnet-net parent))
776 (ipaddr (- (ash 1 (ipnet-width parent))
777 addr)
778 (ipnet-net parent))))
779 ((or string symbol)
780 (string-subipnet parent addr)))))
781
782 (unless (ipnet-subnetp parent net)
783 (error "Network `~A' (~A) falls outside parent ~A."
784 name (ipnet-string net) (ipnet-string parent)))
785
786 (dolist (entry list nil)
787 (let ((ipn (cdr entry)))
788 (when (ipnet-overlapp ipn net)
789 (error "Network `~A' (~A) overlaps `~A' (~A)."
790 name (ipnet-string net)
791 (car entry) (ipnet-string ipn)))))
792
793 (setf finger
794 (1+ (logior
795 (ipnet-addr net)
796 (logxor (ipnet-mask net)
797 (1- (ash 1 (ipnet-width net)))))))
798
799 (when name
800 (push (cons name net) list))
801
802 (when subs
803 (setf list (nconc (process-subnets subs net)
804 list)))))))))
805
806 (let* ((top (string-ipnet addr))
807 (list (nreverse (process-subnets subnets top))))
808 (when name (push (cons name top) list))
809 list)))
9c44003b 810
e1528fd6 811(export 'net-create)
9c44003b 812(defun net-create (name net)
f4e0c48f
MW
813 "Construct a new network called NAME and add it to the map.
814
32ebbe9b
MW
815 The NET describes the new network, in a form acceptable to the `ipnet'
816 function. A named network may have multiple addresses with different
817 families: each `net-create' call adds a new family, or modifies the net's
818 address in an existing family."
819 (let ((ipn (ipnet net))
820 (net (net-find name)))
821 (if net
822 (progn (setf (net-ipnet net (ipnet-family ipn)) ipn) net)
823 (setf (net-find name)
824 (make-instance 'net
825 :name (string-downcase (stringify name))
826 :ipnets (list ipn))))))
9c44003b 827
e1528fd6 828(export 'defnet)
9c44003b 829(defmacro defnet (name net &rest subnets)
f4e0c48f
MW
830 "Main network definition macro.
831
832 None of the arguments is evaluated."
9c44003b 833 `(progn
32ebbe9b
MW
834 ,@(mapcar (lambda (item)
835 (let ((name (car item)) (ipn (cdr item)))
836 `(net-create ',name ',ipn)))
837 (process-net-form name net subnets))
838 ',name))
839
8d531634
MW
840(defun filter-by-family (func form family)
841 "Handle a family-switch form.
842
843 Here, FUNC is a function of two arguments ITEM and FAMILY. FORM is either
844 a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly
845 acceptable to FUNC. Return a list of the resulting outputs of FUNC."
846
847 (if (and (listp form)
848 (every (lambda (clause)
849 (and (listp clause)
850 (family-addrclass (car clause))))
851 form))
852 (mapcan (lambda (clause)
853 (let ((fam (car clause)))
854 (and (or (eq family t)
855 (eq family fam))
856 (list (funcall func (cdr clause) fam)))))
857 form)
858 (list (funcall func form family))))
859
32ebbe9b
MW
860(export 'net-parse-to-ipnets)
861(defun net-parse-to-ipnets (form &optional (family t))
6a26c716
MW
862 "Parse FORM into a list of ipnet objects.
863
864 The FORM can be any of the following.
865
866 * NAME -- a named network, established using `net-create' or `defnet'
867
868 * IPNET -- a network, in a form acceptable to `ipnet'
869
870 * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY"
871
32ebbe9b
MW
872 (flet ((hack (form family)
873 (let* ((form (if (and (consp form)
874 (endp (cdr form)))
875 (car form)
876 form))
877 (net (net-find form))
878 (ipns (if net (net-ipnets net)
879 (list (ipnet form)))))
880 (if (eq family t) ipns
881 (remove family ipns
882 :key #'ipnet-family
883 :test-not #'eq)))))
8d531634 884 (let* ((ipns (apply #'append (filter-by-family #'hack form family)))
32ebbe9b
MW
885 (merged (reduce (lambda (ipns ipn)
886 (if (find (ipnet-family ipn) ipns
887 :key #'ipnet-family)
888 ipns
889 (cons ipn ipns)))
890 ipns
891 :initial-value nil)))
892 (or merged (error "No matching addresses.")))))
9c44003b 893
e1528fd6 894(export 'net-host)
32ebbe9b
MW
895(defun net-host (net-form host &optional (family t))
896 "Return the given HOST on the NET, as an anonymous `host' object.
f4e0c48f 897
88867b1a
MW
898 HOST may be an index (in range, of course), a suffix (as a symbol or
899 string, as for `string-subnet'), or one of the keywords:
2f1d381d 900
32ebbe9b
MW
901 :next next host, as by net-next-host
902 :net network base address
903 :broadcast network broadcast address
904
905 If FAMILY is not `t', then only return an address with that family;
906 otherwise return all available addresses."
907 (flet ((hosts (ipns host)
908 (mapcar (lambda (ipn) (ipnet-host ipn host))
88867b1a
MW
909 (if (integerp host)
910 (remove host ipns :key #'ipnet-hosts :test #'>=)
911 ipns))))
32ebbe9b
MW
912 (let* ((net (and (typep net-form '(or string symbol))
913 (net-find net-form)))
914 (ipns (net-parse-to-ipnets net-form family))
915 (addrs (case host
916 (:next
917 (if net
918 (prog1 (hosts ipns (net-next net))
919 (incf (net-next net)))
920 (error "Can't use `:next' without a named net.")))
921 (:net (mapcar #'ipnet-net ipns))
922 (:broadcast (remove nil (mapcar #'ipnet-broadcast ipns)))
923 (t (hosts ipns host)))))
924 (unless addrs
925 (error "No networks have that address."))
926 (make-instance 'host :addrs addrs))))
927
928;;;--------------------------------------------------------------------------
929;;; Host names and specifiers.
930
931(export 'host)
932(export 'host-name)
933(export 'host-addrs)
934(defclass host ()
935 ((name :type (or string null) :initform nil
936 :initarg :name :reader host-name)
937 (addrs :type list :initarg :addrs :initform nil :accessor host-addrs)))
938
939(defmethod print-object ((host host) stream)
940 (print-unreadable-object (host stream :type t)
941 (format stream "~:[<anonymous>~;~@*~A~]~@[ = ~{~A~^, ~}~]"
942 (host-name host)
943 (mapcar #'ipaddr-string (host-addrs host)))))
944
945(defvar *hosts* (make-hash-table :test #'equal)
946 "The table of known hostnames.")
947
948(export 'host-find)
949(defun host-find (name)
950 "Find a host by NAME."
951 (gethash (string-downcase (stringify name)) *hosts*))
952(defun (setf host-find) (addr name)
953 "Make NAME map to ADDR (must be an ipaddr in integer form)."
954 (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
955
956(defun merge-addresses (addrs-a addrs-b)
957 (append (remove-if (lambda (addr)
958 (member (ipaddr-family addr) addrs-b
959 :key #'ipaddr-family))
960 addrs-a)
961 addrs-b))
962
963(export 'host-parse)
964(defun host-parse (addr &optional (family t))
965 "Convert the ADDR into a (possibly anonymous) `host' object.
966
967 The ADDR can be one of a number of different things.
968
969 HOST a host name defined using `defhost'
970
971 (NET INDEX) a particular host in a network
972
973 IPADDR an address form acceptable to `ipnet'
974
975 ((FAMILY . ADDR) ...) the above, restricted to a particular address
976 FAMILY (i.e., one of the keywords `:ipv4',
977 etc.)"
978
979 (labels ((filter-addresses (addrs family)
980 (make-instance 'host
981 :addrs (if (eq family t) addrs
982 (remove family addrs
983 :key #'ipaddr-family
984 :test-not #'eq))))
985 (host-addresses (host family)
986 (if (eq family t) host
987 (filter-addresses (host-addrs host) family)))
988 (hack (addr family)
989 (let* ((form (listify addr))
990 (indic (car form))
991 (host (and (null (cdr form))
992 (host-find indic))))
993 (cond (host
994 (host-addresses host family))
995 ((and (consp (cdr form))
996 (endp (cddr form)))
997 (net-host (car form) (cadr form) family))
998 (t
999 (filter-addresses (list (ipaddr indic)) family))))))
8d531634
MW
1000 (let* ((list (filter-by-family #'hack addr family))
1001 (host (if (and list (cdr list))
1002 (make-instance 'host
1003 :addrs (reduce #'merge-addresses
1004 (mapcar #'host-addrs
1005 (reverse list))
1006 :initial-value nil))
1007 (car list))))
32ebbe9b
MW
1008 (unless (host-addrs host)
1009 (error "No matching addresses."))
1010 host)))
1011
1012(export 'host-create)
1013(defun host-create (name addr)
1014 "Make host NAME map to ADDR (anything acceptable to `host-parse')."
1015 (let ((existing (host-find name))
1016 (new (host-parse addr)))
1017 (if (not existing)
1018 (setf (host-find name)
1019 (make-instance 'host
1020 :name (string-downcase (stringify name))
1021 :addrs (host-addrs new)))
1022 (progn
1023 (setf (host-addrs existing)
1024 (merge-addresses (host-addrs existing) (host-addrs new)))
1025 existing))))
1026
1027(export 'defhost)
1028(defmacro defhost (name addr)
1029 "Main host definition macro. Neither NAME nor ADDR is evaluated."
1030 `(progn
1031 (host-create ',name ',addr)
1032 ',name))
9c44003b
MW
1033
1034;;;----- That's all, folks --------------------------------------------------