test-suite/tests/socket.test

   1 ;;;; socket.test --- test socket functions     -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-socket)
  20   #:use-module (test-suite lib))
  21
  22 \f
  23
  24 ;;;
  25 ;;; htonl
  26 ;;;
  27
  28 (if (defined? 'htonl)
  29     (with-test-prefix "htonl"
  30
  31       (pass-if "0" (eqv? 0 (htonl 0)))
  32
  33       (pass-if-exception "-1" exception:out-of-range
  34         (htonl -1))
  35
  36       ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
  37       ;; an overflow for values 2^32 <= x < 2^63
  38       (pass-if-exception "2^32" exception:out-of-range
  39         (htonl (ash 1 32)))
  40
  41       (pass-if-exception "2^1024" exception:out-of-range
  42         (htonl (ash 1 1024)))))
  43
  44
  45 ;;;
  46 ;;; inet-ntop
  47 ;;;
  48
  49 (if (defined? 'inet-ntop)
  50     (with-test-prefix "inet-ntop"
  51
  52       (with-test-prefix "ipv6"
  53         (pass-if "0"
  54           (string? (inet-ntop AF_INET6 0)))
  55
  56         (pass-if "2^128-1"
  57           (string? (inet-ntop AF_INET6 (1- (ash 1 128)))))
  58
  59         (pass-if-exception "-1" exception:out-of-range
  60           (inet-ntop AF_INET6 -1))
  61
  62         (pass-if-exception "2^128" exception:out-of-range
  63           (inet-ntop AF_INET6 (ash 1 128)))
  64
  65         (pass-if-exception "2^1024" exception:out-of-range
  66           (inet-ntop AF_INET6 (ash 1 1024))))))
  67
  68 ;;;
  69 ;;; inet-pton
  70 ;;;
  71
  72 (if (defined? 'inet-pton)
  73     (with-test-prefix "inet-pton"
  74
  75       (with-test-prefix "ipv6"
  76         (pass-if "00:00:00:00:00:00:00:00"
  77           (eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00")))
  78
  79         (pass-if "0:0:0:0:0:0:0:1"
  80           (eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1")))
  81
  82         (pass-if "::1"
  83           (eqv? 1 (inet-pton AF_INET6 "::1")))
  84
  85         (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
  86           (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
  87                 (inet-pton AF_INET6
  88                            "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))
  89
  90         (pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
  91           (eqv? #xF0000000000000000000000000000000
  92                 (inet-pton AF_INET6
  93                            "F000:0000:0000:0000:0000:0000:0000:0000")))
  94
  95         (pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
  96           (eqv? #x0F000000000000000000000000000000
  97                 (inet-pton AF_INET6
  98                            "0F00:0000:0000:0000:0000:0000:0000:0000")))
  99
 100         (pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
 101           (eqv? #xF0
 102                 (inet-pton AF_INET6
 103                            "0000:0000:0000:0000:0000:0000:0000:00F0"))))))
 104
 105 (if (defined? 'inet-ntop)
 106     (with-test-prefix "inet-ntop"
 107
 108       (with-test-prefix "ipv4"
 109         (pass-if "127.0.0.1"
 110           (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))
 111
 112       (if (defined? 'AF_INET6)
 113           (with-test-prefix "ipv6"
 114             (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
 115               (string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
 116                            (inet-ntop AF_INET6 (- (expt 2 128) 1))))
 117
 118             (pass-if "::1"
 119               (equal? "::1" (inet-ntop AF_INET6 1)))))))
 120
 121 \f
 122 ;;;
 123 ;;; make-socket-address
 124 ;;;
 125
 126 (with-test-prefix "make-socket-address"
 127   (if (defined? 'AF_INET)
 128       (pass-if "AF_INET"
 129         (let ((sa (make-socket-address AF_INET 123456 80)))
 130           (and (= (sockaddr:fam  sa) AF_INET)
 131                (= (sockaddr:addr sa) 123456)
 132                (= (sockaddr:port sa) 80)))))
 133
 134   (if (defined? 'AF_INET6)
 135       (pass-if "AF_INET6"
 136         ;; Since the platform doesn't necessarily support `scopeid', we won't
 137         ;; test it.
 138         (let ((sa* (make-socket-address AF_INET6 123456 80 1))
 139               (sa+ (make-socket-address AF_INET6 123456 80)))
 140           (and (= (sockaddr:fam  sa*) (sockaddr:fam  sa+) AF_INET6)
 141                (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456)
 142                (= (sockaddr:port sa*) (sockaddr:port sa+) 80)
 143                (= (sockaddr:flowinfo sa*) 1)))))
 144
 145   (if (defined? 'AF_UNIX)
 146       (pass-if "AF_UNIX"
 147         (let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket")))
 148           (and (= (sockaddr:fam sa) AF_UNIX)
 149                (string=? (sockaddr:path sa) "/tmp/unix-socket"))))))
 150
 151 ;;;
 152 ;;; ntohl
 153 ;;;
 154
 155 (if (defined? 'ntohl)
 156     (with-test-prefix "ntohl"
 157
 158       (pass-if "0" (eqv? 0 (ntohl 0)))
 159
 160       (pass-if-exception "-1" exception:out-of-range
 161         (ntohl -1))
 162
 163       ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
 164       ;; an overflow for values 2^32 <= x < 2^63
 165       (pass-if-exception "2^32" exception:out-of-range
 166         (ntohl (ash 1 32)))
 167
 168       (pass-if-exception "2^1024" exception:out-of-range
 169         (ntohl (ash 1 1024)))))
 170
 171
 172 \f
 173 ;;;
 174 ;;; AF_UNIX sockets and `make-socket-address'
 175 ;;;
 176
 177 (define %tmpdir
 178   ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
 179   (or (getenv "TMPDIR") "/tmp"))
 180
 181 (define %curdir
 182   ;; Remember the current working directory.
 183   (getcwd))
 184
 185 ;; Temporarily cd to %TMPDIR.  The goal is to work around path name
 186 ;; limitations, which can lead to exceptions like:
 187 ;;
 188 ;;  (misc-error "scm_to_sockaddr"
 189 ;;              "unix address path too long: ~A"
 190 ;;              ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
 191 ;;              #f)
 192 (chdir %tmpdir)
 193
 194 (define (temp-file-path)
 195   ;; Return a temporary file name, assuming the current directory is %TMPDIR.
 196   (string-append "guile-test-socket-"
 197                  (number->string (current-time)) "-"
 198                  (number->string (random 100000))))
 199
 200
 201 (if (defined? 'AF_UNIX)
 202     (with-test-prefix "AF_UNIX/SOCK_DGRAM"
 203
 204       ;; testing `bind' and `sendto' and datagram sockets
 205
 206       (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
 207             (server-bound? #f)
 208             (path (temp-file-path)))
 209
 210         (pass-if "bind"
 211           (catch 'system-error
 212             (lambda ()
 213               (bind server-socket AF_UNIX path)
 214               (set! server-bound? #t)
 215               #t)
 216             (lambda args
 217               (let ((errno (system-error-errno args)))
 218                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 219                       (else (apply throw args)))))))
 220
 221         (pass-if "bind/sockaddr"
 222           (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
 223                  (path (temp-file-path))
 224                  (sockaddr (make-socket-address AF_UNIX path)))
 225             (catch 'system-error
 226               (lambda ()
 227                 (bind sock sockaddr)
 228                 (false-if-exception (delete-file path))
 229                 #t)
 230               (lambda args
 231                 (let ((errno (system-error-errno args)))
 232                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 233                         (else (apply throw args))))))))
 234
 235         (pass-if "sendto"
 236           (if (not server-bound?)
 237               (throw 'unresolved)
 238               (let ((client (socket AF_UNIX SOCK_DGRAM 0)))
 239                 (> (sendto client "hello" AF_UNIX path) 0))))
 240
 241         (pass-if "sendto/sockaddr"
 242           (if (not server-bound?)
 243               (throw 'unresolved)
 244               (let ((client (socket AF_UNIX SOCK_DGRAM 0))
 245                     (sockaddr (make-socket-address AF_UNIX path)))
 246                 (> (sendto client "hello" sockaddr) 0))))
 247
 248         (false-if-exception (delete-file path)))))
 249
 250
 251 (if (defined? 'AF_UNIX)
 252     (with-test-prefix "AF_UNIX/SOCK_STREAM"
 253
 254       ;; testing `bind', `listen' and `connect' on stream-oriented sockets
 255
 256       (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
 257             (server-bound? #f)
 258             (server-listening? #f)
 259             (server-pid #f)
 260             (path (temp-file-path)))
 261
 262         (pass-if "bind"
 263           (catch 'system-error
 264             (lambda ()
 265               (bind server-socket AF_UNIX path)
 266               (set! server-bound? #t)
 267               #t)
 268             (lambda args
 269               (let ((errno (system-error-errno args)))
 270                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 271                       (else (apply throw args)))))))
 272
 273         (pass-if "bind/sockaddr"
 274           (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
 275                  (path (temp-file-path))
 276                  (sockaddr (make-socket-address AF_UNIX path)))
 277             (catch 'system-error
 278               (lambda ()
 279                 (bind sock sockaddr)
 280                 (false-if-exception (delete-file path))
 281                 #t)
 282               (lambda args
 283                 (let ((errno (system-error-errno args)))
 284                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 285                         (else (apply throw args))))))))
 286
 287         (pass-if "listen"
 288           (if (not server-bound?)
 289               (throw 'unresolved)
 290               (begin
 291                 (listen server-socket 123)
 292                 (set! server-listening? #t)
 293                 #t)))
 294
 295         (force-output (current-output-port))
 296         (force-output (current-error-port))
 297         (if server-listening?
 298             (let ((pid (primitive-fork)))
 299               ;; Spawn a server process.
 300               (case pid
 301                 ((-1) (throw 'unresolved))
 302                 ((0)   ;; the kid:  serve two connections and exit
 303                  (let serve ((conn
 304                               (false-if-exception (accept server-socket)))
 305                              (count 1))
 306                    (if (not conn)
 307                        (exit 1)
 308                        (if (> count 0)
 309                            (serve (false-if-exception (accept server-socket))
 310                                   (- count 1)))))
 311                  (exit 0))
 312                 (else  ;; the parent
 313                  (set! server-pid pid)
 314                  #t))))
 315
 316         (pass-if "connect"
 317           (if (not server-pid)
 318               (throw 'unresolved)
 319               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 320                 (connect s AF_UNIX path)
 321                 #t)))
 322
 323         (pass-if "connect/sockaddr"
 324           (if (not server-pid)
 325               (throw 'unresolved)
 326               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 327                 (connect s (make-socket-address AF_UNIX path))
 328                 #t)))
 329
 330         (pass-if "accept"
 331           (if (not server-pid)
 332               (throw 'unresolved)
 333               (let ((status (cdr (waitpid server-pid))))
 334                 (eq? 0 (status:exit-val status)))))
 335
 336         (false-if-exception (delete-file path))
 337
 338         #t)))
 339
 340
 341 (if (defined? 'AF_INET6)
 342     (with-test-prefix "AF_INET6/SOCK_STREAM"
 343
 344       ;; testing `bind', `listen' and `connect' on stream-oriented sockets
 345
 346       (let ((server-socket (socket AF_INET6 SOCK_STREAM 0))
 347             (server-bound? #f)
 348             (server-listening? #f)
 349             (server-pid #f)
 350             (ipv6-addr 1)               ; ::1
 351             (server-port 8889)
 352             (client-port 9998))
 353
 354         (pass-if "bind"
 355           (catch 'system-error
 356             (lambda ()
 357               (bind server-socket AF_INET6 ipv6-addr server-port)
 358               (set! server-bound? #t)
 359               #t)
 360             (lambda args
 361               (let ((errno (system-error-errno args)))
 362                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 363                       (else (apply throw args)))))))
 364
 365         (pass-if "bind/sockaddr"
 366           (let* ((sock (socket AF_INET6 SOCK_STREAM 0))
 367                  (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
 368             (catch 'system-error
 369               (lambda ()
 370                 (bind sock sockaddr)
 371                 #t)
 372               (lambda args
 373                 (let ((errno (system-error-errno args)))
 374                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 375                         (else (apply throw args))))))))
 376
 377         (pass-if "listen"
 378           (if (not server-bound?)
 379               (throw 'unresolved)
 380               (begin
 381                 (listen server-socket 123)
 382                 (set! server-listening? #t)
 383                 #t)))
 384
 385         (force-output (current-output-port))
 386         (force-output (current-error-port))
 387         (if server-listening?
 388             (let ((pid (primitive-fork)))
 389               ;; Spawn a server process.
 390               (case pid
 391                 ((-1) (throw 'unresolved))
 392                 ((0)   ;; the kid:  serve two connections and exit
 393                  (let serve ((conn
 394                               (false-if-exception (accept server-socket)))
 395                              (count 1))
 396                    (if (not conn)
 397                        (exit 1)
 398                        (if (> count 0)
 399                            (serve (false-if-exception (accept server-socket))
 400                                   (- count 1)))))
 401                  (exit 0))
 402                 (else  ;; the parent
 403                  (set! server-pid pid)
 404                  #t))))
 405
 406         (pass-if "connect"
 407           (if (not server-pid)
 408               (throw 'unresolved)
 409               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 410                 (connect s AF_INET6 ipv6-addr server-port)
 411                 #t)))
 412
 413         (pass-if "connect/sockaddr"
 414           (if (not server-pid)
 415               (throw 'unresolved)
 416               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 417                 (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
 418                 #t)))
 419
 420         (pass-if "accept"
 421           (if (not server-pid)
 422               (throw 'unresolved)
 423               (let ((status (cdr (waitpid server-pid))))
 424                 (eq? 0 (status:exit-val status)))))
 425
 426         #t)))
 427
 428 ;; Switch back to the previous directory.
 429 (false-if-exception (chdir %curdir))