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