guile18/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 2.1 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         (if server-listening?
 296             (let ((pid (primitive-fork)))
 297               ;; Spawn a server process.
 298               (case pid
 299                 ((-1) (throw 'unresolved))
 300                 ((0)   ;; the kid:  serve two connections and exit
 301                  (let serve ((conn
 302                               (false-if-exception (accept server-socket)))
 303                              (count 1))
 304                    (if (not conn)
 305                        (exit 1)
 306                        (if (> count 0)
 307                            (serve (false-if-exception (accept server-socket))
 308                                   (- count 1)))))
 309                  (exit 0))
 310                 (else  ;; the parent
 311                  (set! server-pid pid)
 312                  #t))))
 313
 314         (pass-if "connect"
 315           (if (not server-pid)
 316               (throw 'unresolved)
 317               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 318                 (connect s AF_UNIX path)
 319                 #t)))
 320
 321         (pass-if "connect/sockaddr"
 322           (if (not server-pid)
 323               (throw 'unresolved)
 324               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 325                 (connect s (make-socket-address AF_UNIX path))
 326                 #t)))
 327
 328         (pass-if "accept"
 329           (if (not server-pid)
 330               (throw 'unresolved)
 331               (let ((status (cdr (waitpid server-pid))))
 332                 (eq? 0 (status:exit-val status)))))
 333
 334         (false-if-exception (delete-file path))
 335
 336         #t)))
 337
 338
 339 (if (defined? 'AF_INET6)
 340     (with-test-prefix "AF_INET6/SOCK_STREAM"
 341
 342       ;; testing `bind', `listen' and `connect' on stream-oriented sockets
 343
 344       (let ((server-socket (socket AF_INET6 SOCK_STREAM 0))
 345             (server-bound? #f)
 346             (server-listening? #f)
 347             (server-pid #f)
 348             (ipv6-addr 1)               ; ::1
 349             (server-port 8889)
 350             (client-port 9998))
 351
 352         (pass-if "bind"
 353           (catch 'system-error
 354             (lambda ()
 355               (bind server-socket AF_INET6 ipv6-addr server-port)
 356               (set! server-bound? #t)
 357               #t)
 358             (lambda args
 359               (let ((errno (system-error-errno args)))
 360                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 361                       (else (apply throw args)))))))
 362
 363         (pass-if "bind/sockaddr"
 364           (let* ((sock (socket AF_INET6 SOCK_STREAM 0))
 365                  (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
 366             (catch 'system-error
 367               (lambda ()
 368                 (bind sock sockaddr)
 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"
 376           (if (not server-bound?)
 377               (throw 'unresolved)
 378               (begin
 379                 (listen server-socket 123)
 380                 (set! server-listening? #t)
 381                 #t)))
 382
 383         (if server-listening?
 384             (let ((pid (primitive-fork)))
 385               ;; Spawn a server process.
 386               (case pid
 387                 ((-1) (throw 'unresolved))
 388                 ((0)   ;; the kid:  serve two connections and exit
 389                  (let serve ((conn
 390                               (false-if-exception (accept server-socket)))
 391                              (count 1))
 392                    (if (not conn)
 393                        (exit 1)
 394                        (if (> count 0)
 395                            (serve (false-if-exception (accept server-socket))
 396                                   (- count 1)))))
 397                  (exit 0))
 398                 (else  ;; the parent
 399                  (set! server-pid pid)
 400                  #t))))
 401
 402         (pass-if "connect"
 403           (if (not server-pid)
 404               (throw 'unresolved)
 405               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 406                 (connect s AF_INET6 ipv6-addr server-port)
 407                 #t)))
 408
 409         (pass-if "connect/sockaddr"
 410           (if (not server-pid)
 411               (throw 'unresolved)
 412               (let ((s (socket AF_INET6 SOCK_STREAM 0)))
 413                 (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
 414                 #t)))
 415
 416         (pass-if "accept"
 417           (if (not server-pid)
 418               (throw 'unresolved)
 419               (let ((status (cdr (waitpid server-pid))))
 420                 (eq? 0 (status:exit-val status)))))
 421
 422         #t)))
 423
 424 ;; Switch back to the previous directory.
 425 (false-if-exception (chdir %curdir))