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