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