1 ;;;; 00-socket.test --- test socket functions -*- scheme -*-
3 ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 ;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
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
9 ;;;; version 3 of the License, or (at your option) any later version.
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.
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
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 ;; This test runs early, so that we can fork before any threads are
21 ;; created in other tests.
23 (define-module (test-suite test-socket)
24 #:use-module (rnrs bytevectors)
25 #:use-module (srfi srfi-26)
26 #:use-module (test-suite lib))
35 (with-test-prefix "htonl"
37 (pass-if "0" (eqv? 0 (htonl 0)))
39 (pass-if-exception "-1" exception:out-of-range
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
47 (pass-if-exception "2^1024" exception:out-of-range
48 (htonl (ash 1 1024)))))
55 (if (defined? 'inet-ntop)
56 (with-test-prefix "inet-ntop"
58 (with-test-prefix "ipv6"
60 (string? (inet-ntop AF_INET6 0)))
63 (string? (inet-ntop AF_INET6 (1- (ash 1 128)))))
65 (pass-if-exception "-1" exception:out-of-range
66 (inet-ntop AF_INET6 -1))
68 (pass-if-exception "2^128" exception:out-of-range
69 (inet-ntop AF_INET6 (ash 1 128)))
71 (pass-if-exception "2^1024" exception:out-of-range
72 (inet-ntop AF_INET6 (ash 1 1024))))))
78 (if (defined? 'inet-pton)
79 (with-test-prefix "inet-pton"
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")))
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")))
89 (eqv? 1 (inet-pton AF_INET6 "::1")))
91 (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
92 (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
94 "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))
96 (pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
97 (eqv? #xF0000000000000000000000000000000
99 "F000:0000:0000:0000:0000:0000:0000:0000")))
101 (pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
102 (eqv? #x0F000000000000000000000000000000
104 "0F00:0000:0000:0000:0000:0000:0000:0000")))
106 (pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
109 "0000:0000:0000:0000:0000:0000:0000:00F0"))))))
111 (if (defined? 'inet-ntop)
112 (with-test-prefix "inet-ntop"
114 (with-test-prefix "ipv4"
116 (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))
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))))
125 (equal? "::1" (inet-ntop AF_INET6 1)))))))
129 ;;; make-socket-address
132 (with-test-prefix "make-socket-address"
133 (if (defined? '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)))))
140 (if (defined? 'AF_INET6)
142 ;; Since the platform doesn't necessarily support `scopeid', we won't
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)))))
151 (if (defined? '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"))))))
161 (if (defined? 'ntohl)
162 (with-test-prefix "ntohl"
164 (pass-if "0" (eqv? 0 (ntohl 0)))
166 (pass-if-exception "-1" exception:out-of-range
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
174 (pass-if-exception "2^1024" exception:out-of-range
175 (ntohl (ash 1 1024)))))
180 ;;; AF_UNIX sockets and `make-socket-address'
184 ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
185 (or (getenv "TMPDIR") "/tmp"))
188 ;; Remember the current working directory.
191 ;; Temporarily cd to %TMPDIR. The goal is to work around path name
192 ;; limitations, which can lead to exceptions like:
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")
200 (define (temp-file-path)
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))))
207 (if (defined? 'AF_UNIX)
208 (with-test-prefix "AF_UNIX/SOCK_DGRAM"
210 ;; testing `bind' and `sendto' and datagram sockets
212 (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
214 (path (temp-file-path)))
219 (bind server-socket AF_UNIX path)
220 (set! server-bound? #t)
223 (let ((errno (system-error-errno args)))
224 (cond ((= errno EADDRINUSE) (throw 'unresolved))
225 (else (apply throw args)))))))
227 (pass-if "bind/sockaddr"
228 (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
229 (path (temp-file-path))
230 (sockaddr (make-socket-address AF_UNIX path)))
234 (false-if-exception (delete-file path))
237 (let ((errno (system-error-errno args)))
238 (cond ((= errno EADDRINUSE) (throw 'unresolved))
239 (else (apply throw args))))))))
242 (if (not server-bound?)
244 (let ((client (socket AF_UNIX SOCK_DGRAM 0))
245 (message (string->utf8 "hello")))
246 (> (sendto client message AF_UNIX path) 0))))
248 (pass-if "sendto/sockaddr"
249 (if (not server-bound?)
251 (let ((client (socket AF_UNIX SOCK_DGRAM 0))
252 (message (string->utf8 "hello"))
253 (sockaddr (make-socket-address AF_UNIX path)))
254 (> (sendto client message sockaddr) 0))))
256 (false-if-exception (delete-file path)))))
259 (if (defined? 'AF_UNIX)
260 (with-test-prefix "AF_UNIX/SOCK_STREAM"
262 ;; testing `bind', `listen' and `connect' on stream-oriented sockets
264 (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
266 (server-listening? #f)
268 (path (temp-file-path)))
273 (bind server-socket AF_UNIX path)
274 (set! server-bound? #t)
277 (let ((errno (system-error-errno args)))
278 (cond ((= errno EADDRINUSE) (throw 'unresolved))
279 (else (apply throw args)))))))
281 (pass-if "bind/sockaddr"
282 (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
283 (path (temp-file-path))
284 (sockaddr (make-socket-address AF_UNIX path)))
288 (false-if-exception (delete-file path))
291 (let ((errno (system-error-errno args)))
292 (cond ((= errno EADDRINUSE) (throw 'unresolved))
293 (else (apply throw args))))))))
296 (if (not server-bound?)
299 (listen server-socket 123)
300 (set! server-listening? #t)
303 (force-output (current-output-port))
304 (force-output (current-error-port))
305 (if server-listening?
306 (let ((pid (primitive-fork)))
307 ;; Spawn a server process.
309 ((-1) (throw 'unresolved))
310 ((0) ;; the kid: serve two connections and exit
312 (false-if-exception (accept server-socket)))
317 (serve (false-if-exception (accept server-socket))
321 (set! server-pid pid)
327 (let ((s (socket AF_UNIX SOCK_STREAM 0)))
328 (connect s AF_UNIX path)
331 (pass-if "connect/sockaddr"
334 (let ((s (socket AF_UNIX SOCK_STREAM 0)))
335 (connect s (make-socket-address AF_UNIX path))
341 (let ((status (cdr (waitpid server-pid))))
342 (eqv? 0 (status:exit-val status)))))
344 (false-if-exception (delete-file path))
349 ;; Testing `send', `recv!' & co. on stream-oriented sockets (with
350 ;; a bit of duplication with the above.)
352 (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
354 (server-listening? #f)
356 (message "hello, world!")
357 (path (temp-file-path)))
359 (define (sub-bytevector bv len)
360 (let ((c (make-bytevector len)))
361 (bytevector-copy! bv 0 c 0 len)
364 (pass-if "bind (bis)"
367 (bind server-socket AF_UNIX path)
368 (set! server-bound? #t)
371 (let ((errno (system-error-errno args)))
372 (cond ((= errno EADDRINUSE) (throw 'unresolved))
373 (else (apply throw args)))))))
375 (pass-if "listen (bis)"
376 (if (not server-bound?)
379 (listen server-socket 123)
380 (set! server-listening? #t)
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.
389 ((-1) (throw 'unresolved))
390 ((0) ;; the kid: send MESSAGE and exit
393 (let ((conn (car (accept server-socket)))
394 (bv (string->utf8 message)))
395 (= (bytevector-length bv)
398 (set! server-pid pid)
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))
411 (pass-if "accept (bis)"
414 (let ((status (cdr (waitpid server-pid))))
415 (eqv? 0 (status:exit-val status)))))
417 (false-if-exception (delete-file path))
422 (if (defined? 'AF_INET6)
423 (with-test-prefix "AF_INET6/SOCK_STREAM"
425 ;; testing `bind', `listen' and `connect' on stream-oriented sockets
428 ;; Some platforms don't support this protocol/family combination.
429 (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
431 (server-listening? #f)
438 (if (not server-socket)
442 (bind server-socket AF_INET6 ipv6-addr server-port)
443 (set! server-bound? #t)
446 (let ((errno (system-error-errno args)))
447 (cond ((= errno EADDRINUSE) (throw 'unresolved))
449 ;; On Linux-based systems, when `ipv6' support is
450 ;; missing (for instance, `ipv6' is loaded and
451 ;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set
452 ;; to 1), the socket call above succeeds but
453 ;; bind(2) fails like this.
454 ((= errno EADDRNOTAVAIL) (throw 'unresolved))
456 (else (apply throw args)))))))
458 (pass-if "bind/sockaddr"
459 (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
460 (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
468 (let ((errno (system-error-errno args)))
469 (cond ((= errno EADDRINUSE) (throw 'unresolved))
470 ((= errno EADDRNOTAVAIL) (throw 'unresolved))
471 (else (apply throw args))))))))
474 (if (not server-bound?)
477 (listen server-socket 123)
478 (set! server-listening? #t)
481 (force-output (current-output-port))
482 (force-output (current-error-port))
483 (if server-listening?
484 (let ((pid (primitive-fork)))
485 ;; Spawn a server process.
487 ((-1) (throw 'unresolved))
488 ((0) ;; the kid: serve two connections and exit
490 (false-if-exception (accept server-socket)))
495 (serve (false-if-exception (accept server-socket))
499 (set! server-pid pid)
505 (let ((s (socket AF_INET6 SOCK_STREAM 0)))
506 (connect s AF_INET6 ipv6-addr server-port)
509 (pass-if "connect/sockaddr"
512 (let ((s (socket AF_INET6 SOCK_STREAM 0)))
513 (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
519 (let ((status (cdr (waitpid server-pid))))
520 (eqv? 0 (status:exit-val status)))))
524 ;; Switch back to the previous directory.
525 (false-if-exception (chdir %curdir))