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, 2014 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 ;;; 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 \f
 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 \f
 137 ;;;
 138 ;;; AF_UNIX sockets and `make-socket-address'
 139 ;;;
 140
 141 (define %tmpdir
 142   ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
 143   (or (getenv "TMPDIR") "/tmp"))
 144
 145 (define %curdir
 146   ;; Remember the current working directory.
 147   (getcwd))
 148
 149 ;; Temporarily cd to %TMPDIR.  The goal is to work around path name
 150 ;; limitations, which can lead to exceptions like:
 151 ;;
 152 ;;  (misc-error "scm_to_sockaddr"
 153 ;;              "unix address path too long: ~A"
 154 ;;              ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
 155 ;;              #f)
 156 (chdir %tmpdir)
 157
 158 (define (temp-file-path)
 159   ;; Return a temporary file name, assuming the current directory is %TMPDIR.
 160   (string-append "guile-test-socket-"
 161                  (number->string (current-time)) "-"
 162                  (number->string (random 100000))))
 163
 164
 165 (if (defined? 'AF_UNIX)
 166     (with-test-prefix "AF_UNIX/SOCK_DGRAM"
 167
 168       ;; testing `bind' and `sendto' and datagram sockets
 169
 170       (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
 171             (server-bound? #f)
 172             (path (temp-file-path)))
 173
 174         (pass-if "bind"
 175           (catch 'system-error
 176             (lambda ()
 177               (bind server-socket AF_UNIX path)
 178               (set! server-bound? #t)
 179               #t)
 180             (lambda args
 181               (let ((errno (system-error-errno args)))
 182                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 183                       (else (apply throw args)))))))
 184
 185         (pass-if "bind/sockaddr"
 186           (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
 187                  (path (temp-file-path))
 188                  (sockaddr (make-socket-address AF_UNIX path)))
 189             (catch 'system-error
 190               (lambda ()
 191                 (bind sock sockaddr)
 192                 (false-if-exception (delete-file path))
 193                 #t)
 194               (lambda args
 195                 (let ((errno (system-error-errno args)))
 196                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 197                         (else (apply throw args))))))))
 198
 199         (pass-if "sendto"
 200           (if (not server-bound?)
 201               (throw 'unresolved)
 202               (let ((client  (socket AF_UNIX SOCK_DGRAM 0))
 203                     (message (string->utf8 "hello")))
 204                 (> (sendto client message AF_UNIX path) 0))))
 205
 206         (pass-if "sendto/sockaddr"
 207           (if (not server-bound?)
 208               (throw 'unresolved)
 209               (let ((client   (socket AF_UNIX SOCK_DGRAM 0))
 210                     (message  (string->utf8 "hello"))
 211                     (sockaddr (make-socket-address AF_UNIX path)))
 212                 (> (sendto client message sockaddr) 0))))
 213
 214         (false-if-exception (delete-file path)))))
 215
 216
 217 (if (defined? 'AF_UNIX)
 218     (with-test-prefix "AF_UNIX/SOCK_STREAM"
 219
 220       ;; testing `bind', `listen' and `connect' on stream-oriented sockets
 221
 222       (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
 223             (server-bound? #f)
 224             (server-listening? #f)
 225             (server-pid #f)
 226             (path (temp-file-path)))
 227
 228         (pass-if "bind"
 229           (catch 'system-error
 230             (lambda ()
 231               (bind server-socket AF_UNIX path)
 232               (set! server-bound? #t)
 233               #t)
 234             (lambda args
 235               (let ((errno (system-error-errno args)))
 236                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 237                       (else (apply throw args)))))))
 238
 239         (pass-if "bind/sockaddr"
 240           (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
 241                  (path (temp-file-path))
 242                  (sockaddr (make-socket-address AF_UNIX path)))
 243             (catch 'system-error
 244               (lambda ()
 245                 (bind sock sockaddr)
 246                 (false-if-exception (delete-file path))
 247                 #t)
 248               (lambda args
 249                 (let ((errno (system-error-errno args)))
 250                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 251                         (else (apply throw args))))))))
 252
 253         (pass-if "listen"
 254           (if (not server-bound?)
 255               (throw 'unresolved)
 256               (begin
 257                 (listen server-socket 123)
 258                 (set! server-listening? #t)
 259                 #t)))
 260
 261         (force-output (current-output-port))
 262         (force-output (current-error-port))
 263         (if server-listening?
 264             (let ((pid (primitive-fork)))
 265               ;; Spawn a server process.
 266               (case pid
 267                 ((-1) (throw 'unresolved))
 268                 ((0)   ;; the kid:  serve two connections and exit
 269                  (let serve ((conn
 270                               (false-if-exception (accept server-socket)))
 271                              (count 1))
 272                    (if (not conn)
 273                        (exit 1)
 274                        (if (> count 0)
 275                            (serve (false-if-exception (accept server-socket))
 276                                   (- count 1)))))
 277                  (exit 0))
 278                 (else  ;; the parent
 279                  (set! server-pid pid)
 280                  #t))))
 281
 282         (pass-if "connect"
 283           (if (not server-pid)
 284               (throw 'unresolved)
 285               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 286                 (connect s AF_UNIX path)
 287                 #t)))
 288
 289         (pass-if "connect/sockaddr"
 290           (if (not server-pid)
 291               (throw 'unresolved)
 292               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 293                 (connect s (make-socket-address AF_UNIX path))
 294                 #t)))
 295
 296         (pass-if "accept"
 297           (if (not server-pid)
 298               (throw 'unresolved)
 299               (let ((status (cdr (waitpid server-pid))))
 300                 (eqv? 0 (status:exit-val status)))))
 301
 302         (false-if-exception (delete-file path))
 303
 304         #t)
 305
 306
 307       ;; Testing `send', `recv!' & co. on stream-oriented sockets (with
 308       ;; a bit of duplication with the above.)
 309
 310       (let ((server-socket     (socket AF_UNIX SOCK_STREAM 0))
 311             (server-bound?     #f)
 312             (server-listening? #f)
 313             (server-pid        #f)
 314             (message           "hello, world!")
 315             (path              (temp-file-path)))
 316
 317         (define (sub-bytevector bv len)
 318           (let ((c (make-bytevector len)))
 319             (bytevector-copy! bv 0 c 0 len)
 320             c))
 321
 322         (pass-if "bind (bis)"
 323           (catch 'system-error
 324             (lambda ()
 325               (bind server-socket AF_UNIX path)
 326               (set! server-bound? #t)
 327               #t)
 328             (lambda args
 329               (let ((errno (system-error-errno args)))
 330                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 331                       (else (apply throw args)))))))
 332
 333         (pass-if "listen (bis)"
 334           (if (not server-bound?)
 335               (throw 'unresolved)
 336               (begin
 337                 (listen server-socket 123)
 338                 (set! server-listening? #t)
 339                 #t)))
 340
 341         (force-output (current-output-port))
 342         (force-output (current-error-port))
 343         (if server-listening?
 344             (let ((pid (primitive-fork)))
 345               ;; Spawn a server process.
 346               (case pid
 347                 ((-1) (throw 'unresolved))
 348                 ((0)   ;; the kid: send MESSAGE and exit
 349                  (exit
 350                   (false-if-exception
 351                    (let ((conn (car (accept server-socket)))
 352                          (bv   (string->utf8 message)))
 353                      (= (bytevector-length bv)
 354                         (send conn bv))))))
 355                 (else  ;; the parent
 356                  (set! server-pid pid)
 357                  #t))))
 358
 359         (pass-if "recv!"
 360           (if (not server-pid)
 361               (throw 'unresolved)
 362               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 363                 (connect s AF_UNIX path)
 364                 (let* ((buf      (make-bytevector 123))
 365                        (received (recv! s buf)))
 366                   (string=? (utf8->string (sub-bytevector buf received))
 367                             message)))))
 368
 369         (pass-if "accept (bis)"
 370           (if (not server-pid)
 371               (throw 'unresolved)
 372               (let ((status (cdr (waitpid server-pid))))
 373                 (eqv? 0 (status:exit-val status)))))
 374
 375         (false-if-exception (delete-file path))
 376
 377         #t)))
 378
 379
 380 (if (defined? 'AF_INET6)
 381     (with-test-prefix "AF_INET6/SOCK_STREAM"
 382
 383       ;; testing `bind', `listen' and `connect' on stream-oriented sockets
 384
 385       (let ((server-socket
 386              ;; Some platforms don't support this protocol/family combination.
 387              (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
 388             (server-bound? #f)
 389             (server-listening? #f)
 390             (server-pid #f)
 391             (ipv6-addr 1)               ; ::1
 392             (server-port 8889)
 393             (client-port 9998))
 394
 395         (pass-if "bind"
 396           (if (not server-socket)
 397               (throw 'unresolved))
 398           (catch 'system-error
 399             (lambda ()
 400               (bind server-socket AF_INET6 ipv6-addr server-port)
 401               (set! server-bound? #t)
 402               #t)
 403             (lambda args
 404               (let ((errno (system-error-errno args)))
 405                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 406
 407                       ;; On Linux-based systems, when `ipv6' support is
 408                       ;; missing (for instance, `ipv6' is loaded and
 409                       ;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set
 410                       ;; to 1), the socket call above succeeds but
 411                       ;; bind(2) fails like this.
 412                       ((= errno EADDRNOTAVAIL) (throw 'unresolved))
 413
 414                       (else (apply throw args)))))))
 415
 416         (pass-if "bind/sockaddr"
 417           (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
 418                  (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
 419             (if (not sock)
 420                 (throw 'unresolved))
 421             (catch 'system-error
 422               (lambda ()
 423                 (bind sock sockaddr)
 424                 #t)
 425               (lambda args
 426                 (let ((errno (system-error-errno args)))
 427                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 428                         ((= errno EADDRNOTAVAIL) (throw 'unresolved))
 429                         (else (apply throw args))))))))
 430
 431         (pass-if "listen"
 432           (if (not server-bound?)
 433               (throw 'unresolved)
 434               (begin
 435                 (listen server-socket 123)
 436                 (set! server-listening? #t)
 437                 #t)))
 438
 439         (force-output (current-output-port))
 440         (force-output (current-error-port))
 441         (if server-listening?
 442             (let ((pid (primitive-fork)))
 443               ;; Spawn a server process.
 444               (case pid
 445                 ((-1) (throw 'unresolved))
 446                 ((0)   ;; the kid:  serve two connections and exit
 447                  (let serve ((conn
 448                               (false-if-exception (accept server-socket)))
 449                              (count 1))
 450                    (if (not conn)
 451                        (exit 1)
 452                        (if (> count 0)
 453                            (serve (false-if-exception (accept server-socket))
 454                                   (- count 1)))))
 455                  (exit 0))
 456                 (else  ;; the parent
 457                  (set! server-pid pid)
 458                  #t))))
 459
 460         (pass-if "connect"
 461           (if (not server-pid)
 462               (throw 'unresolved)
 463               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 464                 (connect s AF_INET6 ipv6-addr server-port)
 465                 #t)))
 466
 467         (pass-if "connect/sockaddr"
 468           (if (not server-pid)
 469               (throw 'unresolved)
 470               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 471                 (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
 472                 #t)))
 473
 474         (pass-if "accept"
 475           (if (not server-pid)
 476               (throw 'unresolved)
 477               (let ((status (cdr (waitpid server-pid))))
 478                 (eqv? 0 (status:exit-val status)))))
 479
 480         #t)))
 481
 482 ;; Switch back to the previous directory.
 483 (false-if-exception (chdir %curdir))