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     (let ((ssh (lookup-service "ssh")))
 276       (values (service-name ssh)
 277               (service-port ssh)
 278               (service-protocol ssh)))
 279   "ssh" 22 :tcp)
 280
 281 (deftest lookup-service.2
 282     (let ((ssh (lookup-service 22 :udp)))
 283       (values (service-name ssh)
 284               (service-port ssh)
 285               (service-protocol ssh)))
 286   "ssh" 22 :udp)
 287
 288 ;;; looks up a reserved service port
 289 (deftest lookup-service.3
 290     ;; TODO: check for a more specific error.
 291     (with-expected-conditions (unknown-service)
 292       (lookup-service 1024))
 293   t)
 294
 295 ;;;; Protocol Lookup
 296
 297 (deftest lookup-protocol.1
 298     (let ((p (lookup-protocol "tcp")))
 299       (values (protocol-name p)
 300               (protocol-number p)))
 301   "tcp" 6)
 302
 303 (deftest lookup-protocol.2
 304     (let ((p (lookup-protocol "udp")))
 305       (values (protocol-name p)
 306               (protocol-number p)))
 307   "udp" 17)
 308
 309 (deftest lookup-protocol.3
 310     (with-expected-conditions (unknown-protocol)
 311       (lookup-protocol "nonexistent-protocol"))
 312   t)
 313
 314 (deftest lookup-protocol.4
 315     (protocol-name (lookup-protocol 6))
 316   "tcp")
 317
 318 ;;;; Network Interfaces
 319
 320 (deftest list-network-interfaces.1
 321     (<= 1 (length (list-network-interfaces)))
 322   t)
 323
 324 (deftest network-interfaces.1
 325     (flet ((nif-equal (if1 if2)
 326              (check-type if1 interface)
 327              (check-type if2 interface)
 328              (and (string= (interface-name if1) (interface-name if2))
 329                   (eql (interface-index if1) (interface-index if2)))))
 330       (loop for nif in (list-network-interfaces)
 331             always (nif-equal nif (lookup-interface (interface-name nif)))
 332             always (nif-equal nif (lookup-interface (interface-index nif)))))
 333   t)
 334
 335 ;;;; Sockets
 336
 337 ;;; RT: don't accept unknown keyword arguments, such as typos.
 338 (deftest make-socket.1
 339     (with-expected-conditions (error)
 340       (make-socket :this-kw-arg-doesnt-exist t))
 341   t)
 342
 343 (deftest make-socket.2
 344     (with-socket (s :family :ipv4)
 345       (values (socket-connected-p s)
 346               (socket-open-p s)
 347               (> (socket-fd s) 1)
 348               (socket-family s)
 349               (socket-protocol s)))
 350   nil t t :ipv4 :default) ; why isn't it :TCP?
 351
 352 (deftest make-socket.3
 353     (with-socket (s :family :ipv4)
 354       (typep s 'socket))
 355   t)
 356
 357 ;;; Given the functions we've got so far, if you can think of a better
 358 ;;; way to make sure the bind succeeded than trying it twice, let me
 359 ;;; know. 1974 has no special significance, unless you're the same age
 360 ;;; as me.
 361 (deftest inet.socket-bind.1
 362     (with-socket (s :family :ipv4 :local-host #(127 0 0 1) :local-port 1974)
 363       (handler-case
 364           (with-socket (s :family :ipv4 :local-host #(127 0 0 1)
 365                           :local-port 1974)
 366             nil)
 367         (socket-address-in-use-error () t)))
 368   t)
 369
 370 (deftest sockopt.1
 371     (with-socket (s :family :ipv4)
 372       (setf (socket-option s :reuse-address) t)
 373       (socket-option s :reuse-address))
 374   t)
 375
 376 ;;; Like READ-SEQUENCE, but returns early if the full quantity of data
 377 ;;; isn't there to be read.  Blocks if no input at all.
 378 (defun read-buf-nonblock (buffer stream)
 379   (let ((eof (gensym)))
 380     (do ((i 0 (1+ i))
 381          (c (read-char stream nil eof)
 382             (read-char-no-hang stream nil eof)))
 383         ((or (>= i (length buffer)) (not c) (eq c eof)) i)
 384       (setf (elt buffer i) c))))
 385
 386 (deftest simple-tcp-client
 387     (with-socket (s :remote-host *echo-address* :remote-port *echo-port*
 388                     :family :ipv4)
 389       (let ((data (make-string 200)))
 390         (format s "here is some text")
 391         (finish-output s)
 392         (let ((data (subseq data 0 (read-buf-nonblock data s))))
 393           ;; (format t "~&Got ~S back from TCP echo server~%" data)
 394           (> (length data) 0))))
 395   t)
 396
 397 (deftest sockaddr-return-type
 398     (with-socket (s :remote-host *echo-address* :remote-port *echo-port*
 399                     :family :ipv4)
 400       (and (ipv4-address-p (remote-address s))
 401            (numberp (remote-port s))))
 402   t)
 403
 404 ;;; We don't support streams with UDP sockets ATM.  But when we do,
 405 ;;; let's add a similar test using stream functions.
 406 ;;;
 407 ;;; FIXME: figure out why this test blocks with the inetd services on
 408 ;;; my machines, on both Darwin and Linux/x86-64.  Works with
 409 ;;; echo-server.c though --luis
 410 (deftest simple-udp-client.1
 411     (with-socket (s :remote-host *echo-address* :remote-port *echo-port*
 412                     :type :datagram :family :ipv4)
 413       (let ((data (make-array '(200) :element-type '(unsigned-byte 8))))
 414         (socket-send "here is some text" s)
 415         (socket-receive data s)
 416         ;; (format t "~&Got ~S back from UDP echo server~%" data)
 417         (> (length data) 0)))
 418   t)
 419
 420 (deftest simple-udp-client.2
 421     (with-socket (s :type :datagram :family :ipv4)
 422       (let ((data (make-array 100 :element-type '(unsigned-byte 8))))
 423         (socket-send "here is some more text" s
 424                      :remote-address *echo-address*
 425                      :remote-port *echo-port*)
 426         (socket-receive data s)
 427         (> (length data) 0)))
 428   t)
 429
 430 (deftest simple-local-sockets
 431     (let ((file (namestring
 432                  (make-pathname
 433                   :name "local-socket"
 434                   :type nil
 435                   :defaults
 436                   (asdf:system-definition-pathname
 437                    (asdf:find-system '#:iolib-tests))))))
 438       ;; (ignore-errors (delete-file file))
 439       (with-socket (p :family :local :connect :passive :local-filename file)
 440         (with-socket (a :family :local :remote-filename file)
 441           (format a "local socket test")
 442           (finish-output a))
 443         (let ((s (accept-connection p)))
 444           (prog1 (read-line s)
 445             (close s)
 446             (delete-file file)))))
 447   "local socket test")
 448
 449 (defmacro with-http-stream ((var host port request) &body body)
 450   `(with-socket (,var :family :ipv4 :remote-host ,host :remote-port ,port)
 451      (format ,var ,(concatenate 'string request " HTTP/1.0~%~%"))
 452      (finish-output ,var)
 453      ,@body))
 454
 455 #-no-internet-available
 456 (deftest simple-http-client
 457     (handler-case
 458         (with-http-stream (s "www.google.com" 80 "HEAD /")
 459           (let ((data (make-string 200)))
 460             (setf data (subseq data 0 (read-buf-nonblock data s)))
 461             ;; (princ data)
 462             (> (length data) 0)))
 463       (socket-network-unreachable-error () 'network-unreachable))
 464   t)
 465
 466 #-no-internet-available
 467 (deftest sockopt-receive-buffer
 468     ;; on Linux x86, the receive buffer size appears to be doubled in the
 469     ;; kernel: we set a size of x and then getsockopt() returns 2x.
 470     ;; This is why we compare with >= instead of =
 471     (handler-case
 472         (with-http-stream (s "www.google.com" 80 "HEAD/")
 473           (setf (socket-option s :receive-buffer) 1975)
 474           (let ((data (make-string 200)))
 475             (setf data (subseq data 0 (read-buf-nonblock data s)))
 476             (and (> (length data) 0)
 477                  (>= (socket-option s :receive-buffer) 1975))))
 478       (network-unreachable-error () 'network-unreachable))
 479   t)
 480
 481 (deftest socket-open-p.1
 482     (with-socket (s)
 483       (socket-open-p s))
 484   t)
 485
 486 (deftest socket-open-p.2
 487     (with-socket (s :remote-host *echo-address* :remote-port *echo-port*
 488                     :family :ipv4)
 489       (socket-open-p s))
 490   t)
 491
 492 (deftest socket-open-p.3
 493     (with-socket (s)
 494       (close s)
 495       (socket-open-p s))
 496   nil)
 497
 498 ;;; we don't have an automatic test for some of this yet.  There's no
 499 ;;; simple way to run servers and have something automatically connect
 500 ;;; to them as client, unless we spawn external programs.  Then we
 501 ;;; have to start telling people what external programs they should
 502 ;;; have installed.  Which, eventually, we will, but not just yet
 503
 504 ;;; to check with this: can display packets from multiple peers
 505 ;;; peer address is shown correctly for each packet
 506 ;;; packet length is correct
 507 ;;; long (>500 byte) packets have the full length shown (doesn't work)
 508 #-(and)
 509 (defun udp-server (port)
 510   (with-socket (s :type :datagram :local-port port)
 511     (loop
 512      (multiple-value-bind (buf len address port)
 513          (socket-receive s nil 500)
 514        (format t "Received ~A bytes from ~A:~A - ~A ~%"
 515                len address port (subseq buf 0 (min 10 len)))))))