test-suite/tests/socket.test

   1 ;;;; socket.test --- test socket functions     -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008 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 (temp-file-path)
 178   ;; Return a temporary file path that honors `$TMPDIR', which `tmpnam'
 179   ;; doesn't do.
 180   (let ((dir (or (getenv "TMPDIR") "/tmp")))
 181     (string-append dir "/guile-test-socket-"
 182                    (number->string (current-time)) "-"
 183                    (number->string (random 100000)))))
 184
 185
 186 (if (defined? 'AF_UNIX)
 187     (with-test-prefix "AF_UNIX/SOCK_DGRAM"
 188
 189       ;; testing `bind' and `sendto' and datagram sockets
 190
 191       (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
 192             (server-bound? #f)
 193             (path (temp-file-path)))
 194
 195         (pass-if "bind"
 196           (catch 'system-error
 197             (lambda ()
 198               (bind server-socket AF_UNIX path)
 199               (set! server-bound? #t)
 200               #t)
 201             (lambda args
 202               (let ((errno (system-error-errno args)))
 203                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 204                       (else (apply throw args)))))))
 205
 206         (pass-if "bind/sockaddr"
 207           (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
 208                  (path (temp-file-path))
 209                  (sockaddr (make-socket-address AF_UNIX path)))
 210             (catch 'system-error
 211               (lambda ()
 212                 (bind sock sockaddr)
 213                 (false-if-exception (delete-file path))
 214                 #t)
 215               (lambda args
 216                 (let ((errno (system-error-errno args)))
 217                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 218                         (else (apply throw args))))))))
 219
 220         (pass-if "sendto"
 221           (if (not server-bound?)
 222               (throw 'unresolved)
 223               (let ((client (socket AF_UNIX SOCK_DGRAM 0)))
 224                 (> (sendto client "hello" AF_UNIX path) 0))))
 225
 226         (pass-if "sendto/sockaddr"
 227           (if (not server-bound?)
 228               (throw 'unresolved)
 229               (let ((client (socket AF_UNIX SOCK_DGRAM 0))
 230                     (sockaddr (make-socket-address AF_UNIX path)))
 231                 (> (sendto client "hello" sockaddr) 0))))
 232
 233         (false-if-exception (delete-file path)))))
 234
 235
 236 (if (defined? 'AF_UNIX)
 237     (with-test-prefix "AF_UNIX/SOCK_STREAM"
 238
 239       ;; testing `bind', `listen' and `connect' on stream-oriented sockets
 240
 241       (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
 242             (server-bound? #f)
 243             (server-listening? #f)
 244             (server-pid #f)
 245             (path (temp-file-path)))
 246
 247         (pass-if "bind"
 248           (catch 'system-error
 249             (lambda ()
 250               (bind server-socket AF_UNIX path)
 251               (set! server-bound? #t)
 252               #t)
 253             (lambda args
 254               (let ((errno (system-error-errno args)))
 255                 (cond ((= errno EADDRINUSE) (throw 'unresolved))
 256                       (else (apply throw args)))))))
 257
 258         (pass-if "bind/sockaddr"
 259           (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
 260                  (path (temp-file-path))
 261                  (sockaddr (make-socket-address AF_UNIX path)))
 262             (catch 'system-error
 263               (lambda ()
 264                 (bind sock sockaddr)
 265                 (false-if-exception (delete-file path))
 266                 #t)
 267               (lambda args
 268                 (let ((errno (system-error-errno args)))
 269                   (cond ((= errno EADDRINUSE) (throw 'unresolved))
 270                         (else (apply throw args))))))))
 271
 272         (pass-if "listen"
 273           (if (not server-bound?)
 274               (throw 'unresolved)
 275               (begin
 276                 (listen server-socket 123)
 277                 (set! server-listening? #t)
 278                 #t)))
 279
 280         (if server-listening?
 281             (let ((pid (primitive-fork)))
 282               ;; Spawn a server process.
 283               (case pid
 284                 ((-1) (throw 'unresolved))
 285                 ((0)   ;; the kid:  serve two connections and exit
 286                  (let serve ((conn
 287                               (false-if-exception (accept server-socket)))
 288                              (count 1))
 289                    (if (not conn)
 290                        (exit 1)
 291                        (if (> count 0)
 292                            (serve (false-if-exception (accept server-socket))
 293                                   (- count 1)))))
 294                  (exit 0))
 295                 (else  ;; the parent
 296                  (set! server-pid pid)
 297                  #t))))
 298
 299         (pass-if "connect"
 300           (if (not server-pid)
 301               (throw 'unresolved)
 302               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 303                 (connect s AF_UNIX path)
 304                 #t)))
 305
 306         (pass-if "connect/sockaddr"
 307           (if (not server-pid)
 308               (throw 'unresolved)
 309               (let ((s (socket AF_UNIX SOCK_STREAM 0)))
 310                 (connect s (make-socket-address AF_UNIX path))
 311                 #t)))
 312
 313         (pass-if "accept"
 314           (if (not server-pid)
 315               (throw 'unresolved)
 316               (let ((status (cdr (waitpid server-pid))))
 317                 (eq? 0 (status:exit-val status)))))
 318
 319         (false-if-exception (delete-file path))
 320
 321         #t)))
 322