Commit | Line | Data |
---|---|---|
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 | ||
db43369d MW |
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. | |
90 | ||
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. | |
97 | ||
98 | Returns two values: whether STRING1 strictly precedes STRING2, and whether | |
99 | STRING1 strictly follows STRING2." | |
100 | ||
101 | (let ((end1 (or end1 (length string1))) | |
102 | (end2 (or end2 (length string2)))) | |
103 | (loop | |
104 | (cond ((>= start1 end1) | |
105 | (let ((eqp (>= start2 end2))) | |
106 | (return (values (not eqp) nil)))) | |
107 | ((>= start2 end2) | |
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) | |
113 | 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) | |
117 | 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)))) | |
121 | (setf start1 lim1 | |
122 | start2 lim2))) | |
123 | (t | |
124 | (let ((lim1 (or (position-if #'digit-char-p string1 | |
125 | :start start1 :end end1) | |
126 | end1)) | |
127 | (lim2 (or (position-if #'digit-char-p string2 | |
128 | :start start2 :end end2) | |
129 | 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)))) | |
138 | (setf start1 lim1 | |
139 | start2 lim2))))))) | |
140 | ||
32ebbe9b MW |
141 | ;;;-------------------------------------------------------------------------- |
142 | ;;; Parsing primitives for addresses. | |
143 | ||
144 | (defun parse-partial-address | |
145 | (str | |
146 | &key (start 0) (end nil) (delim #\.) | |
147 | (width 8) (radix 10) (min 1) (max 32) (shiftp t) | |
148 | (what "address")) | |
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 | |
153 | ||
154 | SUM_{1<=i<=k} 2^{WIDTH (k-i)} N_i | |
155 | ||
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. | |
159 | ||
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 | |
162 | specified by STR." | |
163 | ||
164 | (setf-default end (length str)) | |
165 | (let ((addr 0) (nbits 0) (limit (ash 1 width))) | |
166 | (when (< start end) | |
167 | (loop | |
168 | (when (>= nbits max) | |
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)) | |
176 | (incf nbits width) | |
177 | (unless pos (return)) | |
178 | (setf start (1+ pos))))) | |
179 | (when (< nbits min) | |
180 | (error "Not enough elements in ~A" what)) | |
181 | (if shiftp | |
182 | (let* ((top (round-up max width)) | |
183 | (shift (- top nbits))) | |
184 | (values (ash addr shift) shift top)) | |
185 | (values addr 0 nbits)))) | |
9c44003b MW |
186 | |
187 | ;;;-------------------------------------------------------------------------- | |
32ebbe9b MW |
188 | ;;; Simple messing about with IP addresses. |
189 | ||
190 | (export 'ipaddr) | |
191 | (export 'ipaddr-addr) | |
192 | (defclass ipaddr (savable-object) | |
193 | () | |
194 | (:documentation | |
195 | "Base class for IP addresses.")) | |
196 | ||
197 | (export 'ipaddr-family) | |
6a26c716 MW |
198 | (defgeneric ipaddr-family (addr) |
199 | (:documentation "Return the address family of ADDR, as a keyword.")) | |
32ebbe9b MW |
200 | |
201 | (export 'family-addrclass) | |
202 | (defgeneric family-addrclass (family) | |
6a26c716 | 203 | (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.") |
32ebbe9b MW |
204 | (:method ((af symbol)) nil)) |
205 | ||
206 | (export 'ipaddr-width) | |
207 | (defgeneric ipaddr-width (class) | |
6a26c716 MW |
208 | (:documentation "Return the width, in bits, of addresses from CLASS. |
209 | ||
210 | Alternatively, the CLASS may be given as an example object.") | |
32ebbe9b MW |
211 | (:method ((object t)) (ipaddr-width (extract-class-name object)))) |
212 | ||
213 | (export 'ipaddr-comparable-p) | |
214 | (defgeneric ipaddr-comparable-p (addr-a addr-b) | |
6a26c716 | 215 | (:documentation "Is it meaningful to compare ADDR-A and ADDR-B?") |
32ebbe9b MW |
216 | (:method ((addr-a ipaddr) (addr-b ipaddr)) |
217 | (eq (class-of addr-a) (class-of addr-b)))) | |
218 | ||
219 | (defun guess-address-class (str &key (start 0) (end nil)) | |
6a26c716 MW |
220 | "Return a class name for the address in (the given substring of) STR. |
221 | ||
222 | This ought to be an extension point for additional address families, but | |
223 | it isn't at the moment." | |
a2267e14 MW |
224 | (cond ((position #\: str :start start :end end) 'ip6addr) |
225 | (t 'ip4addr))) | |
32ebbe9b MW |
226 | |
227 | (defgeneric parse-partial-ipaddr (class str &key start end min max) | |
6a26c716 MW |
228 | (:documentation |
229 | "Parse (a substring of) STR into a partial address of the given CLASS. | |
230 | ||
231 | Returns three values: the parsed address fragment, as an integer; and the | |
232 | low and high bit positions covered by the response. | |
233 | ||
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.") | |
32ebbe9b MW |
238 | (:method ((object t) str &rest keywords) |
239 | (apply #'parse-partial-ipaddr (extract-class-name object) str keywords))) | |
9c44003b | 240 | |
e1528fd6 | 241 | (export 'string-ipaddr) |
9c44003b | 242 | (defun string-ipaddr (str &key (start 0) (end nil)) |
32ebbe9b | 243 | "Parse STR into an address; guess what kind is intended by the user. |
f4e0c48f MW |
244 | |
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." | |
9c44003b | 247 | (setf str (stringify str)) |
32ebbe9b MW |
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)))) | |
254 | ||
255 | (export 'integer-ipaddr) | |
256 | (defgeneric integer-ipaddr (int like) | |
257 | (:documentation "Convert INT into an address of type indicated by LIKE. | |
258 | ||
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 | |
261 | names.") | |
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))) | |
9c44003b | 266 | |
e1528fd6 | 267 | (export 'ipaddr-string) |
32ebbe9b | 268 | (defgeneric ipaddr-string (ip) |
6a26c716 | 269 | (:documentation "Transform the address IP into a numeric textual form.")) |
32ebbe9b MW |
270 | |
271 | (defmethod print-object ((addr ipaddr) stream) | |
63b00b21 MW |
272 | (if *print-escape* |
273 | (print-unreadable-object (addr stream :type t) | |
274 | (write-string (ipaddr-string addr) stream)) | |
275 | (write-string (ipaddr-string addr) stream))) | |
9c44003b | 276 | |
e1528fd6 | 277 | (export 'ipaddrp) |
9c44003b MW |
278 | (defun ipaddrp (ip) |
279 | "Answer true if IP is a valid IP address in integer form." | |
280 | (typep ip 'ipaddr)) | |
281 | ||
32ebbe9b MW |
282 | (defun ipaddr (ip &optional like) |
283 | "Convert IP to an IP address, of type similar to LIKE. | |
f4e0c48f | 284 | |
32ebbe9b MW |
285 | If it's an IP address, just return it unchanged; If it's an integer, |
286 | capture it; otherwise convert by `string-ipaddr'." | |
9c44003b MW |
287 | (typecase ip |
288 | (ipaddr ip) | |
32ebbe9b | 289 | (integer (integer-ipaddr ip like)) |
9c44003b MW |
290 | (t (string-ipaddr ip)))) |
291 | ||
32ebbe9b MW |
292 | (export 'ipaddr-rrtype) |
293 | (defgeneric ipaddr-rrtype (addr) | |
294 | (:documentation "Return the proper resource record type for ADDR.")) | |
295 | ||
9c44003b MW |
296 | ;;;-------------------------------------------------------------------------- |
297 | ;;; Netmasks. | |
298 | ||
e1528fd6 | 299 | (export 'integer-netmask) |
32ebbe9b MW |
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)))) | |
9c44003b | 303 | |
88dc0b1c MW |
304 | (export 'ipmask-cidr-slash) |
305 | (defun ipmask-cidr-slash (width mask) | |
f4e0c48f MW |
306 | "Given a netmask MASK, try to compute a prefix length. |
307 | ||
32ebbe9b MW |
308 | Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if |
309 | this is impossible." | |
310 | (let* ((low (logxor mask (mask width))) | |
311 | (bits (integer-length low))) | |
312 | (and (= low (mask bits)) (- width bits)))) | |
313 | ||
314 | (export 'ipmask) | |
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))) | |
321 | (if (<= 0 mask w) | |
322 | (integer-netmask w mask) | |
b496b60f | 323 | (error "Prefix length out of range."))))) |
32ebbe9b MW |
324 | |
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)) | |
9c44003b MW |
329 | |
330 | ;;;-------------------------------------------------------------------------- | |
331 | ;;; Networks: pairing an address and netmask. | |
332 | ||
e1528fd6 | 333 | (export 'ipnet) |
32ebbe9b MW |
334 | (export 'ipnet-net) |
335 | (export 'ipnet-mask) | |
336 | (defclass ipnet (savable-object) | |
337 | () | |
338 | (:documentation "Base class for IP networks.")) | |
9c44003b | 339 | |
32ebbe9b MW |
340 | (export 'ipnet-family) |
341 | (defgeneric ipnet-family (ipn) | |
6a26c716 | 342 | (:documentation "Return the address family of IPN, as a keyword.") |
32ebbe9b | 343 | (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn)))) |
9c44003b | 344 | |
32ebbe9b MW |
345 | (export 'ipnet-addr) |
346 | (defun ipnet-addr (ipn) | |
347 | "Return the base network address of IPN as a raw integer." | |
348 | (ipaddr-addr (ipnet-net ipn))) | |
9c44003b | 349 | |
32ebbe9b MW |
350 | (export 'ipaddr-ipnet) |
351 | (defgeneric ipaddr-ipnet (addr mask) | |
352 | (:documentation "Construct an `ipnet' object given a base ADDR and MASK.")) | |
353 | ||
354 | (export 'make-ipnet) | |
355 | (defun make-ipnet (net mask) | |
6a26c716 MW |
356 | "Construct an IP-network object given the NET and MASK. |
357 | ||
358 | These are transformed as though by `ipaddr' and `ipmask'." | |
32ebbe9b MW |
359 | (let* ((net (ipaddr net)) |
360 | (mask (ipmask net mask))) | |
361 | (ipaddr-ipnet (mask-ipaddr net mask) mask))) | |
9c44003b | 362 | |
e1528fd6 | 363 | (export 'with-ipnet) |
32ebbe9b | 364 | (defmacro with-ipnet ((net addr mask) ipn &body body) |
f4e0c48f MW |
365 | "Evaluate the BODY with components of IPN in scope. |
366 | ||
32ebbe9b MW |
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 | |
370 | wanted." | |
9c44003b MW |
371 | (with-gensyms tmp |
372 | `(let ((,tmp ,ipn)) | |
373 | (let (,@(and net `((,net (ipnet-net ,tmp)))) | |
32ebbe9b | 374 | ,@(and addr `((,addr (ipnet-addr ,tmp)))) |
9c44003b MW |
375 | ,@(and mask `((,mask (ipnet-mask ,tmp))))) |
376 | ,@body)))) | |
377 | ||
32ebbe9b MW |
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))) | |
9c44003b | 382 | |
e1528fd6 | 383 | (export 'ipnet-string) |
9c44003b MW |
384 | (defun ipnet-string (ipn) |
385 | "Convert IPN to a string." | |
32ebbe9b | 386 | (with-ipnet (net nil mask) ipn |
9c44003b MW |
387 | (format nil "~A/~A" |
388 | (ipaddr-string net) | |
88dc0b1c | 389 | (or (ipmask-cidr-slash (ipnet-width ipn) mask) |
32ebbe9b MW |
390 | (ipaddr-string (make-instance (class-of net) :addr mask)))))) |
391 | ||
392 | (defmethod print-object ((ipn ipnet) stream) | |
63b00b21 MW |
393 | (if *print-escape* |
394 | (print-unreadable-object (ipn stream :type t) | |
395 | (write-string (ipnet-string ipn) stream)) | |
396 | (write-string (ipnet-string ipn) stream))) | |
32ebbe9b | 397 | |
6343e7bf | 398 | (defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t)) |
6a26c716 MW |
399 | "Parse a subnet description from (a substring of) STR. |
400 | ||
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 | |
404 | their own reasons. | |
405 | ||
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. | |
413 | ||
414 | Returns the relative base address and mask as two integer values." | |
415 | ||
32ebbe9b | 416 | (setf-default end (length str)) |
6343e7bf | 417 | (let ((sl (and slashp (position #\/ str :start start :end end)))) |
32ebbe9b MW |
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) | |
423 | present) | |
424 | ((every #'digit-char-p (subseq str (1+ sl) end)) | |
425 | (let ((length (parse-integer str | |
426 | :start (1+ sl) | |
427 | :end end))) | |
428 | (unless (>= length (- width max)) | |
429 | (error "Mask doesn't reach subnet boundary")) | |
430 | (integer-netmask max (- length (- width max))))) | |
431 | (t | |
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))))) | |
437 | ||
6343e7bf MW |
438 | (defun check-subipnet (base-ipn sub-addr sub-mask) |
439 | "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN. | |
32ebbe9b | 440 | |
6343e7bf MW |
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 | |
445 | integer)." | |
32ebbe9b | 446 | (with-ipnet (base-net base-addr base-mask) base-ipn |
6343e7bf | 447 | (let* ((common (logand base-mask sub-mask)) |
32ebbe9b MW |
448 | (base-overlap (logand base-addr common)) |
449 | (sub-overlap (logand sub-addr common)) | |
450 | (full-mask (logior base-mask sub-mask))) | |
6343e7bf | 451 | (unless (or (zerop sub-overlap) (= sub-overlap base-overlap)) |
32ebbe9b | 452 | (error "Subnet doesn't match base network")) |
6343e7bf MW |
453 | (values (integer-ipaddr (logand full-mask (logior base-addr sub-addr)) |
454 | base-net) | |
455 | full-mask)))) | |
32ebbe9b MW |
456 | |
457 | (export 'string-ipnet) | |
458 | (defun string-ipnet (str &key (start 0) (end nil)) | |
6a26c716 MW |
459 | "Parse an IP network description from the string STR. |
460 | ||
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." | |
32ebbe9b MW |
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))))) | |
473 | ||
6343e7bf MW |
474 | (defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t)) |
475 | "Parse STR as a subnet of IPN. | |
476 | ||
6a26c716 MW |
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 | |
479 | in explicitly. | |
480 | ||
481 | Returns two values: the combined base address, as an `ipnaddr' and | |
482 | combined mask, as an integer." | |
483 | ||
32ebbe9b MW |
484 | (let* ((addr-class (extract-class-name (ipnet-net ipn))) |
485 | (width (ipaddr-width addr-class)) | |
486 | (max (- width | |
88dc0b1c | 487 | (or (ipmask-cidr-slash width (ipnet-mask ipn)) |
32ebbe9b MW |
488 | (error "Base network has complex netmask"))))) |
489 | (multiple-value-bind (addr mask) | |
6343e7bf MW |
490 | (parse-subnet addr-class width max (stringify str) |
491 | :start start :end end :slashp slashp) | |
492 | (check-subipnet ipn addr mask)))) | |
493 | ||
494 | (export 'string-subipnet) | |
495 | (defun string-subipnet (ipn str &key (start 0) (end nil)) | |
6a26c716 MW |
496 | "Parse an IP subnet from a parent net IPN and a suffix string STR. |
497 | ||
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. | |
505 | ||
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." | |
510 | ||
6343e7bf MW |
511 | (multiple-value-bind (addr mask) |
512 | (parse-subipnet ipn str :start start :end end) | |
513 | (ipaddr-ipnet addr mask))) | |
32ebbe9b MW |
514 | |
515 | (defun ipnet (net) | |
516 | "Construct an IP-network object from the given argument. | |
517 | ||
518 | A number of forms are acceptable: | |
519 | ||
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') | |
523 | version." | |
524 | (typecase net | |
525 | (ipnet net) | |
526 | ((or string symbol) (string-ipnet net)) | |
527 | (t (apply #'make-ipnet (pairify net nil))))) | |
9c44003b | 528 | |
e1528fd6 | 529 | (export 'ipnet-broadcast) |
32ebbe9b MW |
530 | (defgeneric ipnet-broadcast (ipn) |
531 | (:documentation "Return the broadcast address for the network IPN. | |
532 | ||
533 | Returns nil if there isn't one.")) | |
9c44003b | 534 | |
e1528fd6 | 535 | (export 'ipnet-hosts) |
9c44003b MW |
536 | (defun ipnet-hosts (ipn) |
537 | "Return the number of available addresses in network IPN." | |
32ebbe9b MW |
538 | (ash 1 (- (ipnet-width ipn) (logcount (ipnet-mask ipn))))) |
539 | ||
540 | (defstruct host-map | |
541 | "An internal object used by `ipnet-index-host' and `ipnet-host-index'. | |
542 | ||
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." | |
547 | ipnet | |
548 | bytes) | |
549 | ||
550 | (export 'ipnet-host-map) | |
551 | (defun ipnet-host-map (ipn) | |
552 | "Work out how to enumerate the variable portion of IPN. | |
553 | ||
554 | Returns an object which can be passed to `ipnet-index-host' and | |
555 | `ipnet-host-index'." | |
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))) | |
559 | (loop | |
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)))) | |
566 | ||
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))))) | |
575 | (unless (zerop host) | |
576 | (error "Host index out of range.")) | |
577 | (integer-ipaddr addr (ipnet-net ipn)))) | |
578 | ||
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)) | |
583 | (host 0) (offset 0)) | |
584 | (dolist (byte (host-map-bytes map)) | |
585 | (setf host (logior host | |
586 | (ash (ldb byte addr) offset)) | |
587 | offset (+ offset (byte-size byte)))) | |
588 | host)) | |
589 | ||
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))) | |
598 | (when good | |
599 | (return-from hack | |
600 | (ipnet-host-index map | |
601 | (ipaddr (funcall tweak-addr | |
602 | (ash 1 good)) | |
603 | (ipnet-net | |
604 | (host-map-ipnet map)))))))) | |
605 | (error "No variable bits in range."))) | |
606 | (values (hack #'identity | |
607 | (lambda (low high) | |
608 | (and (< start high) (max start low))) | |
609 | #'identity) | |
610 | (hack #'reverse | |
611 | (lambda (low high) | |
612 | (and (>= end low) (min end high))) | |
613 | #'1-)))) | |
9c44003b | 614 | |
e1528fd6 | 615 | (export 'ipnet-host) |
9c44003b | 616 | (defun ipnet-host (ipn host) |
f4e0c48f MW |
617 | "Return the address of the given HOST in network IPN. |
618 | ||
88867b1a MW |
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 | |
621 | `string-subnet')." | |
622 | (etypecase host | |
623 | (integer | |
624 | (ipnet-index-host (ipnet-host-map ipn) host)) | |
625 | ((or symbol string) | |
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")) | |
630 | addr)))) | |
9c44003b | 631 | |
e1528fd6 | 632 | (export 'ipaddr-networkp) |
9c44003b | 633 | (defun ipaddr-networkp (ip ipn) |
32ebbe9b MW |
634 | "Returns true if numeric address IP is within network IPN." |
635 | (with-ipnet (nil addr mask) ipn | |
636 | (= addr (logand ip mask)))) | |
9c44003b | 637 | |
e1528fd6 | 638 | (export 'ipnet-subnetp) |
9c44003b MW |
639 | (defun ipnet-subnetp (ipn subn) |
640 | "Returns true if SUBN is a (non-strict) subnet of IPN." | |
32ebbe9b MW |
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)) | |
9c44003b MW |
645 | (= submask (logior mask submask)))))) |
646 | ||
32ebbe9b MW |
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 | |
652 | ||
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 | |
655 | ;; after all. | |
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 | |
661 | ;; indifferent. | |
662 | (logior addr-a (logand addr-b (logandc2 mask-a mask-b))))) | |
663 | ||
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))))))) | |
667 | ||
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. | |
671 | ||
672 | This is a conservative estimate in the case of noncontiguous masks. The | |
673 | WIDTH is the total width of an address." | |
674 | ||
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) | |
680 | (if (= width 1) | |
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)) | |
686 | (recurse lowwidth | |
687 | (logand mask (mask lowwidth)) | |
688 | offset) | |
689 | (recurse highwidth highmask (+ offset lowwidth))))))) | |
690 | (recurse width mask 0))) | |
9c44003b MW |
691 | |
692 | ;;;-------------------------------------------------------------------------- | |
db43369d MW |
693 | ;;; Domain names. |
694 | ||
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. | |
699 | ||
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)) | |
704 | ||
705 | (export 'quotify-label) | |
706 | (defun quotify-label (string) | |
707 | "Quote an individual label STRING, using the RFC1035 rules. | |
708 | ||
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 | |
714 | codes." | |
715 | ||
716 | (if (every (lambda (ch) | |
717 | (and (<= 33 (char-code ch) 126) | |
718 | (not (member ch '(#\. #\@ #\" #\\ #\; #\( #\)))))) | |
719 | string) | |
720 | string | |
721 | (with-output-to-string (out) | |
722 | (write-char #\" out) | |
723 | (dotimes (i (length string)) | |
724 | (let ((ch (char string i))) | |
725 | (cond ((or (eql ch #\") (eql ch #\\)) | |
726 | (write-char #\\ out) | |
727 | (write-char ch out)) | |
728 | ((<= 32 (char-code ch) 126) | |
729 | (write-char ch out)) | |
730 | (t | |
731 | (format out "\\~3,'0D" (char-code ch)))))) | |
732 | (write-char #\" out)))) | |
733 | ||
734 | (defun unquotify-label (string &key (start 0) (end nil)) | |
735 | "Parse and unquote a label from the STRING. | |
736 | ||
737 | Returns the parsed label, and the position of the next label." | |
738 | ||
739 | (let* ((end (or end (length string))) | |
740 | (i start) | |
741 | (label (with-output-to-string (out) | |
742 | (labels | |
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. | |
748 | ||
749 | (let* ((e (+ i 3)) | |
750 | (code | |
751 | (and (<= e end) | |
752 | (do ((j i (1+ j)) | |
753 | (a 0 | |
754 | (let ((d (digit-char-p | |
755 | (char string j)))) | |
756 | (and a d (+ (* 10 a) d))))) | |
757 | ((>= j e) a))))) | |
758 | (unless (<= 0 code 255) | |
759 | (error "Escape code out of range.")) | |
760 | (setf i e) | |
761 | (and code (code-char code)))) | |
762 | ||
763 | (hack-backslash () | |
764 | ;; We've just seen a `\'. Read the next character | |
765 | ;; and write it to the output stream. | |
766 | ||
767 | (let ((ch (cond ((>= i end) nil) | |
768 | ((not (digit-char-p | |
769 | (char string i))) | |
770 | (prog1 (char string i) | |
771 | (incf i))) | |
772 | (t (numeric-escape-char))))) | |
773 | (unless ch | |
774 | (error "Invalid escape in label.")) | |
775 | (write-char ch out))) | |
776 | ||
777 | (munch (delim) | |
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. | |
782 | ||
783 | (loop | |
784 | (when (>= i end) (return nil)) | |
785 | (let ((ch (char string i))) | |
786 | (incf i) | |
787 | (cond ((char= ch #\\) | |
788 | (hack-backslash)) | |
789 | ((char= ch delim) | |
790 | (return ch)) | |
791 | (t | |
792 | (write-char ch out))))))) | |
793 | ||
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 `.'. | |
798 | (cond | |
799 | ((and (< i end) (char= (char string i) #\")) | |
800 | (incf i) | |
801 | (let ((delim (munch #\"))) | |
802 | (unless (and delim | |
803 | (or (= i end) | |
804 | (char= (prog1 (char string i) | |
805 | (incf i)) | |
806 | #\.))) | |
807 | (error "Invalid quoting in label.")))) | |
808 | (t | |
809 | (munch #\.))))))) | |
810 | ||
811 | ;; We're done. Phew! | |
812 | (when (string= label "") | |
813 | (error "Empty labels aren't allowed.")) | |
814 | (values label i))) | |
815 | ||
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. | |
819 | ||
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." | |
824 | ||
825 | (let ((end (or end (length string))) | |
826 | (i start)) | |
827 | (flet ((parse () | |
828 | ;; Parse a sequence of labels. | |
829 | ||
830 | (let ((labels nil)) | |
831 | (loop | |
832 | (unless (< i end) (return)) | |
833 | (multiple-value-bind (label j) | |
834 | (unquotify-label string :start i :end end) | |
835 | (push label labels) | |
836 | (setf i j))) | |
837 | (unless labels | |
838 | (error "Empty domain names have special notations.")) | |
839 | (make-domain-name :labels labels :absolutep absolutep)))) | |
840 | ||
841 | (cond ((= (1+ i) end) | |
842 | ;; A single-character name. Check for the magic things; | |
843 | ;; otherwise I guess it must just be short. | |
844 | ||
845 | (case (char string i) | |
846 | (#\@ (make-domain-name :labels nil :absolutep nil)) | |
847 | (#\. (make-domain-name :labels nil :absolutep t)) | |
848 | (t (parse)))) | |
849 | ||
850 | (t | |
851 | ;; Something more complicated. If the name ends with `.', but | |
852 | ;; not `\\.', then it must be absolute. | |
853 | (when (and (< i end) | |
854 | (char= (char string (- end 1)) #\.) | |
855 | (char/= (char string (- end 2)) #\\)) | |
856 | (decf end) | |
857 | (setf absolutep t)) | |
858 | (parse)))))) | |
859 | ||
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)))) | |
868 | (t | |
869 | (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~]" | |
870 | labels (domain-name-absolutep name)))))) | |
871 | ||
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) | |
876 | left | |
877 | (make-domain-name :labels (append (domain-name-labels right) | |
878 | (domain-name-labels left)) | |
879 | :absolutep (domain-name-absolutep right)))) | |
880 | ||
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. | |
884 | ||
885 | Split the names into labels, and then lexicographically compare the | |
886 | sequences of labels, right to left, using `natural-string<'. | |
887 | ||
888 | Returns two values: whether NAME-A strictly precedes NAME-B, and whether | |
889 | NAME-A strictly follows NAME-B. | |
890 | ||
891 | This doesn't give useful answers on relative domains unless you know what | |
892 | you're doing." | |
893 | ||
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)))) | |
898 | ((null labels-b) | |
899 | (return (values nil t))) | |
900 | (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)))))))))) | |
905 | ||
906 | (export 'root-domain) | |
907 | (defparameter root-domain (make-domain-name :labels nil :absolutep t) | |
908 | "The root domain, as a convenient object.") | |
909 | ||
910 | ;;;-------------------------------------------------------------------------- | |
32ebbe9b MW |
911 | ;;; Reverse lookups. |
912 | ||
913 | (export 'reverse-domain-component-width) | |
914 | (defgeneric reverse-domain-component-width (ipaddr) | |
915 | (:documentation "Return the component width for splitting IPADDR.")) | |
916 | ||
917 | (export 'reverse-domain-component-radix) | |
918 | (defgeneric reverse-domain-radix (ipaddr) | |
919 | (:documentation "Return the radix for representing IPADDR components.")) | |
920 | ||
921 | (export 'reverse-domain-component-suffix) | |
922 | (defgeneric reverse-domain-suffix (ipaddr) | |
923 | (:documentation "Return the reverse-lookup domain suffix for IPADDR.")) | |
924 | ||
925 | (export 'reverse-domain-fragment) | |
926 | (defgeneric reverse-domain-fragment (ipaddr start end &key partialp) | |
927 | (:documentation | |
928 | "Return a portion of an IPADDR's reverse-resolution domain name. | |
929 | ||
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.") | |
db43369d | 934 | |
32ebbe9b MW |
935 | (:method ((ipaddr ipaddr) start end &key (partialp t)) |
936 | ||
937 | (let ((addr (ipaddr-addr ipaddr)) | |
938 | (comp-width (reverse-domain-component-width ipaddr)) | |
939 | (radix (reverse-domain-radix ipaddr))) | |
940 | ||
db43369d MW |
941 | (do ((i (funcall (if partialp #'round-down #'round-up) |
942 | start comp-width) | |
943 | (+ i comp-width)) | |
944 | (limit (funcall (if partialp #'round-up #'round-down) | |
945 | end comp-width)) | |
946 | (comps nil (cons (format nil "~(~vR~)" radix | |
947 | (ldb (byte comp-width i) addr)) | |
948 | comps))) | |
949 | ((>= i limit) (make-domain-name :labels comps)))))) | |
32ebbe9b MW |
950 | |
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. | |
954 | ||
955 | If PREFIX-LEN is nil then it defaults to the length of the network's fixed | |
956 | prefix.") | |
db43369d | 957 | |
32ebbe9b MW |
958 | (:method ((ipn ipnet) &optional prefix-len) |
959 | (let* ((addr (ipnet-net ipn)) | |
960 | (mask (ipnet-mask ipn)) | |
961 | (width (ipaddr-width addr))) | |
db43369d MW |
962 | (domain-name-concat (reverse-domain-fragment |
963 | addr | |
964 | (if prefix-len | |
965 | (- width prefix-len) | |
966 | (ipnet-changeable-bits width mask)) | |
967 | width | |
968 | :partialp nil) | |
969 | (reverse-domain-suffix addr)))) | |
970 | ||
32ebbe9b MW |
971 | (:method ((addr ipaddr) &optional prefix-len) |
972 | (let* ((width (ipaddr-width addr))) | |
db43369d | 973 | (reverse-domain (make-ipnet addr width) |
32ebbe9b | 974 | (or prefix-len width))))) |
9c44003b MW |
975 | |
976 | ;;;-------------------------------------------------------------------------- | |
977 | ;;; Network names and specifiers. | |
978 | ||
e1528fd6 | 979 | (export 'net) |
32ebbe9b MW |
980 | (export 'net-name) |
981 | (export 'net-ipnets) | |
982 | (defclass net () | |
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))) | |
986 | ||
987 | (defmethod print-object ((net net) stream) | |
988 | (print-unreadable-object (net stream :type t) | |
989 | (format stream "~A~@[ = ~{~A~^, ~}~]" | |
990 | (net-name net) | |
991 | (mapcar #'ipnet-string (net-ipnets net))))) | |
9c44003b MW |
992 | |
993 | (defvar *networks* (make-hash-table :test #'equal) | |
994 | "The table of known networks.") | |
995 | ||
e1528fd6 | 996 | (export 'net-find) |
9c44003b MW |
997 | (defun net-find (name) |
998 | "Find a network by NAME." | |
999 | (gethash (string-downcase (stringify name)) *networks*)) | |
9c44003b MW |
1000 | (defun (setf net-find) (net name) |
1001 | "Make NAME map to NET." | |
1002 | (setf (gethash (string-downcase (stringify name)) *networks*) net)) | |
1003 | ||
32ebbe9b MW |
1004 | (export 'net-must-find) |
1005 | (defun net-must-find (name) | |
1006 | (or (net-find name) | |
1007 | (error "Unknown network ~A." name))) | |
1008 | ||
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))))) | |
1017 | ||
1018 | (defun process-net-form (name addr subnets) | |
f4e0c48f MW |
1019 | "Unpack a net-form. |
1020 | ||
32ebbe9b MW |
1021 | A net-form looks like (NAME ADDR [SUBNET ...]) where: |
1022 | ||
1023 | * NAME is the name for the network. | |
1024 | ||
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. | |
1033 | ||
1034 | * The SUBNETs are further net-forms, of the same form, whose addresses | |
1035 | are interpreted relative to the parent network's address. | |
1036 | ||
1037 | The return value is a list of items of the form (NAME . IPNET)." | |
1038 | ||
1039 | (labels ((process-subnets (subnets parent) | |
1040 | (let ((finger (ipnet-addr parent)) | |
1041 | (list nil)) | |
1042 | (dolist (subnet subnets list) | |
1043 | (destructuring-bind (name addr &rest subs) subnet | |
1044 | (let ((net (etypecase addr | |
1045 | (integer | |
1046 | (when (or (> (count-low-zero-bits addr) | |
1047 | (count-low-zero-bits finger)) | |
1048 | (not (zerop (logand addr | |
1049 | (1- addr))))) | |
1050 | (error "Bad subnet size for ~A." name)) | |
1051 | (make-ipnet | |
1052 | (ipaddr finger (ipnet-net parent)) | |
1053 | (ipaddr (- (ash 1 (ipnet-width parent)) | |
1054 | addr) | |
1055 | (ipnet-net parent)))) | |
1056 | ((or string symbol) | |
1057 | (string-subipnet parent addr))))) | |
1058 | ||
1059 | (unless (ipnet-subnetp parent net) | |
1060 | (error "Network `~A' (~A) falls outside parent ~A." | |
1061 | name (ipnet-string net) (ipnet-string parent))) | |
1062 | ||
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))))) | |
1069 | ||
1070 | (setf finger | |
1071 | (1+ (logior | |
1072 | (ipnet-addr net) | |
1073 | (logxor (ipnet-mask net) | |
1074 | (1- (ash 1 (ipnet-width net))))))) | |
1075 | ||
1076 | (when name | |
1077 | (push (cons name net) list)) | |
1078 | ||
1079 | (when subs | |
1080 | (setf list (nconc (process-subnets subs net) | |
1081 | list))))))))) | |
1082 | ||
1083 | (let* ((top (string-ipnet addr)) | |
1084 | (list (nreverse (process-subnets subnets top)))) | |
1085 | (when name (push (cons name top) list)) | |
1086 | list))) | |
9c44003b | 1087 | |
e1528fd6 | 1088 | (export 'net-create) |
9c44003b | 1089 | (defun net-create (name net) |
f4e0c48f MW |
1090 | "Construct a new network called NAME and add it to the map. |
1091 | ||
32ebbe9b MW |
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))) | |
1098 | (if net | |
1099 | (progn (setf (net-ipnet net (ipnet-family ipn)) ipn) net) | |
1100 | (setf (net-find name) | |
1101 | (make-instance 'net | |
1102 | :name (string-downcase (stringify name)) | |
1103 | :ipnets (list ipn)))))) | |
9c44003b | 1104 | |
e1528fd6 | 1105 | (export 'defnet) |
9c44003b | 1106 | (defmacro defnet (name net &rest subnets) |
f4e0c48f MW |
1107 | "Main network definition macro. |
1108 | ||
1109 | None of the arguments is evaluated." | |
9c44003b | 1110 | `(progn |
32ebbe9b MW |
1111 | ,@(mapcar (lambda (item) |
1112 | (let ((name (car item)) (ipn (cdr item))) | |
1113 | `(net-create ',name ',ipn))) | |
1114 | (process-net-form name net subnets)) | |
1115 | ',name)) | |
1116 | ||
8d531634 MW |
1117 | (defun filter-by-family (func form family) |
1118 | "Handle a family-switch form. | |
1119 | ||
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." | |
1123 | ||
1124 | (if (and (listp form) | |
1125 | (every (lambda (clause) | |
1126 | (and (listp clause) | |
1127 | (family-addrclass (car clause)))) | |
1128 | form)) | |
1129 | (mapcan (lambda (clause) | |
1130 | (let ((fam (car clause))) | |
1131 | (and (or (eq family t) | |
1132 | (eq family fam)) | |
1133 | (list (funcall func (cdr clause) fam))))) | |
1134 | form) | |
1135 | (list (funcall func form family)))) | |
1136 | ||
32ebbe9b MW |
1137 | (export 'net-parse-to-ipnets) |
1138 | (defun net-parse-to-ipnets (form &optional (family t)) | |
6a26c716 MW |
1139 | "Parse FORM into a list of ipnet objects. |
1140 | ||
1141 | The FORM can be any of the following. | |
1142 | ||
1143 | * NAME -- a named network, established using `net-create' or `defnet' | |
1144 | ||
1145 | * IPNET -- a network, in a form acceptable to `ipnet' | |
1146 | ||
1147 | * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY" | |
1148 | ||
32ebbe9b MW |
1149 | (flet ((hack (form family) |
1150 | (let* ((form (if (and (consp form) | |
1151 | (endp (cdr form))) | |
1152 | (car form) | |
1153 | form)) | |
1154 | (net (net-find form)) | |
1155 | (ipns (if net (net-ipnets net) | |
1156 | (list (ipnet form))))) | |
1157 | (if (eq family t) ipns | |
1158 | (remove family ipns | |
1159 | :key #'ipnet-family | |
1160 | :test-not #'eq))))) | |
8d531634 | 1161 | (let* ((ipns (apply #'append (filter-by-family #'hack form family))) |
32ebbe9b MW |
1162 | (merged (reduce (lambda (ipns ipn) |
1163 | (if (find (ipnet-family ipn) ipns | |
1164 | :key #'ipnet-family) | |
1165 | ipns | |
1166 | (cons ipn ipns))) | |
1167 | ipns | |
1168 | :initial-value nil))) | |
aee08db8 MW |
1169 | (or merged |
1170 | (error "No addresses match ~S~:[ in family ~S~;~*~]." | |
1171 | form (eq family t) family))))) | |
9c44003b | 1172 | |
e1528fd6 | 1173 | (export 'net-host) |
32ebbe9b MW |
1174 | (defun net-host (net-form host &optional (family t)) |
1175 | "Return the given HOST on the NET, as an anonymous `host' object. | |
f4e0c48f | 1176 | |
88867b1a MW |
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: | |
2f1d381d | 1179 | |
32ebbe9b MW |
1180 | :next next host, as by net-next-host |
1181 | :net network base address | |
1182 | :broadcast network broadcast address | |
1183 | ||
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)) | |
88867b1a MW |
1188 | (if (integerp host) |
1189 | (remove host ipns :key #'ipnet-hosts :test #'>=) | |
1190 | ipns)))) | |
32ebbe9b MW |
1191 | (let* ((net (and (typep net-form '(or string symbol)) |
1192 | (net-find net-form))) | |
1193 | (ipns (net-parse-to-ipnets net-form family)) | |
1194 | (addrs (case host | |
1195 | (:next | |
1196 | (if net | |
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))))) | |
1203 | (unless addrs | |
1204 | (error "No networks have that address.")) | |
1205 | (make-instance 'host :addrs addrs)))) | |
1206 | ||
1207 | ;;;-------------------------------------------------------------------------- | |
1208 | ;;; Host names and specifiers. | |
1209 | ||
1210 | (export 'host) | |
1211 | (export 'host-name) | |
1212 | (export 'host-addrs) | |
1213 | (defclass host () | |
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))) | |
1217 | ||
1218 | (defmethod print-object ((host host) stream) | |
1219 | (print-unreadable-object (host stream :type t) | |
1220 | (format stream "~:[<anonymous>~;~@*~A~]~@[ = ~{~A~^, ~}~]" | |
1221 | (host-name host) | |
1222 | (mapcar #'ipaddr-string (host-addrs host))))) | |
1223 | ||
1224 | (defvar *hosts* (make-hash-table :test #'equal) | |
1225 | "The table of known hostnames.") | |
1226 | ||
1227 | (export 'host-find) | |
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)) | |
1234 | ||
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)) | |
1239 | addrs-a) | |
1240 | addrs-b)) | |
1241 | ||
1242 | (export 'host-parse) | |
1243 | (defun host-parse (addr &optional (family t)) | |
1244 | "Convert the ADDR into a (possibly anonymous) `host' object. | |
1245 | ||
1246 | The ADDR can be one of a number of different things. | |
1247 | ||
1248 | HOST a host name defined using `defhost' | |
1249 | ||
1250 | (NET INDEX) a particular host in a network | |
1251 | ||
1252 | IPADDR an address form acceptable to `ipnet' | |
1253 | ||
1254 | ((FAMILY . ADDR) ...) the above, restricted to a particular address | |
1255 | FAMILY (i.e., one of the keywords `:ipv4', | |
1256 | etc.)" | |
1257 | ||
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 | |
1263 | :test-not #'eq)))) | |
1264 | (host-addresses (host family) | |
1265 | (if (eq family t) host | |
1266 | (filter-addresses (host-addrs host) family))) | |
1267 | (hack (addr family) | |
1268 | (let* ((form (listify addr)) | |
1269 | (indic (car form)) | |
1270 | (host (and (null (cdr form)) | |
1271 | (host-find indic)))) | |
1272 | (cond (host | |
1273 | (host-addresses host family)) | |
1274 | ((and (consp (cdr form)) | |
1275 | (endp (cddr form))) | |
1276 | (net-host (car form) (cadr form) family)) | |
1277 | (t | |
1278 | (filter-addresses (list (ipaddr indic)) family)))))) | |
8d531634 MW |
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 | |
1284 | (reverse list)) | |
1285 | :initial-value nil)) | |
1286 | (car list)))) | |
32ebbe9b | 1287 | (unless (host-addrs host) |
aee08db8 MW |
1288 | (error "No addresses match ~S~:[ in family ~S~;~*~]." |
1289 | addr (eq family t) family)) | |
32ebbe9b MW |
1290 | host))) |
1291 | ||
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))) | |
1297 | (if (not existing) | |
1298 | (setf (host-find name) | |
1299 | (make-instance 'host | |
1300 | :name (string-downcase (stringify name)) | |
1301 | :addrs (host-addrs new))) | |
1302 | (progn | |
1303 | (setf (host-addrs existing) | |
1304 | (merge-addresses (host-addrs existing) (host-addrs new))) | |
1305 | existing)))) | |
1306 | ||
1307 | (export 'defhost) | |
1308 | (defmacro defhost (name addr) | |
1309 | "Main host definition macro. Neither NAME nor ADDR is evaluated." | |
1310 | `(progn | |
1311 | (host-create ',name ',addr) | |
1312 | ',name)) | |
9c44003b MW |
1313 | |
1314 | ;;;----- That's all, folks -------------------------------------------------- |