tests/sockets.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; sockets.lisp --- net.sockets test suite.
   4 ;;;
   5 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27 ;;; The first version of this test suite was based on SB-BSD-SOCKETS'
  28 ;;; to which the following licensing information applies:
  29 ;;;
  30 ;;;    All changes to SBCL since the fork from CMU CL have been
  31 ;;;    released into the public domain in jurisdictions where this is
  32 ;;;    possible, or under the FreeBSD licence where not.
  33
  34 (in-package :iolib-tests)
  35
  36 (in-suite* :net.sockets :in :iolib)
  37
  38 (defparameter *echo-address* (ensure-address #(127 0 0 1)))
  39 (defparameter *echo-port* 7)
  40
  41 ;;;; Addresses
  42
  43 ;;; a real address
  44 (test address-to-vector.1
  45   (is (equalp (address-to-vector "127.0.0.1")
  46               (values #(127 0 0 1) :ipv4))))
  47
  48 ;;; and an address with bit 8 set on some octets
  49 (test address-to-vector.2
  50   (is (equalp (address-to-vector "242.1.211.3")
  51               (values #(242 1 211 3) :ipv4))))
  52
  53 (test address-to-vector.3
  54   (is (equalp (address-to-vector "::")
  55               (values #(0 0 0 0 0 0 0 0) :ipv6))))
  56
  57 ;;; RT: used to return the PARSE-ERROR as a secondary value.
  58 (test string-address-to-vector.1
  59   (is-false (string-address-to-vector "256.0.0.1")))
  60
  61 ;;; RT: should only ignore PARSE-ERRORs.
  62 (test string-address-to-vector.2
  63   (signals type-error
  64     (string-address-to-vector 'not-a-string)))
  65
  66 ;;; RT: should signal a PARSE-ERROR when given an invalid string.
  67 (test ensure-address.1
  68   (signals parse-error
  69     (ensure-address "ff0x::114")))
  70
  71 ;;; ditto
  72 (test ensure-address.2
  73   (signals parse-error
  74     (ensure-address "127.0.256.1")))
  75
  76 (test ensure-address.3
  77   (is-false
  78    (or (ensure-address "ff0x::114" :errorp nil)
  79        (ensure-address "127.0.256.1" :errorp nil))))
  80
  81 (test integer-to-dotted-and-back
  82   (is-true
  83    (every #'(lambda (s) (string= s (integer-to-dotted (dotted-to-integer s))))
  84           '("0.0.255.0" "0.255.255.0" "0.255.255.1"))))
  85
  86 (test integer-to-dotted.1
  87   (is (string= (integer-to-dotted 0)
  88                "0.0.0.0")))
  89
  90 (test integer-to-dotted.2
  91   (is (string= (integer-to-dotted +max-ipv4-value+)
  92                "255.255.255.255")))
  93
  94 (test integer-to-dotted.3
  95   (signals type-error
  96     (integer-to-dotted (1+ +max-ipv4-value+))))
  97
  98 (test integer-to-dotted.4
  99   (signals type-error
 100     (integer-to-dotted -1)))
 101
 102 (test dotted-to-vector.1
 103   (is (equalp (mapcar #'dotted-to-vector '("255.255.255.255" "0.0.0.0" "127.0.0.1"))
 104               '(#(255 255 255 255) #(0 0 0 0) #(127 0 0 1)))))
 105
 106 (test dotted-to-vector.2
 107   (signals parse-error
 108     (dotted-to-vector "127.0.0.0.0")))
 109
 110 (test dotted-to-vector.3
 111   (signals type-error
 112     (dotted-to-vector 'not-a-string)))
 113
 114 (test vector-to-dotted.1
 115   (is (equalp (mapcar #'vector-to-dotted '(#(255 255 255 255) #(0 0 0 0) (127 0 0 1)))
 116               '("255.255.255.255" "0.0.0.0" "127.0.0.1"))))
 117
 118 (test vector-to-dotted.2
 119   (signals type-error
 120     (vector-to-dotted #(127 0 0 256))))
 121
 122 (test address-to-string.1
 123   (is (equalp (mapcar (lambda (x) (address-to-string (make-address x)))
 124                       '(#(127 0 0 1) #(255 255 255 255) #(0 0 0 0 0 0 0 0)
 125                         #(0 0 0 0 0 0 0 1) #(1 0 0 0 0 0 0 0)))
 126               '("127.0.0.1" "255.255.255.255" "::" "::1" "1::"))))
 127
 128 (test vector-to-colon-separated.1
 129   (is (equalp (let ((ip  #(0 0 0 255 255 255 0 0)))
 130                 (values (vector-to-colon-separated ip)
 131                         (vector-to-colon-separated ip :downcase)
 132                         (vector-to-colon-separated ip :upcase)))
 133               (values "::ff:ff:ff:0:" "::ff:ff:ff:0:" "::FF:FF:FF:0:"))))
 134
 135 (test vector-to-colon-separated.2
 136     (is (string= (vector-to-colon-separated #(1 2 3 4 5 0 6 7))
 137                  "1:2:3:4:5::6:7")))
 138
 139 (test vector-to-colon-separated.3
 140   (is (string= (vector-to-colon-separated #(0 2 3 4 5 0 6 7))
 141                ":2:3:4:5::6:7")))
 142
 143 (test vector-to-colon-separated.4
 144   (is (string= (vector-to-colon-separated #(1 2 3 4 5 0 6 0))
 145                "1:2:3:4:5::6:")))
 146
 147 (test colon-separated-to-vector.1
 148   (is (equalp (mapcar #'colon-separated-to-vector
 149                       '(":ff::ff:" "::" "::1" "1::" ":2:3:4:5:6:7:8" "1:2:3:4:5:6:7:"
 150                         ":1::2:" "::127.0.0.1" ":1::127.0.0.1"))
 151               '(#(0 #xff 0 0 0 0 #xff 0)
 152                 #(0 0 0 0 0 0 0 0)
 153                 #(0 0 0 0 0 0 0 1)
 154                 #(1 0 0 0 0 0 0 0)
 155                 #(0 2 3 4 5 6 7 8)
 156                 #(1 2 3 4 5 6 7 0)
 157                 #(0 1 0 0 0 0 2 0)
 158                 #(0 0 0 0 0 0 #x7f00 1)
 159                 #(0 1 0 0 0 0 #x7f00 1)))))
 160
 161 (test address=.1
 162   (is-true (address= +ipv4-loopback+ (make-address #(127 0 0 1)))))
 163
 164 (test address=.2
 165   (is-true (address= +ipv6-loopback+ (ensure-address "::1"))))
 166
 167 (test copy-address.1
 168   (is-true (loop for designator in (list "127.0.0.1" +max-ipv4-value+ "::" "::1")
 169               for addr1 = (ensure-address designator)
 170               for addr2 = (ensure-address designator)
 171               for addr3 = (copy-address addr1)
 172               always (and (address= addr1 addr2)
 173                           (address= addr1 addr3)
 174                           (address= addr2 addr3)))))
 175
 176 (test make-address.1
 177   (signals type-error
 178     (make-address 'not-a-valid-designator)))
 179
 180 (test address.unspecified.1
 181   (is-true (every #'inet-address-unspecified-p
 182                   (mapcar #'ensure-address '("0.0.0.0" "::" "0:0:0:0:0:0:0:0")))))
 183
 184 (test address.loopback.1
 185   (is-true (every #'inet-address-loopback-p
 186                   (mapcar #'ensure-address '("127.0.0.1" "::1" "0:0::1")))))
 187
 188 (test address.multicast.1
 189   (is-true (every #'inet-address-multicast-p
 190                   (mapcar #'ensure-address
 191                           '("224.0.0.0" "224.1.2.3" "232.0.0.127" "239.255.255.255"
 192                             "ff02::2" "ff0a::114" "ff05::1:3")))))
 193
 194 (test address.ipv6-ipv4-mapped.1
 195   (is-true (ipv6-ipv4-mapped-p (ensure-address "::ffff:127.0.0.1"))))
 196
 197 (test address.ipv6.1
 198   (is (equalp (address-to-vector "::1.2.3.4")
 199               (values #(0 0 0 0 0 0 #x0102 #x0304) :ipv6))))
 200
 201 ;;;; Host Lookup
 202
 203 #-no-internet-available
 204 (test lookup-host.1
 205   (is (equalp (multiple-value-bind (addresses truename)
 206                   (lookup-host "a.root-servers.net" :ipv6 nil)
 207                 (values (address-equal-p (car addresses) #(198 41 0 4))
 208                         truename))
 209               (values t "a.root-servers.net"))))
 210
 211 #-no-internet-available
 212 (test lookup-host.2
 213   (is-true (string= (nth-value 1 (lookup-host #(198 41 0 4)))
 214                     "a.root-servers.net")))
 215
 216 ;;; These days lots of people seem to be using DNS servers that don't
 217 ;;; report resolving failures for non-existing domains.  This test
 218 ;;; will fail there.
 219 (test lookup-host.3
 220   (signals resolver-no-name-error
 221     (lookup-host "foo.tninkpad.telent.net.")))
 222
 223 (test lookup-host.4
 224   (is-true (address-equal-p (car (lookup-host #(127 0 0 1) :ipv6 nil))
 225                             #(127 0 0 1))))
 226
 227 (test lookup-host.5
 228   (signals parse-error
 229     (lookup-host #(127 0 0))))
 230
 231 (test lookup-host.6
 232   (signals resolver-no-name-error
 233     (lookup-host #(127 0 0 1) :ipv6 :ipv6)))
 234
 235 ;;;; Service Lookup
 236
 237 (test lookup-service.1
 238   (is (equalp (lookup-service "ssh")
 239               (values 22 "ssh" :tcp))))
 240
 241 (test lookup-service.2
 242   (is (equalp (lookup-service 22 :udp)
 243               (values 22 "ssh" :udp))))
 244
 245 ;;; looks up a reserved service port
 246 (test lookup-service.3
 247   ;; TODO: check for a more specific error.
 248   (signals unknown-service
 249     (lookup-service 1024)))
 250
 251 ;;;; Protocol Lookup
 252
 253 (test lookup-protocol.1
 254   (is (equalp (multiple-value-bind (number name)
 255                   (lookup-protocol "tcp")
 256                 (values number name))
 257               (values 6 "tcp"))))
 258
 259 (test lookup-protocol.2
 260   (is (equalp (multiple-value-bind (number name)
 261                   (lookup-protocol "udp")
 262                 (values number name))
 263               (values 17 "udp"))))
 264
 265 (test lookup-protocol.3
 266   (signals unknown-protocol
 267     (lookup-protocol "nonexistent-protocol")))
 268
 269 (test lookup-protocol.4
 270   (is-true (string= (nth-value 1 (lookup-protocol 6))
 271                     "tcp")))
 272
 273 ;;;; Network Interfaces
 274
 275 (test list-network-interfaces.1
 276   (is-true (<= 1 (length (list-network-interfaces)))))
 277
 278 (test network-interfaces.1
 279   (is-true
 280    (flet ((nif-equal (if1 if2)
 281             (check-type if1 interface)
 282             (check-type if2 interface)
 283             (and (string= (interface-name if1) (interface-name if2))
 284                  (eql (interface-index if1) (interface-index if2)))))
 285      (loop for nif in (list-network-interfaces)
 286         always (nif-equal nif (lookup-interface (interface-name nif)))
 287         always (nif-equal nif (lookup-interface (interface-index nif)))))))
 288
 289 ;;;; Sockets
 290
 291 ;;; RT: don't accept unknown keyword arguments, such as typos.
 292 (test make-socket.1
 293   (signals error
 294     (make-socket :this-kw-arg-doesnt-exist t)))
 295
 296 (test make-socket.2
 297   (is (equalp (with-open-socket (s :family :ipv4)
 298                 (values (socket-connected-p s)
 299                         (socket-open-p s)
 300                         (> (socket-os-fd s) 1)
 301                         (socket-family s)
 302                         (socket-protocol s)))
 303               (values nil t t :ipv4 :default)))) ; why isn't it :TCP?
 304
 305 (test make-socket.3
 306   (is-true (with-open-socket (s :family :ipv4)
 307              (typep s 'socket))))
 308
 309 ;;; Given the functions we've got so far, if you can think of a better
 310 ;;; way to make sure the bind succeeded than trying it twice, let me
 311 ;;; know. 1974 has no special significance, unless you're the same age
 312 ;;; as me.
 313 (test inet.socket-bind.1
 314   (signals socket-address-in-use-error
 315     (with-open-socket (s :family :ipv4 :connect :passive
 316                          :local-host #(127 0 0 1) :local-port 1974)
 317       (with-open-socket (s :family :ipv4 :connect :passive
 318                            :local-host #(127 0 0 1) :local-port 1974)))))
 319
 320 (test sockopt.1
 321   (is-true (with-open-socket (s :family :ipv4)
 322              (setf (socket-option s :reuse-address) t)
 323              (socket-option s :reuse-address))))
 324
 325 ;;; Like READ-SEQUENCE, but returns early if the full quantity of data
 326 ;;; isn't there to be read.  Blocks if no input at all.
 327 (defun read-buf-nonblock (buffer stream)
 328   (let ((eof (gensym)))
 329     (do ((i 0 (1+ i))
 330          (c (read-char stream nil eof)
 331             (read-char-no-hang stream nil eof)))
 332         ((or (>= i (length buffer)) (not c) (eq c eof)) i)
 333       (setf (elt buffer i) c))))
 334
 335 (test simple-tcp-client
 336   (is-true
 337    (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
 338                         :family :ipv4)
 339      (let ((data (make-string 200)))
 340        (format s "here is some text")
 341        (finish-output s)
 342        (let ((data (subseq data 0 (read-buf-nonblock data s))))
 343          ;; (format t "~&Got ~S back from TCP echo server~%" data)
 344          (> (length data) 0))))))
 345
 346 (test sockaddr-return-type
 347   (is-true
 348    (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
 349                         :family :ipv4)
 350      (and (ipv4-address-p (remote-host s))
 351           (numberp (remote-port s))))))
 352
 353 ;;; We don't support streams with UDP sockets ATM.  But when we do,
 354 ;;; let's add a similar test using stream functions.
 355 ;;;
 356 ;;; FIXME: figure out why this test blocks with the inetd services on
 357 ;;; my machines, on both Darwin and Linux/x86-64.  Works with
 358 ;;; echo-server.c though --luis
 359 (test simple-udp-client.1
 360   (is-true
 361    (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
 362                         :type :datagram :family :ipv4)
 363      (send-to s "here is some text")
 364      (let ((nbytes (nth-value 1 (receive-from s :size 200))))
 365        (plusp nbytes)))))
 366
 367 (test simple-udp-client.2
 368   (is-true
 369    (with-open-socket (s :type :datagram :family :ipv4)
 370      (send-to s "here is some more text"
 371               :remote-host *echo-address*
 372               :remote-port *echo-port*)
 373      (let ((nbytes (nth-value 1 (receive-from s :size 200))))
 374        (plusp nbytes)))))
 375
 376 (test simple-local-sockets
 377   (is (string= (let ((file (namestring
 378                             (make-pathname :name "local-socket" :type nil
 379                                            :defaults (truename
 380                                                       (asdf:system-definition-pathname
 381                                                        (asdf:find-system '#:iolib-tests)))))))
 382                  ;; (ignore-errors (delete-file file))
 383                  (with-open-socket (p :family :local :connect :passive :local-filename file)
 384                    (with-open-socket (a :family :local :remote-filename file)
 385                      (format a "local socket test")
 386                      (finish-output a))
 387                    (let ((s (accept-connection p)))
 388                      (prog1 (read-line s)
 389                        (close s)
 390                        (delete-file file)))))
 391                "local socket test")))
 392
 393 (defmacro with-http-stream ((var host port request) &body body)
 394   `(with-open-socket (,var :family :ipv4 :remote-host ,host :remote-port ,port)
 395      (format ,var ,(concatenate 'string request " HTTP/1.0~%~%"))
 396      (finish-output ,var)
 397      ,@body))
 398
 399 #-no-internet-available
 400 (test simple-http-client
 401   (is-true
 402    (with-http-stream (s "www.google.com" 80 "HEAD /")
 403      (let ((data (make-string 200)))
 404        (setf data (subseq data 0 (read-buf-nonblock data s)))
 405        ;; (princ data)
 406        (> (length data) 0)))))
 407
 408 #-no-internet-available
 409 (test sockopt-receive-buffer
 410   ;; on Linux x86, the receive buffer size appears to be doubled in the
 411   ;; kernel: we set a size of x and then getsockopt() returns 2x.
 412   ;; This is why we compare with >= instead of =
 413   (is-true
 414    (with-http-stream (s "www.google.com" 80 "HEAD/")
 415      (setf (socket-option s :receive-buffer) 1975)
 416      (let ((data (make-string 200)))
 417        (setf data (subseq data 0 (read-buf-nonblock data s)))
 418        (and (> (length data) 0)
 419             (>= (socket-option s :receive-buffer) 1975))))))
 420
 421 (test socket-open-p.1
 422   (is-true (with-open-socket (s)
 423              (socket-open-p s))))
 424
 425 (test socket-open-p.2
 426   (is-true (with-open-socket (s :remote-host *echo-address* :remote-port *echo-port*
 427                                 :family :ipv4)
 428              (socket-open-p s))))
 429
 430 (test socket-open-p.3
 431   (is-false (with-open-socket (s)
 432               (close s)
 433               (socket-open-p s))))
 434
 435 ;;; we don't have an automatic test for some of this yet.  There's no
 436 ;;; simple way to run servers and have something automatically connect
 437 ;;; to them as client, unless we spawn external programs.  Then we
 438 ;;; have to start telling people what external programs they should
 439 ;;; have installed.  Which, eventually, we will, but not just yet
 440
 441 ;;; to check with this: can display packets from multiple peers
 442 ;;; peer address is shown correctly for each packet
 443 ;;; packet length is correct
 444 ;;; long (>500 byte) packets have the full length shown (doesn't work)
 445 #-(and)
 446 (defun udp-server (port)
 447   (with-open-socket (s :type :datagram :local-port port)
 448     (loop
 449        (multiple-value-bind (buf len address port)
 450            (receive-from s :size 500)
 451          (format t "Received ~A bytes from ~A:~A - ~A ~%"
 452                  len address port (subseq buf 0 (min 10 len)))))))