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