test-suite/tests/socket.test

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