Fix bug in test SIMPLE-LOCAL-SOCKETS.
[iolib.git] / tests / sockets.lisp
blob874db9e50465e671c77653f612bf324291406afb
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
2 ;;;
3 ;;; sockets.lisp --- net.sockets test suite.
4 ;;;
5 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
6 ;;;
7 ;;; Permission is hereby granted, free of charge, to any person
8 ;;; obtaining a copy of this software and associated documentation
9 ;;; files (the "Software"), to deal in the Software without
10 ;;; restriction, including without limitation the rights to use, copy,
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 ;;; of the Software, and to permit persons to whom the Software is
13 ;;; furnished to do so, subject to the following conditions:
14 ;;;
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
17 ;;;
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 ;;; DEALINGS IN THE SOFTWARE.
26 ;;;
27 ;;; The first version of this test suite was based on SB-BSD-SOCKETS'
28 ;;; to which the following licensing information applies:
29 ;;;
30 ;;; All changes to SBCL since the fork from CMU CL have been
31 ;;; released into the public domain in jurisdictions where this is
32 ;;; possible, or under the FreeBSD licence where not.
34 (in-package :iolib-tests)
36 (in-suite* :net.sockets :in :iolib)
38 ;;; A couple of these tests require an echo server. You can either
39 ;;; compile and run the provided tests/echo-server.c or enabled the
40 ;;; echo services in (x)inetd.
41 ;;;
42 ;;; (Note: on Darwin, this can be achieved by uncommenting the echo
43 ;;; service in /etc/inetd.conf and running:
44 ;;; sudo xinetd -dontfork -inetd_compat)
45 ;;;
46 ;;; Set these appropriately if you want to point the echo tests
47 ;;; somewhere else.
48 (defparameter *echo-address* (ensure-address #(127 0 0 1)))
49 (defparameter *echo-port* 7)
51 ;;;; Addresses
53 ;;; a real address
54 (test address-to-vector.1
55 (is (equalp (address-to-vector "127.0.0.1")
56 (values #(127 0 0 1) :ipv4))))
58 ;;; and an address with bit 8 set on some octets
59 (test address-to-vector.2
60 (is (equalp (address-to-vector "242.1.211.3")
61 (values #(242 1 211 3) :ipv4))))
63 (test address-to-vector.3
64 (is (equalp (address-to-vector "::")
65 (values #(0 0 0 0 0 0 0 0) :ipv6))))
67 ;;; RT: used to return the PARSE-ERROR as a secondary value.
68 (test string-address-to-vector.1
69 (is-false (string-address-to-vector "256.0.0.1")))
71 ;;; RT: should only ignore PARSE-ERRORs.
72 (test string-address-to-vector.2
73 (signals type-error
74 (string-address-to-vector 'not-a-string)))
76 ;;; RT: should signal a PARSE-ERROR when given an invalid string.
77 (test ensure-address.1
78 (signals parse-error
79 (ensure-address "ff0x::114")))
81 ;;; ditto
82 (test ensure-address.2
83 (signals parse-error
84 (ensure-address "127.0.256.1")))
86 (test integer-to-dotted-and-back
87 (is-true
88 (every #'(lambda (s) (string= s (integer-to-dotted (dotted-to-integer s))))
89 '("0.0.255.0" "0.255.255.0" "0.255.255.1"))))
91 (test integer-to-dotted.1
92 (is (string= (integer-to-dotted 0)
93 "0.0.0.0")))
95 (test integer-to-dotted.2
96 (is (string= (integer-to-dotted +max-ipv4-value+)
97 "255.255.255.255")))
99 (test integer-to-dotted.3
100 (signals type-error
101 (integer-to-dotted (1+ +max-ipv4-value+))))
103 (test integer-to-dotted.4
104 (signals type-error
105 (integer-to-dotted -1)))
107 (test dotted-to-vector.1
108 (is (equalp (mapcar #'dotted-to-vector '("255.255.255.255" "0.0.0.0" "127.0.0.1"))
109 '(#(255 255 255 255) #(0 0 0 0) #(127 0 0 1)))))
111 (test dotted-to-vector.2
112 (signals parse-error
113 (dotted-to-vector "127.0.0.0.0")))
115 (test dotted-to-vector.3
116 (signals type-error
117 (dotted-to-vector 'not-a-string)))
119 (test vector-to-dotted.1
120 (is (equalp (mapcar #'vector-to-dotted '(#(255 255 255 255) #(0 0 0 0) (127 0 0 1)))
121 '("255.255.255.255" "0.0.0.0" "127.0.0.1"))))
123 (test vector-to-dotted.2
124 (signals type-error
125 (vector-to-dotted #(127 0 0 256))))
127 (test address-to-string.1
128 (is (equalp (mapcar (lambda (x) (address-to-string (make-address x)))
129 '(#(127 0 0 1) #(255 255 255 255) #(0 0 0 0 0 0 0 0)
130 #(0 0 0 0 0 0 0 1) #(1 0 0 0 0 0 0 0)))
131 '("127.0.0.1" "255.255.255.255" "::" "::1" "1::"))))
133 (test vector-to-colon-separated.1
134 (is (equalp (let ((ip #(0 0 0 255 255 255 0 0)))
135 (values (vector-to-colon-separated ip)
136 (vector-to-colon-separated ip :downcase)
137 (vector-to-colon-separated ip :upcase)))
138 (values "::ff:ff:ff:0:" "::ff:ff:ff:0:" "::FF:FF:FF:0:"))))
140 (test vector-to-colon-separated.2
141 (is (string= (vector-to-colon-separated #(1 2 3 4 5 0 6 7))
142 "1:2:3:4:5::6:7")))
144 (test vector-to-colon-separated.3
145 (is (string= (vector-to-colon-separated #(0 2 3 4 5 0 6 7))
146 ":2:3:4:5::6:7")))
148 (test vector-to-colon-separated.4
149 (is (string= (vector-to-colon-separated #(1 2 3 4 5 0 6 0))
150 "1:2:3:4:5::6:")))
152 (test colon-separated-to-vector.1
153 (is (equalp (mapcar #'colon-separated-to-vector
154 '(":ff::ff:" "::" "::1" "1::" ":2:3:4:5:6:7:8" "1:2:3:4:5:6:7:"
155 ":1::2:" "::127.0.0.1" ":1::127.0.0.1"))
156 '(#(0 #xff 0 0 0 0 #xff 0)
157 #(0 0 0 0 0 0 0 0)
158 #(0 0 0 0 0 0 0 1)
159 #(1 0 0 0 0 0 0 0)
160 #(0 2 3 4 5 6 7 8)
161 #(1 2 3 4 5 6 7 0)
162 #(0 1 0 0 0 0 2 0)
163 #(0 0 0 0 0 0 #x7f00 1)
164 #(0 1 0 0 0 0 #x7f00 1)))))
166 (test address=.1
167 (is-true (address= +ipv4-loopback+ (make-address #(127 0 0 1)))))
169 (test address=.2
170 (is-true (address= +ipv6-loopback+ (ensure-address "::1"))))
172 (test copy-address.1
173 (is-true (loop for designator in (list "127.0.0.1" +max-ipv4-value+ "::" "::1")
174 for addr1 = (ensure-address designator)
175 for addr2 = (ensure-address designator)
176 for addr3 = (copy-address addr1)
177 always (and (address= addr1 addr2)
178 (address= addr1 addr3)
179 (address= addr2 addr3)))))
181 (test make-address.1
182 (signals type-error
183 (make-address 'not-a-valid-designator)))
185 (test address.unspecified.1
186 (is-true (every #'inet-address-unspecified-p
187 (mapcar #'ensure-address '("0.0.0.0" "::" "0:0:0:0:0:0:0:0")))))
189 (test address.loopback.1
190 (is-true (every #'inet-address-loopback-p
191 (mapcar #'ensure-address '("127.0.0.1" "::1" "0:0::1")))))
193 (test address.multicast.1
194 (is-true (every #'inet-address-multicast-p
195 (mapcar #'ensure-address
196 '("224.0.0.0" "224.1.2.3" "232.0.0.127" "239.255.255.255"
197 "ff02::2" "ff0a::114" "ff05::1:3")))))
199 (test address.ipv6-ipv4-mapped.1
200 (is-true (ipv6-ipv4-mapped-p (ensure-address "::ffff:127.0.0.1"))))
202 (test address.ipv6.1
203 (is (equalp (address-to-vector "::1.2.3.4")
204 (values #(0 0 0 0 0 0 #x0102 #x0304) :ipv6))))
206 ;;;; Host Lookup
208 #-no-internet-available
209 (test lookup-host.1
210 (is (equalp (multiple-value-bind (addresses truename)
211 (lookup-host "a.root-servers.net" :ipv6 nil)
212 (values (address-equal-p (car addresses) #(198 41 0 4))
213 truename))
214 (values t "a.root-servers.net"))))
216 #-no-internet-available
217 (test lookup-host.2
218 (is-true (string= (nth-value 1 (lookup-host #(198 41 0 4)))
219 "a.root-servers.net")))
221 ;;; These days lots of people seem to be using DNS servers that don't
222 ;;; report resolving failures for non-existing domains. This test
223 ;;; will fail there.
224 (test lookup-host.3
225 (signals resolver-no-name-error
226 (lookup-host "foo.tninkpad.telent.net.")))
228 (test lookup-host.4
229 (is-true (address-equal-p (car (lookup-host #(127 0 0 1) :ipv6 nil))
230 #(127 0 0 1))))
232 (test lookup-host.5
233 (signals parse-error
234 (lookup-host #(127 0 0))))
236 (test lookup-host.6
237 (signals resolver-no-name-error
238 (lookup-host #(127 0 0 1) :ipv6 :ipv6)))
240 ;;;; Service Lookup
242 (test lookup-service.1
243 (is (equalp (lookup-service "ssh")
244 (values 22 "ssh" :tcp))))
246 (test lookup-service.2
247 (is (equalp (lookup-service 22 :udp)
248 (values 22 "ssh" :udp))))
250 ;;; looks up a reserved service port
251 (test lookup-service.3
252 ;; TODO: check for a more specific error.
253 (signals unknown-service
254 (lookup-service 1024)))
256 ;;;; Protocol Lookup
258 (test lookup-protocol.1
259 (is (equalp (multiple-value-bind (number name)
260 (lookup-protocol "tcp")
261 (values number name))
262 (values 6 "tcp"))))
264 (test lookup-protocol.2
265 (is (equalp (multiple-value-bind (number name)
266 (lookup-protocol "udp")
267 (values number name))
268 (values 17 "udp"))))
270 (test lookup-protocol.3
271 (signals unknown-protocol
272 (lookup-protocol "nonexistent-protocol")))
274 (test lookup-protocol.4
275 (is-true (string= (nth-value 1 (lookup-protocol 6))
276 "tcp")))
278 ;;;; Network Interfaces
280 (test list-network-interfaces.1
281 (is-true (<= 1 (length (list-network-interfaces)))))
283 (test network-interfaces.1
284 (is-true
285 (flet ((nif-equal (if1 if2)
286 (check-type if1 interface)
287 (check-type if2 interface)
288 (and (string= (interface-name if1) (interface-name if2))
289 (eql (interface-index if1) (interface-index if2)))))
290 (loop for nif in (list-network-interfaces)
291 always (nif-equal nif (lookup-interface (interface-name nif)))
292 always (nif-equal nif (lookup-interface (interface-index nif)))))))
294 ;;;; Sockets
296 ;;; RT: don't accept unknown keyword arguments, such as typos.
297 (test make-socket.1
298 (signals error
299 (make-socket :this-kw-arg-doesnt-exist t)))
301 (test make-socket.2
302 (is (equalp (with-open-socket (s :family :ipv4)
303 (values (socket-connected-p s)
304 (socket-open-p s)
305 (> (socket-fd s) 1)
306 (socket-family s)
307 (socket-protocol s)))
308 (values nil t t :ipv4 :default)))) ; why isn't it :TCP?
310 (test make-socket.3
311 (is-true (with-open-socket (s :family :ipv4)
312 (typep s 'socket))))
314 ;;; Given the functions we've got so far, if you can think of a better
315 ;;; way to make sure the bind succeeded than trying it twice, let me
316 ;;; know. 1974 has no special significance, unless you're the same age
317 ;;; as me.
318 (test inet.socket-bind.1
319 (signals socket-address-in-use-error
320 (with-open-socket (s :family :ipv4 :connect :passive
321 :local-host #(127 0 0 1) :local-port 1974)
322 (with-open-socket (s :family :ipv4 :connect :passive
323 :local-host #(127 0 0 1) :local-port 1974)))))
325 (test sockopt.1
326 (is-true (with-open-socket (s :family :ipv4)
327 (setf (socket-option s :reuse-address) t)
328 (socket-option s :reuse-address))))
330 ;;; Like READ-SEQUENCE, but returns early if the full quantity of data
331 ;;; isn't there to be read. Blocks if no input at all.
332 (defun read-buf-nonblock (buffer stream)
333 (let ((eof (gensym)))
334 (do ((i 0 (1+ i))
335 (c (read-char stream nil eof)
336 (read-char-no-hang stream nil eof)))
337 ((or (>= i (length buffer)) (not c) (eq c eof)) i)
338 (setf (elt buffer i) c))))
340 (test simple-tcp-client
341 (is-true
342 (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
343 :family :ipv4)
344 (let ((data (make-string 200)))
345 (format s "here is some text")
346 (finish-output s)
347 (let ((data (subseq data 0 (read-buf-nonblock data s))))
348 ;; (format t "~&Got ~S back from TCP echo server~%" data)
349 (> (length data) 0))))))
351 (test sockaddr-return-type
352 (is-true
353 (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
354 :family :ipv4)
355 (and (ipv4-address-p (remote-address s))
356 (numberp (remote-port s))))))
358 ;;; We don't support streams with UDP sockets ATM. But when we do,
359 ;;; let's add a similar test using stream functions.
361 ;;; FIXME: figure out why this test blocks with the inetd services on
362 ;;; my machines, on both Darwin and Linux/x86-64. Works with
363 ;;; echo-server.c though --luis
364 (test simple-udp-client.1
365 (is-true
366 (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
367 :type :datagram :family :ipv4)
368 (let ((data (make-array '(200) :element-type '(unsigned-byte 8))))
369 (socket-send "here is some text" s)
370 (socket-receive data s)
371 ;; (format t "~&Got ~S back from UDP echo server~%" data)
372 (> (length data) 0)))))
374 (test simple-udp-client.2
375 (is-true
376 (with-open-socket (s :type :datagram :family :ipv4)
377 (let ((data (make-array 100 :element-type '(unsigned-byte 8))))
378 (socket-send "here is some more text" s
379 :remote-address *echo-address*
380 :remote-port *echo-port*)
381 (socket-receive data s)
382 (> (length data) 0)))))
384 (test simple-local-sockets
385 (is (string= (let ((file (namestring
386 (make-pathname :name "local-socket" :type nil
387 :defaults (truename
388 (asdf:system-definition-pathname
389 (asdf:find-system '#:iolib-tests)))))))
390 ;; (ignore-errors (delete-file file))
391 (with-open-socket (p :family :local :connect :passive :local-filename file)
392 (with-open-socket (a :family :local :remote-filename file)
393 (format a "local socket test")
394 (finish-output a))
395 (let ((s (accept-connection p)))
396 (prog1 (read-line s)
397 (close s)
398 (delete-file file)))))
399 "local socket test")))
401 (defmacro with-http-stream ((var host port request) &body body)
402 `(with-open-socket (,var :family :ipv4 :remote-host ,host :remote-port ,port)
403 (format ,var ,(concatenate 'string request " HTTP/1.0~%~%"))
404 (finish-output ,var)
405 ,@body))
407 #-no-internet-available
408 (test simple-http-client
409 (is-true
410 (with-http-stream (s "www.google.com" 80 "HEAD /")
411 (let ((data (make-string 200)))
412 (setf data (subseq data 0 (read-buf-nonblock data s)))
413 ;; (princ data)
414 (> (length data) 0)))))
416 #-no-internet-available
417 (test sockopt-receive-buffer
418 ;; on Linux x86, the receive buffer size appears to be doubled in the
419 ;; kernel: we set a size of x and then getsockopt() returns 2x.
420 ;; This is why we compare with >= instead of =
421 (is-true
422 (with-http-stream (s "www.google.com" 80 "HEAD/")
423 (setf (socket-option s :receive-buffer) 1975)
424 (let ((data (make-string 200)))
425 (setf data (subseq data 0 (read-buf-nonblock data s)))
426 (and (> (length data) 0)
427 (>= (socket-option s :receive-buffer) 1975))))))
429 (test socket-open-p.1
430 (is-true (with-open-socket (s)
431 (socket-open-p s))))
433 (test socket-open-p.2
434 (is-true (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
435 :family :ipv4)
436 (socket-open-p s))))
438 (test socket-open-p.3
439 (is-false (with-open-socket (s)
440 (close s)
441 (socket-open-p s))))
443 ;;; we don't have an automatic test for some of this yet. There's no
444 ;;; simple way to run servers and have something automatically connect
445 ;;; to them as client, unless we spawn external programs. Then we
446 ;;; have to start telling people what external programs they should
447 ;;; have installed. Which, eventually, we will, but not just yet
449 ;;; to check with this: can display packets from multiple peers
450 ;;; peer address is shown correctly for each packet
451 ;;; packet length is correct
452 ;;; long (>500 byte) packets have the full length shown (doesn't work)
453 #-(and)
454 (defun udp-server (port)
455 (with-open-socket (s :type :datagram :local-port port)
456 (loop
457 (multiple-value-bind (buf len address port)
458 (socket-receive s nil 500)
459 (format t "Received ~A bytes from ~A:~A - ~A ~%"
460 len address port (subseq buf 0 (min 10 len)))))))