Commit | Line | Data |
---|---|---|
415e00fc | 1 | ;;;; 00-socket.test --- test socket functions -*- scheme -*- |
4064ed2a | 2 | ;;;; |
d21a1dc8 | 3 | ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, |
415e00fc | 4 | ;;;; 2011, 2012 Free Software Foundation, Inc. |
4064ed2a KR |
5 | ;;;; |
6 | ;;;; This library is free software; you can redistribute it and/or | |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 9 | ;;;; version 3 of the License, or (at your option) any later version. |
d21a1dc8 | 10 | ;;;; |
4064ed2a KR |
11 | ;;;; This library 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 GNU | |
14 | ;;;; Lesser General Public License for more details. | |
d21a1dc8 | 15 | ;;;; |
4064ed2a KR |
16 | ;;;; You should have received a copy of the GNU Lesser General Public |
17 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
4064ed2a | 19 | |
415e00fc AW |
20 | ;; This test runs early, so that we can fork before any threads are |
21 | ;; created in other tests. | |
22 | ||
7a5fb796 | 23 | (define-module (test-suite test-socket) |
d21a1dc8 | 24 | #:use-module (rnrs bytevectors) |
9d46abb0 | 25 | #:use-module (srfi srfi-26) |
4064ed2a KR |
26 | #:use-module (test-suite lib)) |
27 | ||
e7e48080 | 28 | \f |
8ab3d8a0 KR |
29 | |
30 | ;;; | |
31 | ;;; htonl | |
32 | ;;; | |
33 | ||
d3075c52 LC |
34 | (if (defined? 'htonl) |
35 | (with-test-prefix "htonl" | |
8ab3d8a0 | 36 | |
d3075c52 | 37 | (pass-if "0" (eqv? 0 (htonl 0))) |
8ab3d8a0 | 38 | |
d3075c52 LC |
39 | (pass-if-exception "-1" exception:out-of-range |
40 | (htonl -1)) | |
8ab3d8a0 | 41 | |
d3075c52 LC |
42 | ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect |
43 | ;; an overflow for values 2^32 <= x < 2^63 | |
44 | (pass-if-exception "2^32" exception:out-of-range | |
45 | (htonl (ash 1 32))) | |
8ab3d8a0 | 46 | |
d3075c52 LC |
47 | (pass-if-exception "2^1024" exception:out-of-range |
48 | (htonl (ash 1 1024))))) | |
8ab3d8a0 KR |
49 | |
50 | ||
4064ed2a KR |
51 | ;;; |
52 | ;;; inet-ntop | |
53 | ;;; | |
54 | ||
55 | (if (defined? 'inet-ntop) | |
56 | (with-test-prefix "inet-ntop" | |
57 | ||
58 | (with-test-prefix "ipv6" | |
59 | (pass-if "0" | |
60 | (string? (inet-ntop AF_INET6 0))) | |
61 | ||
62 | (pass-if "2^128-1" | |
63 | (string? (inet-ntop AF_INET6 (1- (ash 1 128))))) | |
64 | ||
65 | (pass-if-exception "-1" exception:out-of-range | |
66 | (inet-ntop AF_INET6 -1)) | |
67 | ||
68 | (pass-if-exception "2^128" exception:out-of-range | |
69 | (inet-ntop AF_INET6 (ash 1 128))) | |
70 | ||
71 | (pass-if-exception "2^1024" exception:out-of-range | |
72 | (inet-ntop AF_INET6 (ash 1 1024)))))) | |
3810edd9 KR |
73 | |
74 | ;;; | |
75 | ;;; inet-pton | |
76 | ;;; | |
77 | ||
78 | (if (defined? 'inet-pton) | |
79 | (with-test-prefix "inet-pton" | |
80 | ||
81 | (with-test-prefix "ipv6" | |
82 | (pass-if "00:00:00:00:00:00:00:00" | |
83 | (eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00"))) | |
84 | ||
85 | (pass-if "0:0:0:0:0:0:0:1" | |
86 | (eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1"))) | |
87 | ||
88 | (pass-if "::1" | |
89 | (eqv? 1 (inet-pton AF_INET6 "::1"))) | |
90 | ||
91 | (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF" | |
92 | (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF | |
93 | (inet-pton AF_INET6 | |
94 | "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"))) | |
95 | ||
96 | (pass-if "F000:0000:0000:0000:0000:0000:0000:0000" | |
97 | (eqv? #xF0000000000000000000000000000000 | |
98 | (inet-pton AF_INET6 | |
99 | "F000:0000:0000:0000:0000:0000:0000:0000"))) | |
100 | ||
101 | (pass-if "0F00:0000:0000:0000:0000:0000:0000:0000" | |
102 | (eqv? #x0F000000000000000000000000000000 | |
103 | (inet-pton AF_INET6 | |
104 | "0F00:0000:0000:0000:0000:0000:0000:0000"))) | |
105 | ||
106 | (pass-if "0000:0000:0000:0000:0000:0000:0000:00F0" | |
107 | (eqv? #xF0 | |
108 | (inet-pton AF_INET6 | |
109 | "0000:0000:0000:0000:0000:0000:0000:00F0")))))) | |
e7e48080 | 110 | |
7a5fb796 LC |
111 | (if (defined? 'inet-ntop) |
112 | (with-test-prefix "inet-ntop" | |
113 | ||
114 | (with-test-prefix "ipv4" | |
115 | (pass-if "127.0.0.1" | |
116 | (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK)))) | |
117 | ||
118 | (if (defined? 'AF_INET6) | |
119 | (with-test-prefix "ipv6" | |
120 | (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF" | |
121 | (string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF" | |
122 | (inet-ntop AF_INET6 (- (expt 2 128) 1)))) | |
123 | ||
124 | (pass-if "::1" | |
125 | (equal? "::1" (inet-ntop AF_INET6 1))))))) | |
126 | ||
e7e48080 KR |
127 | \f |
128 | ;;; | |
129 | ;;; make-socket-address | |
130 | ;;; | |
131 | ||
132 | (with-test-prefix "make-socket-address" | |
133 | (if (defined? 'AF_INET) | |
134 | (pass-if "AF_INET" | |
135 | (let ((sa (make-socket-address AF_INET 123456 80))) | |
136 | (and (= (sockaddr:fam sa) AF_INET) | |
137 | (= (sockaddr:addr sa) 123456) | |
138 | (= (sockaddr:port sa) 80))))) | |
139 | ||
140 | (if (defined? 'AF_INET6) | |
141 | (pass-if "AF_INET6" | |
142 | ;; Since the platform doesn't necessarily support `scopeid', we won't | |
143 | ;; test it. | |
144 | (let ((sa* (make-socket-address AF_INET6 123456 80 1)) | |
145 | (sa+ (make-socket-address AF_INET6 123456 80))) | |
146 | (and (= (sockaddr:fam sa*) (sockaddr:fam sa+) AF_INET6) | |
147 | (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456) | |
148 | (= (sockaddr:port sa*) (sockaddr:port sa+) 80) | |
149 | (= (sockaddr:flowinfo sa*) 1))))) | |
150 | ||
151 | (if (defined? 'AF_UNIX) | |
152 | (pass-if "AF_UNIX" | |
153 | (let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket"))) | |
154 | (and (= (sockaddr:fam sa) AF_UNIX) | |
155 | (string=? (sockaddr:path sa) "/tmp/unix-socket")))))) | |
156 | ||
8ab3d8a0 KR |
157 | ;;; |
158 | ;;; ntohl | |
159 | ;;; | |
160 | ||
d3075c52 LC |
161 | (if (defined? 'ntohl) |
162 | (with-test-prefix "ntohl" | |
8ab3d8a0 | 163 | |
d3075c52 | 164 | (pass-if "0" (eqv? 0 (ntohl 0))) |
8ab3d8a0 | 165 | |
d3075c52 LC |
166 | (pass-if-exception "-1" exception:out-of-range |
167 | (ntohl -1)) | |
8ab3d8a0 | 168 | |
d3075c52 LC |
169 | ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect |
170 | ;; an overflow for values 2^32 <= x < 2^63 | |
171 | (pass-if-exception "2^32" exception:out-of-range | |
172 | (ntohl (ash 1 32))) | |
8ab3d8a0 | 173 | |
d3075c52 LC |
174 | (pass-if-exception "2^1024" exception:out-of-range |
175 | (ntohl (ash 1 1024))))) | |
8ab3d8a0 | 176 | |
e7e48080 KR |
177 | |
178 | \f | |
179 | ;;; | |
180 | ;;; AF_UNIX sockets and `make-socket-address' | |
181 | ;;; | |
182 | ||
91cbeffc LC |
183 | (define %tmpdir |
184 | ;; Honor `$TMPDIR', which tmpnam(3) doesn't do. | |
185 | (or (getenv "TMPDIR") "/tmp")) | |
186 | ||
187 | (define %curdir | |
188 | ;; Remember the current working directory. | |
189 | (getcwd)) | |
190 | ||
191 | ;; Temporarily cd to %TMPDIR. The goal is to work around path name | |
192 | ;; limitations, which can lead to exceptions like: | |
193 | ;; | |
194 | ;; (misc-error "scm_to_sockaddr" | |
195 | ;; "unix address path too long: ~A" | |
196 | ;; ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619") | |
197 | ;; #f) | |
198 | (chdir %tmpdir) | |
199 | ||
eedcb08a | 200 | (define (temp-file-path) |
91cbeffc LC |
201 | ;; Return a temporary file name, assuming the current directory is %TMPDIR. |
202 | (string-append "guile-test-socket-" | |
203 | (number->string (current-time)) "-" | |
204 | (number->string (random 100000)))) | |
eedcb08a LC |
205 | |
206 | ||
e7e48080 KR |
207 | (if (defined? 'AF_UNIX) |
208 | (with-test-prefix "AF_UNIX/SOCK_DGRAM" | |
209 | ||
210 | ;; testing `bind' and `sendto' and datagram sockets | |
211 | ||
212 | (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0)) | |
213 | (server-bound? #f) | |
eedcb08a | 214 | (path (temp-file-path))) |
e7e48080 KR |
215 | |
216 | (pass-if "bind" | |
217 | (catch 'system-error | |
218 | (lambda () | |
219 | (bind server-socket AF_UNIX path) | |
220 | (set! server-bound? #t) | |
221 | #t) | |
222 | (lambda args | |
223 | (let ((errno (system-error-errno args))) | |
224 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
225 | (else (apply throw args))))))) | |
226 | ||
227 | (pass-if "bind/sockaddr" | |
228 | (let* ((sock (socket AF_UNIX SOCK_STREAM 0)) | |
eedcb08a | 229 | (path (temp-file-path)) |
e7e48080 KR |
230 | (sockaddr (make-socket-address AF_UNIX path))) |
231 | (catch 'system-error | |
232 | (lambda () | |
233 | (bind sock sockaddr) | |
234 | (false-if-exception (delete-file path)) | |
235 | #t) | |
236 | (lambda args | |
237 | (let ((errno (system-error-errno args))) | |
238 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
239 | (else (apply throw args)))))))) | |
240 | ||
241 | (pass-if "sendto" | |
242 | (if (not server-bound?) | |
243 | (throw 'unresolved) | |
d21a1dc8 LC |
244 | (let ((client (socket AF_UNIX SOCK_DGRAM 0)) |
245 | (message (string->utf8 "hello"))) | |
246 | (> (sendto client message AF_UNIX path) 0)))) | |
e7e48080 KR |
247 | |
248 | (pass-if "sendto/sockaddr" | |
249 | (if (not server-bound?) | |
250 | (throw 'unresolved) | |
d21a1dc8 LC |
251 | (let ((client (socket AF_UNIX SOCK_DGRAM 0)) |
252 | (message (string->utf8 "hello")) | |
e7e48080 | 253 | (sockaddr (make-socket-address AF_UNIX path))) |
d21a1dc8 | 254 | (> (sendto client message sockaddr) 0)))) |
e7e48080 KR |
255 | |
256 | (false-if-exception (delete-file path))))) | |
257 | ||
258 | ||
259 | (if (defined? 'AF_UNIX) | |
260 | (with-test-prefix "AF_UNIX/SOCK_STREAM" | |
261 | ||
262 | ;; testing `bind', `listen' and `connect' on stream-oriented sockets | |
263 | ||
264 | (let ((server-socket (socket AF_UNIX SOCK_STREAM 0)) | |
265 | (server-bound? #f) | |
266 | (server-listening? #f) | |
267 | (server-pid #f) | |
eedcb08a | 268 | (path (temp-file-path))) |
e7e48080 KR |
269 | |
270 | (pass-if "bind" | |
271 | (catch 'system-error | |
272 | (lambda () | |
273 | (bind server-socket AF_UNIX path) | |
274 | (set! server-bound? #t) | |
275 | #t) | |
276 | (lambda args | |
277 | (let ((errno (system-error-errno args))) | |
278 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
279 | (else (apply throw args))))))) | |
280 | ||
281 | (pass-if "bind/sockaddr" | |
282 | (let* ((sock (socket AF_UNIX SOCK_STREAM 0)) | |
eedcb08a | 283 | (path (temp-file-path)) |
e7e48080 KR |
284 | (sockaddr (make-socket-address AF_UNIX path))) |
285 | (catch 'system-error | |
286 | (lambda () | |
287 | (bind sock sockaddr) | |
288 | (false-if-exception (delete-file path)) | |
289 | #t) | |
290 | (lambda args | |
291 | (let ((errno (system-error-errno args))) | |
292 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
293 | (else (apply throw args)))))))) | |
294 | ||
295 | (pass-if "listen" | |
296 | (if (not server-bound?) | |
297 | (throw 'unresolved) | |
298 | (begin | |
299 | (listen server-socket 123) | |
300 | (set! server-listening? #t) | |
301 | #t))) | |
302 | ||
5ebc8b81 KR |
303 | (force-output (current-output-port)) |
304 | (force-output (current-error-port)) | |
e7e48080 KR |
305 | (if server-listening? |
306 | (let ((pid (primitive-fork))) | |
307 | ;; Spawn a server process. | |
308 | (case pid | |
309 | ((-1) (throw 'unresolved)) | |
310 | ((0) ;; the kid: serve two connections and exit | |
311 | (let serve ((conn | |
312 | (false-if-exception (accept server-socket))) | |
313 | (count 1)) | |
314 | (if (not conn) | |
315 | (exit 1) | |
316 | (if (> count 0) | |
317 | (serve (false-if-exception (accept server-socket)) | |
318 | (- count 1))))) | |
319 | (exit 0)) | |
320 | (else ;; the parent | |
321 | (set! server-pid pid) | |
322 | #t)))) | |
323 | ||
324 | (pass-if "connect" | |
325 | (if (not server-pid) | |
326 | (throw 'unresolved) | |
327 | (let ((s (socket AF_UNIX SOCK_STREAM 0))) | |
328 | (connect s AF_UNIX path) | |
329 | #t))) | |
330 | ||
331 | (pass-if "connect/sockaddr" | |
332 | (if (not server-pid) | |
333 | (throw 'unresolved) | |
334 | (let ((s (socket AF_UNIX SOCK_STREAM 0))) | |
335 | (connect s (make-socket-address AF_UNIX path)) | |
336 | #t))) | |
337 | ||
338 | (pass-if "accept" | |
339 | (if (not server-pid) | |
340 | (throw 'unresolved) | |
341 | (let ((status (cdr (waitpid server-pid)))) | |
342 | (eq? 0 (status:exit-val status))))) | |
343 | ||
344 | (false-if-exception (delete-file path)) | |
345 | ||
9d46abb0 LC |
346 | #t) |
347 | ||
348 | ||
349 | ;; Testing `send', `recv!' & co. on stream-oriented sockets (with | |
350 | ;; a bit of duplication with the above.) | |
351 | ||
352 | (let ((server-socket (socket AF_UNIX SOCK_STREAM 0)) | |
353 | (server-bound? #f) | |
354 | (server-listening? #f) | |
355 | (server-pid #f) | |
356 | (message "hello, world!") | |
357 | (path (temp-file-path))) | |
358 | ||
359 | (define (sub-bytevector bv len) | |
360 | (let ((c (make-bytevector len))) | |
361 | (bytevector-copy! bv 0 c 0 len) | |
362 | c)) | |
363 | ||
364 | (pass-if "bind (bis)" | |
365 | (catch 'system-error | |
366 | (lambda () | |
367 | (bind server-socket AF_UNIX path) | |
368 | (set! server-bound? #t) | |
369 | #t) | |
370 | (lambda args | |
371 | (let ((errno (system-error-errno args))) | |
372 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
373 | (else (apply throw args))))))) | |
374 | ||
375 | (pass-if "listen (bis)" | |
376 | (if (not server-bound?) | |
377 | (throw 'unresolved) | |
378 | (begin | |
379 | (listen server-socket 123) | |
380 | (set! server-listening? #t) | |
381 | #t))) | |
382 | ||
383 | (force-output (current-output-port)) | |
384 | (force-output (current-error-port)) | |
385 | (if server-listening? | |
386 | (let ((pid (primitive-fork))) | |
387 | ;; Spawn a server process. | |
388 | (case pid | |
389 | ((-1) (throw 'unresolved)) | |
390 | ((0) ;; the kid: send MESSAGE and exit | |
391 | (exit | |
392 | (false-if-exception | |
393 | (let ((conn (car (accept server-socket))) | |
394 | (bv (string->utf8 message))) | |
395 | (= (bytevector-length bv) | |
396 | (send conn bv)))))) | |
397 | (else ;; the parent | |
398 | (set! server-pid pid) | |
399 | #t)))) | |
400 | ||
401 | (pass-if "recv!" | |
402 | (if (not server-pid) | |
403 | (throw 'unresolved) | |
404 | (let ((s (socket AF_UNIX SOCK_STREAM 0))) | |
405 | (connect s AF_UNIX path) | |
406 | (let* ((buf (make-bytevector 123)) | |
407 | (received (recv! s buf))) | |
408 | (string=? (utf8->string (sub-bytevector buf received)) | |
409 | message))))) | |
410 | ||
411 | (pass-if "accept (bis)" | |
412 | (if (not server-pid) | |
413 | (throw 'unresolved) | |
414 | (let ((status (cdr (waitpid server-pid)))) | |
415 | (eq? 0 (status:exit-val status))))) | |
416 | ||
417 | (false-if-exception (delete-file path)) | |
418 | ||
419 | #t))) | |
e7e48080 | 420 | |
1ff4da65 NJ |
421 | |
422 | (if (defined? 'AF_INET6) | |
423 | (with-test-prefix "AF_INET6/SOCK_STREAM" | |
424 | ||
425 | ;; testing `bind', `listen' and `connect' on stream-oriented sockets | |
426 | ||
d532c41b LC |
427 | (let ((server-socket |
428 | ;; Some platforms don't support this protocol/family combination. | |
429 | (false-if-exception (socket AF_INET6 SOCK_STREAM 0))) | |
1ff4da65 NJ |
430 | (server-bound? #f) |
431 | (server-listening? #f) | |
432 | (server-pid #f) | |
433 | (ipv6-addr 1) ; ::1 | |
434 | (server-port 8889) | |
435 | (client-port 9998)) | |
436 | ||
437 | (pass-if "bind" | |
d532c41b LC |
438 | (if (not server-socket) |
439 | (throw 'unresolved)) | |
1ff4da65 NJ |
440 | (catch 'system-error |
441 | (lambda () | |
442 | (bind server-socket AF_INET6 ipv6-addr server-port) | |
443 | (set! server-bound? #t) | |
444 | #t) | |
445 | (lambda args | |
446 | (let ((errno (system-error-errno args))) | |
447 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
448 | (else (apply throw args))))))) | |
449 | ||
450 | (pass-if "bind/sockaddr" | |
d532c41b | 451 | (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0))) |
1ff4da65 | 452 | (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port))) |
d532c41b LC |
453 | (if (not sock) |
454 | (throw 'unresolved)) | |
1ff4da65 NJ |
455 | (catch 'system-error |
456 | (lambda () | |
457 | (bind sock sockaddr) | |
458 | #t) | |
459 | (lambda args | |
460 | (let ((errno (system-error-errno args))) | |
461 | (cond ((= errno EADDRINUSE) (throw 'unresolved)) | |
462 | (else (apply throw args)))))))) | |
463 | ||
464 | (pass-if "listen" | |
465 | (if (not server-bound?) | |
466 | (throw 'unresolved) | |
467 | (begin | |
468 | (listen server-socket 123) | |
469 | (set! server-listening? #t) | |
470 | #t))) | |
471 | ||
5ebc8b81 KR |
472 | (force-output (current-output-port)) |
473 | (force-output (current-error-port)) | |
1ff4da65 NJ |
474 | (if server-listening? |
475 | (let ((pid (primitive-fork))) | |
476 | ;; Spawn a server process. | |
477 | (case pid | |
478 | ((-1) (throw 'unresolved)) | |
479 | ((0) ;; the kid: serve two connections and exit | |
480 | (let serve ((conn | |
481 | (false-if-exception (accept server-socket))) | |
482 | (count 1)) | |
483 | (if (not conn) | |
484 | (exit 1) | |
485 | (if (> count 0) | |
486 | (serve (false-if-exception (accept server-socket)) | |
487 | (- count 1))))) | |
488 | (exit 0)) | |
489 | (else ;; the parent | |
490 | (set! server-pid pid) | |
491 | #t)))) | |
492 | ||
493 | (pass-if "connect" | |
494 | (if (not server-pid) | |
495 | (throw 'unresolved) | |
496 | (let ((s (socket AF_INET6 SOCK_STREAM 0))) | |
497 | (connect s AF_INET6 ipv6-addr server-port) | |
498 | #t))) | |
499 | ||
500 | (pass-if "connect/sockaddr" | |
501 | (if (not server-pid) | |
502 | (throw 'unresolved) | |
503 | (let ((s (socket AF_INET6 SOCK_STREAM 0))) | |
504 | (connect s (make-socket-address AF_INET6 ipv6-addr server-port)) | |
505 | #t))) | |
506 | ||
507 | (pass-if "accept" | |
508 | (if (not server-pid) | |
509 | (throw 'unresolved) | |
510 | (let ((status (cdr (waitpid server-pid)))) | |
511 | (eq? 0 (status:exit-val status))))) | |
512 | ||
91cbeffc LC |
513 | #t))) |
514 | ||
515 | ;; Switch back to the previous directory. | |
516 | (false-if-exception (chdir %curdir)) |