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