1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- IP address classes and main methods.
6 (in-package :iolib
/sockets
)
12 (:documentation
"Base class for all socket address classes."))
14 (defclass named-address
(address)
15 ((name :initarg
:name
:reader address-name
:type vector
))
16 (:documentation
"Base class for socket address with a name."))
18 (defclass inet-address
(named-address) ()
19 (:documentation
"Base class for IPv4 and IPv6 addresses."))
21 (defclass ipv4-address
(inet-address) ()
22 (:documentation
"IPv4 address. Its low-level representation
23 can be accessed as vector of type IPV4-ARRAY through the
24 ADDRESS-NAME reader."))
26 (defclass ipv6-address
(inet-address) ()
27 (:documentation
"IPv6 address. Its low-level representation
28 can be accessed as vector of type IPV6-ARRAY through the
29 ADDRESS-NAME reader."))
31 (defclass local-address
(named-address)
32 ((abstract :initform nil
:initarg
:abstract
33 :reader abstract-address-p
:type boolean
))
34 (:documentation
"UNIX socket address."))
35 (unset-method-docstring #'abstract-address-p
() '(local-address))
36 (set-function-docstring 'abstract-address-p
"Return T if ADDRESS is a LOCAL-ADDRESS that lives in the abstract namespace.")
39 (defclass netlink-address
(address)
40 ((multicast-groups :initform
0 :initarg
:multicast-groups
41 :reader netlink-address-multicast-groups
)))
43 (defmethod initialize-instance :after
((address local-address
) &key
)
44 (with-slots (name) address
47 (pathname (setf name
(namestring name
))))))
49 (defmethod make-load-form ((address inet-address
) &optional env
)
50 (declare (ignore env
))
51 `(make-instance ,(class-of address
)
52 :name
,(address-name address
)))
54 (defmethod make-load-form ((address local-address
) &optional env
)
55 (declare (ignore env
))
56 `(make-instance ,(class-of address
)
57 :name
,(address-name address
)
58 :abstract
,(abstract-address-p address
)))
60 ;;;; Conversion functions for SOCKADDR_* structs
62 (defun sockaddr-in->sockaddr
(sin)
63 (with-foreign-slots ((addr port
) sin sockaddr-in
)
64 (values (make-instance 'ipv4-address
65 :name
(integer-to-vector (ntohl addr
)))
68 (defun sockaddr-in6->sockaddr
(sin6)
69 (with-foreign-slots ((addr port
) sin6 sockaddr-in6
)
70 (values (make-instance 'ipv6-address
71 :name
(in6-addr-to-ipv6-array addr
))
74 (defun parse-un-path (path)
75 (foreign-string-to-lisp path
:max-chars
(1- unix-path-max
)))
77 (defun sockaddr-un->sockaddr
(sun)
78 (with-foreign-slots ((path) sun sockaddr-un
)
79 (multiple-value-bind (name abstract
)
80 (if (zerop (mem-aref path
:uint8
0))
81 (values (parse-un-path (inc-pointer path
1)) t
)
82 (values (parse-un-path path
) nil
))
83 (make-instance 'local-address
:name name
:abstract abstract
))))
86 (defun sockaddr-nl->sockaddr
(snl)
87 (with-foreign-slots ((groups port
) snl sockaddr-nl
)
88 (values (make-instance 'netlink-address
:multicast-groups groups
)
91 (defun sockaddr-storage->sockaddr
(ss)
92 (with-foreign-slots ((family) ss sockaddr-storage
)
93 (switch (family :test
#'=)
94 (af-inet (sockaddr-in->sockaddr ss
))
95 (af-inet6 (sockaddr-in6->sockaddr ss
))
96 (af-local (sockaddr-un->sockaddr ss
))
98 (af-netlink (sockaddr-nl->sockaddr ss
)))))
100 (defun sockaddr->sockaddr-storage
(ss sockaddr
&optional
(port 0))
102 (ipv4-address (make-sockaddr-in ss
(address-name sockaddr
) port
))
103 (ipv6-address (make-sockaddr-in6 ss
(address-name sockaddr
) port
))
104 (local-address (make-sockaddr-un ss
(address-name sockaddr
)
105 (abstract-address-p sockaddr
)))
107 (netlink-address (make-sockaddr-nl ss
(netlink-address-multicast-groups sockaddr
)
110 (defun sockaddr-size (ss)
111 (with-foreign-slots ((family) ss sockaddr-storage
)
112 (switch (family :test
#'=)
113 (af-inet (isys:sizeof
'sockaddr-in
))
114 (af-inet6 (isys:sizeof
'sockaddr-in6
))
115 (af-local (isys:sizeof
'sockaddr-un
))
117 (af-netlink (isys:sizeof
'sockaddr-nl
)))))
119 ;;;; Conversion functions
121 (defun integer-to-dotted (integer)
122 "Convert an (UNSIGNED-BYTE 32) IPv4 address to a dotted string."
123 (check-type integer ub32
"an '(unsigned-byte 32)")
124 (let ((*print-pretty
* nil
) (*print-base
* 10))
125 (format nil
"~A.~A.~A.~A"
126 (ldb (byte 8 24) integer
)
127 (ldb (byte 8 16) integer
)
128 (ldb (byte 8 8) integer
)
129 (ldb (byte 8 0) integer
))))
131 (defun dotted-to-vector (address)
132 "Convert a dotted IPv4 address to a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) 4)."
133 (check-type address string
"a string")
134 (let ((addr (make-array 4 :element-type
'ub8
:initial-element
0))
135 (split (split-sequence #\. address
:count
5)))
136 (flet ((set-array-value (index str
)
137 (setf (aref addr index
)
138 (ensure-number str
:type
'ub8
))))
139 (let ((len (length split
)))
141 (error 'parse-error
))
142 (set-array-value 3 (nth (1- len
) split
))
143 (loop :for n
:in split
144 :for index
:below
(1- len
)
145 :do
(set-array-value index n
))))
148 (defun dotted-to-integer (address)
149 "Convert a dotted IPv4 address to an (UNSIGNED-BYTE 32)."
150 (vector-to-integer (dotted-to-vector address
)))
152 (defun vector-to-dotted (vector)
153 "Convert an 4-element vector to a dotted string."
154 (coercef vector
'ipv4-array
)
155 (let ((*print-pretty
* nil
) (*print-base
* 10))
156 (with-output-to-string (s)
157 (princ (aref vector
0) s
) (princ #\. s
)
158 (princ (aref vector
1) s
) (princ #\. s
)
159 (princ (aref vector
2) s
) (princ #\. s
)
160 (princ (aref vector
3) s
))))
162 ;;; TODO: add tests against inet_pton(). Optimize if necessary.
163 ;;; <http://java.sun.com/javase/6/docs/api/java/net/Inet6Address.html#format>
164 (defun colon-separated-to-vector (string)
165 "Convert a colon-separated IPv6 address to a (SIMPLE-ARRAY (UNSIGNED-BYTE 16) 8)."
166 (check-type string string
"a string")
167 (when (< (length string
) 2)
168 (error 'parse-error
))
169 (flet ((handle-trailing-and-leading-colons (string)
171 (end (length string
))
173 (trailing-colon-p nil
)
174 (tokens-from-leading-or-trailing-zeros 0))
175 (when (char= #\
: (char string
0))
177 (unless (char= #\
: (char string
1))
179 (setq tokens-from-leading-or-trailing-zeros
1)))
180 (when (char= #\
: (char string
(- end
1)))
181 (setq trailing-colon-p t
)
182 (unless (char= #\
: (char string
(- end
2)))
183 (incf tokens-from-leading-or-trailing-zeros
))
185 (values start end start-i trailing-colon-p
186 tokens-from-leading-or-trailing-zeros
)))
187 ;; we need to use this instead of dotted-to-vector because
188 ;; abbreviated IPv4 addresses are invalid in this context.
189 (ipv4-string-to-ub16-list (string)
190 (let ((tokens (split-sequence #\. string
)))
191 (when (= (length tokens
) 4)
192 (let ((ipv4 (map 'vector
194 (let ((x (ignore-errors
195 (parse-integer string
))))
196 (if (or (null x
) (not (<= 0 x
#xff
)))
200 (list (dpb (aref ipv4
0) (byte 8 8) (aref ipv4
1))
201 (dpb (aref ipv4
2) (byte 8 8) (aref ipv4
3)))))))
202 (parse-hex-ub16 (string)
203 (ensure-number string
:type
'ub16
:radix
16)))
204 (multiple-value-bind (start end start-i trailing-colon-p extra-tokens
)
205 (handle-trailing-and-leading-colons string
)
206 (let* ((vector (make-array 8 :element-type
'ub16
:initial-element
0))
207 (tokens (split-sequence #\
: string
:start start
:end end
))
208 (empty-tokens (count-if #'emptyp tokens
))
209 (token-count (+ (length tokens
) extra-tokens
)))
210 (unless trailing-colon-p
211 (let ((ipv4 (ipv4-string-to-ub16-list (lastcar tokens
))))
214 (setq tokens
(nconc (butlast tokens
) ipv4
)))))
215 (when (or (> token-count
8) (> empty-tokens
1)
216 (and (zerop empty-tokens
) (/= token-count
8)))
217 (error 'parse-error
))
218 (loop for i from start-i and token in tokens do
220 ((integerp token
) (setf (aref vector i
) token
))
221 ((emptyp token
) (incf i
(- 8 token-count
)))
222 (t (setf (aref vector i
) (parse-hex-ub16 token
)))))
225 (defun ipv4-on-ipv6-mapped-vector-p (vector)
226 (and (dotimes (i 5 t
)
227 (when (plusp (aref vector i
))
229 (= (aref vector
5) #xffff
)))
231 (defun princ-ipv4-on-ipv6-mapped-address (vector s
)
233 (let ((*print-base
* 10) (*print-pretty
* nil
))
234 (princ (ldb (byte 8 8) (aref vector
6)) s
) (princ #\. s
)
235 (princ (ldb (byte 8 0) (aref vector
6)) s
) (princ #\. s
)
236 (princ (ldb (byte 8 8) (aref vector
7)) s
) (princ #\. s
)
237 (princ (ldb (byte 8 0) (aref vector
7)) s
)))
239 (defun vector-to-colon-separated (vector &optional
(case :downcase
))
240 "Convert an (SIMPLE-ARRAY (UNSIGNED-BYTE 16) 8) to a colon-separated IPv6
241 address. CASE may be :DOWNCASE or :UPCASE."
242 (coercef vector
'ipv6-array
)
243 (check-type case
(member :upcase
:downcase
) "either :UPCASE or :DOWNCASE")
244 (let ((s (make-string-output-stream)))
245 (flet ((find-zeros ()
246 (let ((start (position 0 vector
:start
1 :end
7)))
249 (position-if #'plusp vector
:start start
:end
7)))))
250 (princ-subvec (start end
)
251 (loop :for i
:from start
:below end
252 :do
(princ (aref vector i
) s
) (princ #\
: s
))))
254 ((ipv4-on-ipv6-mapped-vector-p vector
)
255 (princ-ipv4-on-ipv6-mapped-address vector s
))
257 (let ((*print-base
* 16) (*print-pretty
* nil
))
258 (when (plusp (aref vector
0)) (princ (aref vector
0) s
))
260 (multiple-value-bind (start end
) (find-zeros)
261 (cond (start (princ-subvec 1 start
)
263 (when end
(princ-subvec end
7)))
264 (t (princ-subvec 1 7))))
265 (when (plusp (aref vector
7)) (princ (aref vector
7) s
))))))
266 (let ((str (get-output-stream-string s
)))
268 (:downcase
(nstring-downcase str
))
269 (:upcase
(nstring-upcase str
))))))
271 (defmacro ignore-parse-errors
(&body body
)
272 ;; return first value only
273 `(values (ignore-some-conditions (parse-error) ,@body
)))
275 (defun string-address-to-vector (address)
276 "Convert a string address (dotted or colon-separated) to a vector address.
277 If the string is not a valid address, return NIL."
278 (or (ignore-parse-errors (dotted-to-vector address
))
279 (ignore-parse-errors (colon-separated-to-vector address
))))
281 (defun address-to-vector (address)
282 "Convert any representation of an internet address to a vector.
283 Allowed inputs are: unsigned 32-bit integers, strings, vectors
284 and INET-ADDRESS objects. If the address is valid, two values
285 are returned: the vector and the address type (:IPV4 or IPV6),
286 otherwise NIL is returned."
287 (let (vector addr-type
)
289 (number (and (ignore-parse-errors
290 (setf vector
(integer-to-vector address
)))
291 (setf addr-type
:ipv4
)))
293 ((ignore-parse-errors (setf vector
(dotted-to-vector address
)))
294 (setf addr-type
:ipv4
))
295 ((ignore-parse-errors
296 (setf vector
(colon-separated-to-vector address
)))
297 (setf addr-type
:ipv6
))))
298 ((vector * 4) (and (ignore-parse-errors
299 (setf vector
(coerce address
'ipv4-array
)))
300 (setf addr-type
:ipv4
)))
301 ((vector * 8) (and (ignore-parse-errors
302 (setf vector
(coerce address
'ipv6-array
)))
303 (setf addr-type
:ipv6
)))
304 (ipv4-address (setf vector
(copy-seq (address-name address
))
306 (ipv6-address (setf vector
(copy-seq (address-name address
))
309 (values vector addr-type
))))
311 (defun ensure-address (address &key
(family :internet
) abstract
(errorp t
))
312 "If FAMILY is :LOCAL, a LOCAL-ADDRESS is instantiated with
313 ADDRESS as its NAME slot. If FAMILY is :INTERNET, an appropriate
314 subtype of INET-ADDRESS is instantiated after guessing the
315 address type through ADDRESS-TO-VECTOR. If the address is invalid
316 and ERRORP is not NIL, then a CL:PARSE-ERROR is signalled,
317 otherwise NIL is returned.
319 When ADDRESS is already an instance of the ADDRESS class, a check
320 is made to see if it matches the FAMILY argument and it is
321 returned unmodified."
327 (check-type address inet-address
"an INET address"))
328 ((not (typep address
'inet-address
))
331 (t (let ((vector (address-to-vector address
)))
333 (vector (make-address vector
))
334 (errorp (error 'parse-error
)))))))
337 (string (make-instance 'local-address
:name address
:abstract abstract
))
340 (check-type address local-address
"a local address"))
341 ((not (typep address
'local-address
))
347 (defgeneric address-to-string
(address)
348 (:documentation
"Returns a textual presentation of ADDRESS."))
350 (defmethod address-to-string ((address ipv4-address
))
351 (vector-to-dotted (address-name address
)))
353 (defmethod address-to-string ((address ipv6-address
))
354 (vector-to-colon-separated (address-name address
)))
356 (defmethod address-to-string ((address local-address
))
357 (format nil
"~:[~;@~]~S" (abstract-address-p address
)
358 (address-name address
)))
361 (defmethod address-to-string ((address netlink-address
))
362 (format nil
"~A" (netlink-address-multicast-groups address
)))
364 (defmethod print-object ((address inet-address
) stream
)
365 (let ((namestring (address-to-string address
)))
366 (if (or *print-readably
* *print-escape
*)
367 (format stream
"#/~S/~A" 'ip namestring
)
368 (write-string namestring stream
))))
370 (defmethod print-object ((address local-address
) stream
)
371 (print-unreadable-object (address stream
:type nil
:identity nil
)
372 (format stream
"Unix socket address: ~A"
373 (address-to-string address
))))
376 (defmethod print-object ((address netlink-address
) stream
)
377 (print-unreadable-object (address stream
:type nil
:identity nil
)
378 (format stream
"Netlink socket address: ~A"
379 (address-to-string address
))))
383 (define-literal-reader ip
(stream)
384 (loop :with sstr
:= (make-string-output-stream)
385 :for char
:= (read-char stream nil nil
)
387 :do
(cond ((or (digit-char-p char
16)
388 (member char
'(#\.
#\
:) :test
#'char
=))
389 (write-char char sstr
))
391 (unread-char char stream
)
393 :finally
(return (or (ensure-address (get-output-stream-string sstr
)
395 (error 'reader-error
:stream stream
)))))
397 ;;;; Equality Methods
399 (defun vector-equal (v1 v2
)
400 (and (= (length v1
) (length v2
))
401 (every #'eql v1 v2
)))
403 (defgeneric address
= (addr1 addr2
)
404 (:documentation
"Returns T if both arguments are the same socket address."))
406 (defmethod address= ((addr1 inet-address
) (addr2 inet-address
))
407 (vector-equal (address-name addr1
) (address-name addr2
)))
409 (defmethod address= ((addr1 local-address
) (addr2 local-address
))
410 (equal (address-name addr1
) (address-name addr2
)))
412 (defun address-equal-p (addr1 addr2
&optional
(family :internet
))
413 "Returns T if both arguments are designators for the same socket address."
414 (address= (ensure-address addr1
:family family
)
415 (ensure-address addr2
:family family
)))
419 (defgeneric copy-address
(address)
421 "Returns a copy of ADDRESS which is ADDRESS= to the original."))
423 (defmethod copy-address ((addr ipv4-address
))
424 (make-instance 'ipv4-address
:name
(copy-seq (address-name addr
))))
426 (defmethod copy-address ((addr ipv6-address
))
427 (make-instance 'ipv6-address
:name
(copy-seq (address-name addr
))))
429 (defmethod copy-address ((addr local-address
))
430 (make-instance 'local-address
431 :name
(copy-seq (address-name addr
))
432 :abstract
(abstract-address-p addr
)))
434 (defun map-ipv4-address-to-ipv6 (address)
435 "Returns an IPv6 address by mapping ADDRESS onto it."
436 (make-instance 'ipv6-address
437 :name
(map-ipv4-vector-to-ipv6 (address-name address
))))
439 (defun map-ipv6-address-to-ipv4 (address)
440 "Extracts the IPv4 part of an IPv6-mapped IPv4 address.
441 Signals an error if ADDRESS is not an IPv6-mapped IPv4 address."
442 (assert (ipv6-ipv4-mapped-p address
) (address)
443 "Not an IPv6-mapped IPv4 address: ~A" address
)
444 (make-instance 'ipv4-address
445 :name
(map-ipv6-vector-to-ipv4 (address-name address
))))
449 (defun make-address (name)
450 "Constructs an ADDRESS object. NAME should be of type
451 IPV4-ARRAY, IPV6-ARRAY or STRING in which case an instance of
452 IPV4-ADDRESS, IPV6-ADDRESS or LOCAL-ADDRESS, respectively, will
453 be created. Otherwise, a TYPE-ERROR is signalled. See also
456 ((ignore-errors (coercef name
'ipv4-array
))
457 (make-instance 'ipv4-address
:name name
))
458 ((ignore-errors (coercef name
'ipv6-array
))
459 (make-instance 'ipv6-address
:name name
))
460 ((stringp name
) (make-instance 'local-address
:name name
))
461 (t (error 'type-error
:datum name
462 :expected-type
'(or string ipv4-array ipv6-array
)))))