test-suite/tests/00-socket.test

   1 ;;;; 00-socket.test --- test socket functions     -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   4 ;;;;   2011, 2012, 2013 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 \f
  29
  30 ;;;
  31 ;;; htonl
  32 ;;;
  33
  34 (if (defined? 'htonl)
  35     (with-test-prefix "htonl"
  36
  37       (pass-if "0" (eqv? 0 (htonl 0)))
  38
  39       (pass-if-exception "-1" exception:out-of-range
  40         (htonl -1))
  41
  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)))
  46
  47       (pass-if-exception "2^1024" exception:out-of-range
  48         (htonl (ash 1 1024)))))
  49
  50
  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))))))
  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"))))))
 110
 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
 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
 157 ;;;
 158 ;;; ntohl
 159 ;;;
 160
 161 (if (defined? 'ntohl)
 162     (with-test-prefix "ntohl"
 163
 164       (pass-if "0" (eqv? 0 (ntohl 0)))
 165
 166       (pass-if-exception "-1" exception:out-of-range
 167         (ntohl -1))
 168
 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)))
 173
 174       (pass-if-exception "2^1024" exception:out-of-range
 175         (ntohl (ash 1 1024)))))
 176
 177
 178 \f
 179 ;;;
 180 ;;; AF_UNIX sockets and `make-socket-address'
 181 ;;;
 182
 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
 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))))
 205
 206
 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)
 214             (path (temp-file-path)))
 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))
 229                  (path (temp-file-path))
 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)
 244               (let ((client  (socket AF_UNIX SOCK_DGRAM 0))
 245                     (message (string->utf8 "hello")))
 246                 (> (sendto client message AF_UNIX path) 0))))
 247
 248         (pass-if "sendto/sockaddr"
 249           (if (not server-bound?)
 250               (throw 'unresolved)
 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))))
 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)
 268             (path (temp-file-path)))
 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))
 283                  (path (temp-file-path))
 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
 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.
 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                 (eqv? 0 (status:exit-val status)))))
 343
 344         (false-if-exception (delete-file path))
 345
 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                 (eqv? 0 (status:exit-val status)))))
 416
 417         (false-if-exception (delete-file path))
 418
 419         #t)))
 420
 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
 427       (let ((server-socket
 428              ;; Some platforms don't support this protocol/family combination.
 429              (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
 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"
 438           (if (not server-socket)
 439               (throw 'unresolved))
 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
 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))
 455
 456                       (else (apply throw args)))))))
 457
 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)))
 461             (if (not sock)
 462                 (throw 'unresolved))
 463             (catch 'system-error
 464               (lambda ()
 465                 (bind sock sockaddr)
 466                 #t)
 467               (lambda args
 468                 (let ((errno (system-error-errno args)))
 469                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 470                         ((= errno EADDRNOTAVAIL) (throw 'unresolved))
 471                         (else (apply throw args))))))))
 472
 473         (pass-if "listen"
 474           (if (not server-bound?)
 475               (throw 'unresolved)
 476               (begin
 477                 (listen server-socket 123)
 478                 (set! server-listening? #t)
 479                 #t)))
 480
 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.
 486               (case pid
 487                 ((-1) (throw 'unresolved))
 488                 ((0)   ;; the kid:  serve two connections and exit
 489                  (let serve ((conn
 490                               (false-if-exception (accept server-socket)))
 491                              (count 1))
 492                    (if (not conn)
 493                        (exit 1)
 494                        (if (> count 0)
 495                            (serve (false-if-exception (accept server-socket))
 496                                   (- count 1)))))
 497                  (exit 0))
 498                 (else  ;; the parent
 499                  (set! server-pid pid)
 500                  #t))))
 501
 502         (pass-if "connect"
 503           (if (not server-pid)
 504               (throw 'unresolved)
 505               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 506                 (connect s AF_INET6 ipv6-addr server-port)
 507                 #t)))
 508
 509         (pass-if "connect/sockaddr"
 510           (if (not server-pid)
 511               (throw 'unresolved)
 512               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 513                 (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
 514                 #t)))
 515
 516         (pass-if "accept"
 517           (if (not server-pid)
 518               (throw 'unresolved)
 519               (let ((status (cdr (waitpid server-pid))))
 520                 (eqv? 0 (status:exit-val status)))))
 521
 522         #t)))
 523
 524 ;; Switch back to the previous directory.
 525 (false-if-exception (chdir %curdir))