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