1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ; Copyright (C) 2006 by Stelian Ionescu ;
6 ; This program is free software; you can redistribute it and/or modify ;
7 ; it under the terms of the GNU General Public License as published by ;
8 ; the Free Software Foundation; either version 2 of the License, or ;
9 ; (at your option) any later version. ;
11 ; This program is distributed in the hope that it will be useful, ;
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of ;
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;
14 ; GNU General Public License for more details. ;
16 ; You should have received a copy of the GNU General Public License ;
17 ; along with this program; if not, write to the ;
18 ; Free Software Foundation, Inc., ;
19 ; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ;
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 ;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2)))
23 (declaim (optimize (speed 0) (safety 2) (space 0) (debug 2)))
25 (in-package #:net.sockets
)
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;;; RESOLVER CONDITIONS ;;;
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 (define-constant +resolver-error-map
+
34 `((:eai-again . resolver-again-error
)
35 (:eai-fail . resolver-fail-error
)
36 (:eai-noname . resolver-no-name-error
)
37 (:eai-nodata . resolver-no-name-error
)
38 (:eai-addrfamily . resolver-no-name-error
)
39 (:eai-service . resolver-no-service-error
)))
41 (defun resolver-error-condition (id)
42 (cdr (assoc id
+resolver-error-map
+)))
44 (defmacro resolver-error-code
(id)
47 (define-condition resolver-error
(system-error)
48 ((data :initarg
:data
:reader resolver-error-data
))
49 (:documentation
"Signaled when an error occurs while trying to resolve an address."))
51 (defmacro define-resolver-error
(name code identifier format-string
&optional documentation
)
54 (define-condition ,name
(resolver-error)
55 ((code :initform
,code
)
56 (identifier :initform
,identifier
))
57 (:report
(lambda (condition stream
)
58 (format stream
,format-string
(resolver-error-data condition
))
59 (print-message-if-not-null condition stream
)))
60 (:documentation
,documentation
))))
62 (define-resolver-error resolver-again-error
(resolver-error-code :eai-again
) :resolver-again
63 "Temporary failure occurred while resolving: ~S"
64 "Condition signaled when a temporary failure occurred.")
66 (define-resolver-error resolver-fail-error
(resolver-error-code :eai-fail
) :resolver-fail
67 "Non recoverable error occurred while resolving: ~S"
68 "Condition signaled when a non-recoverable error occurred.")
70 (define-resolver-error resolver-no-name-error
(resolver-error-code :eai-noname
) :resolver-no-name
71 "Host or service not found: ~S"
72 "Condition signaled when a host or service was not found.")
74 (define-resolver-error resolver-no-service-error
(resolver-error-code :eai-service
) :resolver-no-service
75 "Service not found for specific socket type: ~S"
76 "Condition signaled when a service was not found for the socket type requested.")
78 (define-resolver-error resolver-unknown-error
0 :resolver-unknown
79 "Unknown error while resolving: ~S"
80 "Condition signaled when an unknown error is signaled while resolving an address.")
82 (defun resolver-error (identifier &key data message
)
83 (let ((condition-class
84 (resolver-error-condition identifier
)))
86 (error condition-class
87 :code
(resolver-error-code identifier
)
88 :identifier identifier
91 (error 'resolver-unknown-error
92 :code
(or (ignore-errors
93 (resolver-error-code identifier
))
95 :identifier identifier
99 (define-constant +max-ipv4-value
+ (1- (expt 2 32)))
110 (defun get-address-info (&key node service
111 (hint-flags 0) (hint-family 0)
112 (hint-type 0) (hint-protocol 0))
113 (with-alien ((hints et
:addrinfo
)
114 (res (* et
:addrinfo
)))
115 (et:memset
(addr hints
) 0 et
::size-of-addrinfo
)
116 (setf (slot hints
'et
:flags
) hint-flags
)
117 (setf (slot hints
'et
:family
) hint-family
)
118 (setf (slot hints
'et
:socktype
) hint-type
)
119 (setf (slot hints
'et
:protocol
) hint-protocol
)
120 (et:getaddrinfo node service
(addr hints
) (addr res
))
121 (sap-alien (alien-sap res
) (* et
:addrinfo
))))
123 (defun get-name-info (sockaddr &key
(want-host t
) want-service
(flags 0))
124 (assert (or want-host want-service
))
125 (let ((salen (etypecase sockaddr
126 ((alien (* et
:sockaddr-in
)) et
::size-of-sockaddr-in
)
127 ((alien (* et
:sockaddr-in6
)) et
::size-of-sockaddr-in6
)
128 ((alien (* et
:sockaddr-storage
)) et
::size-of-sockaddr-storage
))))
129 (with-alien ((host (array char
#.et
:ni-maxhost
))
130 (service (array char
#.et
:ni-maxserv
)))
131 (sb-sys:with-pinned-objects
(host service
)
132 (et:getnameinfo sockaddr salen
133 (alien-sap host
) (if want-host et
:ni-maxhost
0)
134 (alien-sap service
) (if want-service et
:ni-maxserv
0)
136 (values (and want-host
(cast host c-ascii-string
))
137 (and want-service
(cast service c-ascii-string
))))))
140 ((truename :initarg
:truename
:reader host-truename
)
141 (aliases :initarg
:aliases
:reader host-aliases
)
142 (addresses :initarg
:addresses
:reader host-addresses
)))
144 (defmethod initialize-instance :after
((host host
) &key
)
145 (with-slots (addresses) host
146 (unless (consp addresses
)
147 (setf addresses
(list addresses
)))))
149 (defgeneric random-address
(host))
150 (defmethod random-address ((host host
))
151 (with-slots (addresses) host
152 (nth (random (length addresses
))
155 (defun make-host (truename addresses
&optional aliases
)
159 :addresses addresses
))
161 (defmethod print-object ((host host
) stream
)
162 (print-unreadable-object (host stream
:type t
:identity nil
)
163 (with-slots (truename aliases addresses
) host
164 (format stream
"Cannonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~].~%Addresses: ~{~A~^, ~}"
165 truename aliases addresses
))))
172 (defun lookup-host-u8-vector-4 (host ipv6
)
173 (setf host
(coerce host
'(simple-array ub8
(4))))
178 (with-alien ((sin et
:sockaddr-in
))
179 (make-sockaddr-in (addr sin
) host
)
180 (return-from lookup-host-u8-vector-4
181 (make-host (get-name-info (addr sin
) :flags et
:ni-namereqd
)
182 (list (make-address (copy-seq host
)))))))
185 (with-alien ((sin6 et
:sockaddr-in6
))
186 (let ((ipv6addr (map-ipv4-vector-to-ipv6 host
)))
187 (make-sockaddr-in6 (addr sin6
) ipv6addr
)
188 (return-from lookup-host-u8-vector-4
189 (make-host (get-name-info (addr sin6
) :flags et
:ni-namereqd
)
190 (list (make-address ipv6addr
))))))))
191 (et:resolv-error
(err)
192 (resolver-error (et:system-error-identifier err
) :data host
))))
194 (defun lookup-host-u16-vector-8 (host ipv6
)
195 (setf host
(coerce host
'(simple-array ub16
(8))))
200 (resolver-error :eai-fail
202 :message
"Received IPv6 address but IPv4-only was requested."))
205 (with-alien ((sin6 et
::sockaddr-in6
))
206 (make-sockaddr-in6 (addr sin6
) host
)
207 (return-from lookup-host-u16-vector-8
208 (make-host (get-name-info (addr sin6
) :flags et
:ni-namereqd
)
209 (list (make-address (copy-seq host
))))))))
210 (et:resolv-error
(err)
211 (resolver-error (et:system-error-identifier err
) :data host
))))
213 (defun make-host-from-addrinfo (addrinfo)
214 (declare (type (alien (* et
:addrinfo
)) addrinfo
))
215 (let ((canonname (slot addrinfo
'et
:canonname
))
218 :for addrptr
:of-type
(alien (* et
:addrinfo
)) := addrinfo
219 :then
(slot addrptr
'et
:next
)
220 :while
(not (null-alien addrptr
))
221 :collect
(sockaddr-storage->netaddr
222 (slot addrptr
'et
:addr
)))))
223 (make-host canonname addrlist
)))
225 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
226 (declare (type host hostobj
))
227 (with-slots (addresses) hostobj
229 (mapcar #'(lambda (address)
230 (if (ipv4-address-p address
)
231 (make-address (map-ipv4-vector-to-ipv6 (name address
)))
236 (defgeneric lookup-host
(host &key
&allow-other-keys
))
238 (defmethod lookup-host :before
(host &key
(ipv6 *ipv6
*))
239 (check-type ipv6
(member nil
:ipv6 t
) "valid IPv6 configuration"))
241 (defmethod lookup-host ((host string
) &key
(ipv6 *ipv6
*))
242 (flet ((decide-family-and-flags ()
244 ((nil) (values et
:af-inet
0))
245 ;; the freebsd I use rejects AI_V4MAPPED and AI_ALL(weird thing)
246 ;; therefore I'll use AF_UNSPEC and do the mappings myself
248 #-freebsd et
:af-inet6
249 #+freebsd et
:af-unspec
252 (logior et
:ai-v4mapped
253 #+freebsd et
:ai-v4mapped-cfg
255 (:ipv6
(values et
:af-inet6
0)))))
259 ((setf parsed
(dotted-to-vector host
:error-p nil
))
260 (return-from lookup-host
261 (lookup-host-u8-vector-4 parsed ipv6
)))
263 ((setf parsed
(colon-separated-to-vector host
:error-p nil
))
264 (return-from lookup-host
265 (lookup-host-u16-vector-8 parsed ipv6
)))
269 (setf host
(coerce host
'(simple-array base-char
(*))))
271 (declare (ignore err
))
272 (error 'invalid-argument
:argument host
273 :message
(format nil
"The string ~S contains non-ASCII characters." host
))))
275 (multiple-value-bind (family flags
)
276 (decide-family-and-flags)
277 (setf flags
(logior flags et
:ai-canonname et
:ai-addrconfig
))
280 (get-address-info :node host
283 :hint-type et
:sock-stream
284 :hint-protocol et
:ipproto-ip
))
285 (hostobj (make-host-from-addrinfo addrinfo
)))
286 (when (string-not-equal (host-truename hostobj
)
288 (setf (slot-value hostobj
'aliases
) (list host
)))
289 (et:freeaddrinfo addrinfo
)
290 ;; mapping IPv4 addresses onto IPv6
293 (map-host-ipv4-addresses-to-ipv6 hostobj
))
294 (return-from lookup-host hostobj
))
295 (et:resolv-error
(err)
296 (resolver-error (et:system-error-identifier err
) :data host
)))))))))
298 (defmethod lookup-host ((host ipv4addr
) &key
(ipv6 *ipv6
*))
299 (lookup-host-u8-vector-4 (name host
) ipv6
))
301 (defmethod lookup-host ((host ipv6addr
) &key
(ipv6 *ipv6
*))
302 (lookup-host-u16-vector-8 (name host
) ipv6
))
304 (defmethod lookup-host (host &key
(ipv6 *ipv6
*))
306 ((simple-array * (4)) ; IPv4 address
307 (lookup-host-u8-vector-4 host ipv6
))
309 ((simple-array * (8)) ; IPv6 address
310 (lookup-host-u16-vector-8 host ipv6
))))
314 ;;;;;;;;;;;;;;;;;;;;;;;
315 ;;;;;;;;;;;;;;;;;;;;;;;
317 ;;; SERVICE LOOKUP ;;;
319 ;;;;;;;;;;;;;;;;;;;;;;;
320 ;;;;;;;;;;;;;;;;;;;;;;;
323 ((name :initarg
:name
:reader service-name
)
324 (port :initarg
:port
:reader service-port
)
325 (protocol :initarg
:protocol
:reader service-protocol
)))
327 (defun make-service (name port protocol
)
328 (make-instance 'service
333 (defmethod print-object ((service service
) stream
)
334 (print-unreadable-object (service stream
:type t
:identity nil
)
335 (with-slots (name port protocol
) service
336 (format stream
"Name: ~A. Port: ~A. Protocol: ~A" name port protocol
))))
338 (defun socket-type-from-int (alien-val)
340 (#.et
:sock-stream
:tcp
)
341 (#.et
:sock-dgram
:udp
)
342 (#.et
:sock-seqpacket
:sctp
)
346 (defun lookup-service-number (port-number protocol
&key name-required
)
347 (declare (type ub32 port-number
))
348 (with-alien ((sin et
:sockaddr-in
))
352 (et:memset
(addr sin
) 0 et
::size-of-sockaddr-in
)
353 (setf (slot sin
'et
:family
) et
:af-inet
)
354 (setf (slot sin
'et
:port
) (htons port-number
))
355 (get-name-info (addr sin
)
362 :want-host nil
:want-service t
)))))
363 (make-service service port-number protocol
))))
365 (defun lookup-service-name (port protocol
)
367 (the (alien (* et
:addrinfo
))
368 (get-address-info :service port
369 :hint-type
(case protocol
370 (:tcp et
:sock-stream
)
374 (ntohs (slot (cast (slot addrinfo
'et
:addr
)
378 (socket-type-from-int (slot addrinfo
'et
:socktype
))))
379 (sb-sys:with-pinned-objects
(addrinfo)
380 (et:freeaddrinfo addrinfo
))
381 (return-from lookup-service-name
382 (make-service port port-number true-protocol
))))
384 (defun lookup-service (port &key
(protocol :tcp
) (name-required nil
))
387 (t (setf protocol
:any
)))
389 (multiple-value-bind (port-type port-number
)
390 (string-or-parsed-number port
)
394 (lookup-service-number port-number protocol
395 :name-required name-required
))
397 (lookup-service-name port protocol
)))
398 (et:resolv-error
(err)
399 (resolver-error (et:system-error-identifier err
) :data port
)))))
403 ;;;;;;;;;;;;;;;;;;;;;;;;
404 ;;;;;;;;;;;;;;;;;;;;;;;;
406 ;;; PROTOCOL LOOKUP ;;;
408 ;;;;;;;;;;;;;;;;;;;;;;;;
409 ;;;;;;;;;;;;;;;;;;;;;;;;
411 (defclass protocol
()
412 ((name :initarg
:name
:reader protocol-name
)
413 (aliases :initarg
:aliases
:reader protocol-aliases
)
414 (protonum :initarg
:protonum
:reader protocol-number
)))
416 (defun make-protocol (name protonum
&optional aliases
)
417 (make-instance 'protocol
422 (defmethod print-object ((protocol protocol
) stream
)
423 (print-unreadable-object (protocol stream
:type t
:identity nil
)
424 (with-slots (name aliases protonum
) protocol
425 (format stream
"Name: ~S. Protocol number: ~A. Aliases: ~{~S~^, ~}"
426 name protonum aliases
))))
428 (define-condition unknown-protocol
(system-error)
429 ((name :initarg
:name
:initform nil
:reader protocol-name
))
430 (:report
(lambda (condition stream
)
431 (format stream
"Unknown protocol: ~S"
432 (protocol-name condition
))))
433 (:documentation
"Condition raised when a network protocol is not found."))
435 (defun make-protocol-from-protoent (protoent)
436 (declare (type (alien (* et
:protoent
)) protoent
))
437 (let* ((name (slot protoent
'et
:name
))
438 (number (slot protoent
'et
:proto
))
439 (aliasptr (slot protoent
'et
:aliases
))
442 :for alias
:= (deref aliasptr i
)
443 :while alias
:collect alias
)))
444 (make-protocol name number aliases
)))
446 (defun get-protocol-by-number (protonum)
447 (make-protocol-from-protoent (et:getprotobynumber protonum
)))
449 (defun get-protocol-by-name (protoname)
450 (make-protocol-from-protoent (sb-sys:with-pinned-objects
(protoname)
451 (et:getprotobyname protoname
))))
453 (defun lookup-protocol (proto)
454 (multiple-value-bind (proto-type proto-val
)
455 (string-or-parsed-number proto
)
459 (get-protocol-by-number proto-val
))
462 (get-protocol-by-name proto-val
)))
464 (declare (ignore err
))
465 (error 'unknown-protocol
:name proto
)))))