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 (null-pointer)) (service (null-pointer))
111 (hint-flags 0) (hint-family 0)
112 (hint-type 0) (hint-protocol 0))
113 (with-foreign-objects ((hints 'et
:addrinfo
)
115 (et:memset hints
0 (foreign-type-size 'et
:addrinfo
))
116 (with-foreign-slots ((et:flags et
:family et
:socktype et
:protocol
)
118 (setf et
:flags hint-flags
)
119 (setf et
:family hint-family
)
120 (setf et
:socktype hint-type
)
121 (setf et
:protocol hint-protocol
)
122 (et:getaddrinfo node service hints res
)
123 (make-pointer (pointer-address (mem-ref res
:pointer
))))))
125 (defun get-name-info (sockaddr &key
(want-host t
) want-service
(flags 0))
126 (assert (or want-host want-service
))
127 (let ((salen #.
(foreign-type-size 'et
:sockaddr-storage
)))
128 (with-foreign-objects ((host :char et
:ni-maxhost
)
129 (service :char et
:ni-maxserv
))
130 (et:getnameinfo sockaddr salen
131 host
(if want-host et
:ni-maxhost
0)
132 service
(if want-service et
:ni-maxserv
0)
134 (values (and want-host
(foreign-string-to-lisp host et
:ni-maxhost
))
135 (and want-service
(foreign-string-to-lisp service et
:ni-maxserv
))))))
138 ((truename :initarg
:truename
:reader host-truename
)
139 (aliases :initarg
:aliases
:reader host-aliases
)
140 (addresses :initarg
:addresses
:reader host-addresses
)))
142 (defmethod initialize-instance :after
((host host
) &key
)
143 (with-slots (addresses) host
144 (unless (consp addresses
)
145 (setf addresses
(list addresses
)))))
147 (defgeneric random-address
(host))
148 (defmethod random-address ((host host
))
149 (with-slots (addresses) host
150 (nth (random (length addresses
))
153 (defun make-host (truename addresses
&optional aliases
)
157 :addresses addresses
))
159 (defmethod print-object ((host host
) stream
)
160 (print-unreadable-object (host stream
:type t
:identity nil
)
161 (with-slots (truename aliases addresses
) host
162 (format stream
"Cannonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~].~%Addresses: ~{~A~^, ~}"
163 truename aliases addresses
))))
170 (defun lookup-host-u8-vector-4 (host ipv6
)
171 (setf host
(coerce host
'(simple-array ub8
(4))))
176 (with-foreign-object (sin 'et
:sockaddr-storage
)
177 (make-sockaddr-in sin host
)
178 (return-from lookup-host-u8-vector-4
179 (make-host (get-name-info sin
:flags et
:ni-namereqd
)
180 (list (make-address (copy-seq host
)))))))
183 (with-foreign-object (sin6 'et
:sockaddr-storage
)
184 (let ((ipv6addr (map-ipv4-vector-to-ipv6 host
)))
185 (make-sockaddr-in6 sin6 ipv6addr
)
186 (return-from lookup-host-u8-vector-4
187 (make-host (get-name-info sin6
:flags et
:ni-namereqd
)
188 (list (make-address ipv6addr
)))))))
190 (resolver-error :eai-fail
192 :message
"Received IPv4 address but IPv6-only was requested.")))
193 (et:resolv-error
(err)
194 (resolver-error (et:system-error-identifier err
) :data host
))))
196 (defun lookup-host-u16-vector-8 (host ipv6
)
197 (setf host
(coerce host
'(simple-array ub16
(8))))
202 (resolver-error :eai-fail
204 :message
"Received IPv6 address but IPv4-only was requested."))
207 (with-foreign-object (sin6 'et
:sockaddr-storage
)
208 (make-sockaddr-in6 sin6 host
)
209 (return-from lookup-host-u16-vector-8
210 (make-host (get-name-info sin6
:flags et
:ni-namereqd
)
211 (list (make-address (copy-seq host
))))))))
212 (et:resolv-error
(err)
213 (resolver-error (et:system-error-identifier err
) :data host
))))
215 (defun make-host-from-addrinfo (addrinfo)
216 (let ((canonname (foreign-slot-value addrinfo
'et
:addrinfo
'et
:canonname
))
219 :for addrptr
:= addrinfo
220 :then
(foreign-slot-value addrptr
'et
:addrinfo
'et
:next
)
221 :while
(not (null-pointer-p addrptr
))
222 :collect
(sockaddr-storage->sockaddr
223 (foreign-slot-value addrptr
'et
:addrinfo
'et
:addr
)))))
224 (make-host (if (null-pointer-p canonname
)
226 (foreign-string-to-lisp canonname
))
229 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
230 (declare (type host hostobj
))
231 (with-slots (addresses) hostobj
233 (mapcar #'(lambda (address)
234 (if (ipv4-address-p address
)
235 (make-address (map-ipv4-vector-to-ipv6 (name address
)))
240 (defgeneric lookup-host
(host &key
&allow-other-keys
))
242 (defmethod lookup-host :before
(host &key
(ipv6 *ipv6
*))
243 (check-type ipv6
(member nil
:ipv6 t
) "valid IPv6 configuration"))
245 (defmethod lookup-host ((host string
) &key
(ipv6 *ipv6
*))
246 (flet ((decide-family-and-flags ()
248 ((nil) (values et
:af-inet
0))
249 ;; the freebsd I use rejects AI_V4MAPPED and AI_ALL(weird thing)
250 ;; therefore I'll use AF_UNSPEC and do the mappings myself
252 #-freebsd et
:af-inet6
253 #+freebsd et
:af-unspec
256 (logior et
:ai-v4mapped
257 #+freebsd et
:ai-v4mapped-cfg
259 (:ipv6
(values et
:af-inet6
0)))))
263 ((setf parsed
(dotted-to-vector host
:errorp nil
))
264 (return-from lookup-host
265 (lookup-host-u8-vector-4 parsed ipv6
)))
267 ((setf parsed
(colon-separated-to-vector host
:errorp nil
))
268 (return-from lookup-host
269 (lookup-host-u16-vector-8 parsed ipv6
)))
271 ;; FIXME: check for ASCII-only strings or implement IDN
273 (multiple-value-bind (family flags
)
274 (decide-family-and-flags)
275 (setf flags
(logior flags et
:ai-canonname et
:ai-addrconfig
))
278 (get-address-info :node host
281 :hint-type et
:sock-stream
282 :hint-protocol et
:ipproto-ip
))
283 (hostobj (make-host-from-addrinfo addrinfo
)))
284 (when (string-not-equal (host-truename hostobj
)
286 (setf (slot-value hostobj
'aliases
) (list host
)))
287 (et:freeaddrinfo addrinfo
)
288 ;; mapping IPv4 addresses onto IPv6
291 (map-host-ipv4-addresses-to-ipv6 hostobj
))
292 (return-from lookup-host hostobj
))
293 (et:resolv-error
(err)
294 (resolver-error (et:system-error-identifier err
) :data host
)))))))))
296 (defmethod lookup-host ((host ipv4addr
) &key
(ipv6 *ipv6
*))
297 (lookup-host-u8-vector-4 (name host
) ipv6
))
299 (defmethod lookup-host ((host ipv6addr
) &key
(ipv6 *ipv6
*))
300 (lookup-host-u16-vector-8 (name host
) ipv6
))
302 (defmethod lookup-host (host &key
(ipv6 *ipv6
*))
304 ((simple-array * (4)) ; IPv4 address
305 (lookup-host-u8-vector-4 host ipv6
))
307 ((simple-array * (8)) ; IPv6 address
308 (lookup-host-u16-vector-8 host ipv6
))))
312 ;;;;;;;;;;;;;;;;;;;;;;;
313 ;;;;;;;;;;;;;;;;;;;;;;;
315 ;;; SERVICE LOOKUP ;;;
317 ;;;;;;;;;;;;;;;;;;;;;;;
318 ;;;;;;;;;;;;;;;;;;;;;;;
321 ((name :initarg
:name
:reader service-name
)
322 (port :initarg
:port
:reader service-port
)
323 (protocol :initarg
:protocol
:reader service-protocol
)))
325 (defun make-service (name port protocol
)
326 (make-instance 'service
331 (defmethod print-object ((service service
) stream
)
332 (print-unreadable-object (service stream
:type t
:identity nil
)
333 (with-slots (name port protocol
) service
334 (format stream
"Name: ~A. Port: ~A. Protocol: ~A" name port protocol
))))
336 (defun socket-type-from-int (alien-val)
338 (#.et
:sock-stream
:tcp
)
339 (#.et
:sock-dgram
:udp
)
340 (#.et
:sock-seqpacket
:sctp
)
344 (defun lookup-service-number (port-number protocol
&key name-required
)
345 (declare (type ub32 port-number
))
346 (with-foreign-object (sin 'et
:sockaddr-in
)
350 (et:memset sin
0 #.
(foreign-type-size 'et
:sockaddr-in
))
351 (setf (foreign-slot-value sin
'et
:sockaddr-in
'et
:family
)
353 (setf (foreign-slot-value sin
'et
:sockaddr-in
'et
:port
)
362 :want-host nil
:want-service t
)))))
363 (make-service service port-number protocol
))))
365 (defun lookup-service-name (port protocol
)
367 (get-address-info :service port
368 :hint-type
(case protocol
369 (:tcp et
:sock-stream
)
373 (ntohs (foreign-slot-value (foreign-slot-value addrinfo
'et
:addrinfo
'et
:addr
)
374 'et
:sockaddr-in
'et
:port
)))
376 (socket-type-from-int (foreign-slot-value addrinfo
'et
:addrinfo
'et
:socktype
))))
377 (et:freeaddrinfo addrinfo
)
378 (return-from lookup-service-name
379 (make-service port port-number true-protocol
))))
381 (defun lookup-service (port &key
(protocol :tcp
) (name-required nil
))
384 (t (setf protocol
:any
)))
386 (let ((parsed-number (parse-number-or-nil port
:ub16
)))
389 (lookup-service-number parsed-number protocol
390 :name-required name-required
)
391 (lookup-service-name port protocol
))
392 (et:resolv-error
(err)
393 (resolver-error (et:system-error-identifier err
) :data port
)))))
397 ;;;;;;;;;;;;;;;;;;;;;;;;
398 ;;;;;;;;;;;;;;;;;;;;;;;;
400 ;;; PROTOCOL LOOKUP ;;;
402 ;;;;;;;;;;;;;;;;;;;;;;;;
403 ;;;;;;;;;;;;;;;;;;;;;;;;
405 (defclass protocol
()
406 ((name :initarg
:name
:reader protocol-name
)
407 (aliases :initarg
:aliases
:reader protocol-aliases
)
408 (protonum :initarg
:protonum
:reader protocol-number
)))
410 (defun make-protocol (name protonum
&optional aliases
)
411 (make-instance 'protocol
416 (defmethod print-object ((protocol protocol
) stream
)
417 (print-unreadable-object (protocol stream
:type t
:identity nil
)
418 (with-slots (name aliases protonum
) protocol
419 (format stream
"Name: ~S. Protocol number: ~A. Aliases: ~{~S~^, ~}"
420 name protonum aliases
))))
422 (define-condition unknown-protocol
(system-error)
423 ((name :initarg
:name
:initform nil
:reader protocol-name
))
424 (:report
(lambda (condition stream
)
425 (format stream
"Unknown protocol: ~S"
426 (protocol-name condition
))))
427 (:documentation
"Condition raised when a network protocol is not found."))
429 (defun make-protocol-from-protoent (protoent)
430 (let* ((name (foreign-slot-value protoent
'et
:protoent
'et
:name
))
431 (number (foreign-slot-value protoent
'et
:protoent
'et
:proto
))
432 (aliasptr (foreign-slot-value protoent
'et
:protoent
'et
:aliases
))
435 :for alias
:= (mem-aref aliasptr
:string i
)
436 :while alias
:collect alias
)))
437 (make-protocol name number aliases
)))
439 (defun get-protocol-by-number (protonum)
440 (make-protocol-from-protoent (et:getprotobynumber protonum
)))
442 (defun get-protocol-by-name (protoname)
443 (make-protocol-from-protoent (et:getprotobyname protoname
)))
445 (defun lookup-protocol (proto)
446 (let ((parsed-number (parse-number-or-nil proto
)))
449 (get-protocol-by-number parsed-number
)
450 (get-protocol-by-name proto
))
452 (declare (ignore err
))
453 (error 'unknown-protocol
:name proto
)))))