guile/test-suite/tests/socket.test

;;;; socket.test --- test socket functions     -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
;;;;   2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-socket)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-26)
  #:use-module (test-suite lib))



;;;
;;; htonl
;;;

(if (defined? 'htonl)
    (with-test-prefix "htonl"

      (pass-if "0" (eqv? 0 (htonl 0)))

      (pass-if-exception "-1" exception:out-of-range
        (htonl -1))

      ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
      ;; an overflow for values 2^32 <= x < 2^63
      (pass-if-exception "2^32" exception:out-of-range
        (htonl (ash 1 32)))

      (pass-if-exception "2^1024" exception:out-of-range
        (htonl (ash 1 1024)))))


;;;
;;; inet-ntop
;;;

(if (defined? 'inet-ntop)
    (with-test-prefix "inet-ntop"

      (with-test-prefix "ipv6"
	(pass-if "0"
	  (string? (inet-ntop AF_INET6 0)))

	(pass-if "2^128-1"
	  (string? (inet-ntop AF_INET6 (1- (ash 1 128)))))

	(pass-if-exception "-1" exception:out-of-range
	  (inet-ntop AF_INET6 -1))

	(pass-if-exception "2^128" exception:out-of-range
	  (inet-ntop AF_INET6 (ash 1 128)))

	(pass-if-exception "2^1024" exception:out-of-range
	  (inet-ntop AF_INET6 (ash 1 1024))))))

;;;
;;; inet-pton
;;;

(if (defined? 'inet-pton)
    (with-test-prefix "inet-pton"

      (with-test-prefix "ipv6"
	(pass-if "00:00:00:00:00:00:00:00"
	  (eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00")))

	(pass-if "0:0:0:0:0:0:0:1"
	  (eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1")))

	(pass-if "::1"
	  (eqv? 1 (inet-pton AF_INET6 "::1")))

	(pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	  (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
		(inet-pton AF_INET6
			   "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))

	(pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
	  (eqv? #xF0000000000000000000000000000000
		(inet-pton AF_INET6
			   "F000:0000:0000:0000:0000:0000:0000:0000")))

	(pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
	  (eqv? #x0F000000000000000000000000000000
		(inet-pton AF_INET6
			   "0F00:0000:0000:0000:0000:0000:0000:0000")))

	(pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
	  (eqv? #xF0
		(inet-pton AF_INET6
			   "0000:0000:0000:0000:0000:0000:0000:00F0"))))))

(if (defined? 'inet-ntop)
    (with-test-prefix "inet-ntop"

      (with-test-prefix "ipv4"
	(pass-if "127.0.0.1"
	  (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))

      (if (defined? 'AF_INET6)
	  (with-test-prefix "ipv6"
	    (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	      (string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
			   (inet-ntop AF_INET6 (- (expt 2 128) 1))))

	    (pass-if "::1"
	      (equal? "::1" (inet-ntop AF_INET6 1)))))))


;;;
;;; make-socket-address
;;;

(with-test-prefix "make-socket-address"
  (if (defined? 'AF_INET)
      (pass-if "AF_INET"
	(let ((sa (make-socket-address AF_INET 123456 80)))
	  (and (= (sockaddr:fam  sa) AF_INET)
	       (= (sockaddr:addr sa) 123456)
	       (= (sockaddr:port sa) 80)))))

  (if (defined? 'AF_INET6)
      (pass-if "AF_INET6"
	;; Since the platform doesn't necessarily support `scopeid', we won't
        ;; test it.
	(let ((sa* (make-socket-address AF_INET6 123456 80 1))
	      (sa+ (make-socket-address AF_INET6 123456 80)))
	  (and (= (sockaddr:fam  sa*) (sockaddr:fam  sa+) AF_INET6)
	       (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456)
	       (= (sockaddr:port sa*) (sockaddr:port sa+) 80)
	       (= (sockaddr:flowinfo sa*) 1)))))

  (if (defined? 'AF_UNIX)
      (pass-if "AF_UNIX"
	(let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket")))
	  (and (= (sockaddr:fam sa) AF_UNIX)
	       (string=? (sockaddr:path sa) "/tmp/unix-socket"))))))

;;;
;;; ntohl
;;;

(if (defined? 'ntohl)
    (with-test-prefix "ntohl"

      (pass-if "0" (eqv? 0 (ntohl 0)))

      (pass-if-exception "-1" exception:out-of-range
        (ntohl -1))

      ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
      ;; an overflow for values 2^32 <= x < 2^63
      (pass-if-exception "2^32" exception:out-of-range
        (ntohl (ash 1 32)))

      (pass-if-exception "2^1024" exception:out-of-range
        (ntohl (ash 1 1024)))))



;;;
;;; AF_UNIX sockets and `make-socket-address'
;;;

(define %tmpdir
  ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
  (or (getenv "TMPDIR") "/tmp"))

(define %curdir
  ;; Remember the current working directory.
  (getcwd))

;; Temporarily cd to %TMPDIR.  The goal is to work around path name
;; limitations, which can lead to exceptions like:
;;
;;  (misc-error "scm_to_sockaddr"
;;              "unix address path too long: ~A"
;;              ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
;;              #f)
(chdir %tmpdir)

(define (temp-file-path)
  ;; Return a temporary file name, assuming the current directory is %TMPDIR.
  (string-append "guile-test-socket-"
                 (number->string (current-time)) "-"
                 (number->string (random 100000))))


(if (defined? 'AF_UNIX)
    (with-test-prefix "AF_UNIX/SOCK_DGRAM"

      ;; testing `bind' and `sendto' and datagram sockets

      (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
	    (server-bound? #f)
	    (path (temp-file-path)))

	(pass-if "bind"
	  (catch 'system-error
	    (lambda ()
	      (bind server-socket AF_UNIX path)
	      (set! server-bound? #t)
	      #t)
	    (lambda args
	      (let ((errno (system-error-errno args)))
		(cond ((= errno EADDRINUSE) (throw 'unresolved))
		      (else (apply throw args)))))))

	(pass-if "bind/sockaddr"
	  (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
		 (path (temp-file-path))
		 (sockaddr (make-socket-address AF_UNIX path)))
	    (catch 'system-error
	      (lambda ()
		(bind sock sockaddr)
		(false-if-exception (delete-file path))
		#t)
	      (lambda args
		(let ((errno (system-error-errno args)))
		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
			(else (apply throw args))))))))

	(pass-if "sendto"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (let ((client  (socket AF_UNIX SOCK_DGRAM 0))
                    (message (string->utf8 "hello")))
		(> (sendto client message AF_UNIX path) 0))))

	(pass-if "sendto/sockaddr"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (let ((client   (socket AF_UNIX SOCK_DGRAM 0))
                    (message  (string->utf8 "hello"))
		    (sockaddr (make-socket-address AF_UNIX path)))
		(> (sendto client message sockaddr) 0))))

	(false-if-exception (delete-file path)))))


(if (defined? 'AF_UNIX)
    (with-test-prefix "AF_UNIX/SOCK_STREAM"

      ;; testing `bind', `listen' and `connect' on stream-oriented sockets

      (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
	    (server-bound? #f)
	    (server-listening? #f)
	    (server-pid #f)
	    (path (temp-file-path)))

	(pass-if "bind"
	  (catch 'system-error
	    (lambda ()
	      (bind server-socket AF_UNIX path)
	      (set! server-bound? #t)
	      #t)
	    (lambda args
	      (let ((errno (system-error-errno args)))
		(cond ((= errno EADDRINUSE) (throw 'unresolved))
		      (else (apply throw args)))))))

	(pass-if "bind/sockaddr"
	  (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
		 (path (temp-file-path))
		 (sockaddr (make-socket-address AF_UNIX path)))
	    (catch 'system-error
	      (lambda ()
		(bind sock sockaddr)
		(false-if-exception (delete-file path))
		#t)
	      (lambda args
		(let ((errno (system-error-errno args)))
		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
			(else (apply throw args))))))))

	(pass-if "listen"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (begin
		(listen server-socket 123)
		(set! server-listening? #t)
		#t)))

	(force-output (current-output-port))
	(force-output (current-error-port))
	(if server-listening?
	    (let ((pid (primitive-fork)))
	      ;; Spawn a server process.
	      (case pid
		((-1) (throw 'unresolved))
		((0)   ;; the kid:  serve two connections and exit
		 (let serve ((conn
			      (false-if-exception (accept server-socket)))
			     (count 1))
		   (if (not conn)
		       (exit 1)
		       (if (> count 0)
			   (serve (false-if-exception (accept server-socket))
				  (- count 1)))))
		 (exit 0))
		(else  ;; the parent
		 (set! server-pid pid)
		 #t))))

	(pass-if "connect"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_UNIX SOCK_STREAM 0)))
		(connect s AF_UNIX path)
		#t)))

	(pass-if "connect/sockaddr"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_UNIX SOCK_STREAM 0)))
		(connect s (make-socket-address AF_UNIX path))
		#t)))

	(pass-if "accept"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((status (cdr (waitpid server-pid))))
		(eq? 0 (status:exit-val status)))))

	(false-if-exception (delete-file path))

	#t)


      ;; Testing `send', `recv!' & co. on stream-oriented sockets (with
      ;; a bit of duplication with the above.)

      (let ((server-socket     (socket AF_UNIX SOCK_STREAM 0))
            (server-bound?     #f)
            (server-listening? #f)
            (server-pid        #f)
            (message           "hello, world!")
            (path              (temp-file-path)))

        (define (sub-bytevector bv len)
          (let ((c (make-bytevector len)))
            (bytevector-copy! bv 0 c 0 len)
            c))

        (pass-if "bind (bis)"
          (catch 'system-error
            (lambda ()
              (bind server-socket AF_UNIX path)
              (set! server-bound? #t)
              #t)
            (lambda args
              (let ((errno (system-error-errno args)))
                (cond ((= errno EADDRINUSE) (throw 'unresolved))
                      (else (apply throw args)))))))

        (pass-if "listen (bis)"
          (if (not server-bound?)
              (throw 'unresolved)
              (begin
                (listen server-socket 123)
                (set! server-listening? #t)
                #t)))

        (force-output (current-output-port))
        (force-output (current-error-port))
        (if server-listening?
            (let ((pid (primitive-fork)))
              ;; Spawn a server process.
              (case pid
                ((-1) (throw 'unresolved))
                ((0)   ;; the kid: send MESSAGE and exit
                 (exit
                  (false-if-exception
                   (let ((conn (car (accept server-socket)))
                         (bv   (string->utf8 message)))
                     (= (bytevector-length bv)
                        (send conn bv))))))
                (else  ;; the parent
                 (set! server-pid pid)
                 #t))))

        (pass-if "recv!"
          (if (not server-pid)
              (throw 'unresolved)
              (let ((s (socket AF_UNIX SOCK_STREAM 0)))
                (connect s AF_UNIX path)
                (let* ((buf      (make-bytevector 123))
                       (received (recv! s buf)))
                  (string=? (utf8->string (sub-bytevector buf received))
                            message)))))

        (pass-if "accept (bis)"
          (if (not server-pid)
              (throw 'unresolved)
              (let ((status (cdr (waitpid server-pid))))
                (eq? 0 (status:exit-val status)))))

        (false-if-exception (delete-file path))

        #t)))


(if (defined? 'AF_INET6)
    (with-test-prefix "AF_INET6/SOCK_STREAM"

      ;; testing `bind', `listen' and `connect' on stream-oriented sockets

      (let ((server-socket
             ;; Some platforms don't support this protocol/family combination.
             (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
	    (server-bound? #f)
	    (server-listening? #f)
	    (server-pid #f)
	    (ipv6-addr 1)		; ::1
	    (server-port 8889)
	    (client-port 9998))

	(pass-if "bind"
          (if (not server-socket)
              (throw 'unresolved))
	  (catch 'system-error
	    (lambda ()
	      (bind server-socket AF_INET6 ipv6-addr server-port)
	      (set! server-bound? #t)
	      #t)
	    (lambda args
	      (let ((errno (system-error-errno args)))
		(cond ((= errno EADDRINUSE) (throw 'unresolved))
		      (else (apply throw args)))))))

	(pass-if "bind/sockaddr"
	  (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
		 (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
            (if (not sock)
                (throw 'unresolved))
	    (catch 'system-error
	      (lambda ()
		(bind sock sockaddr)
		#t)
	      (lambda args
		(let ((errno (system-error-errno args)))
		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
			(else (apply throw args))))))))

	(pass-if "listen"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (begin
		(listen server-socket 123)
		(set! server-listening? #t)
		#t)))

	(force-output (current-output-port))
	(force-output (current-error-port))
	(if server-listening?
	    (let ((pid (primitive-fork)))
	      ;; Spawn a server process.
	      (case pid
		((-1) (throw 'unresolved))
		((0)   ;; the kid:  serve two connections and exit
		 (let serve ((conn
			      (false-if-exception (accept server-socket)))
			     (count 1))
		   (if (not conn)
		       (exit 1)
		       (if (> count 0)
			   (serve (false-if-exception (accept server-socket))
				  (- count 1)))))
		 (exit 0))
		(else  ;; the parent
		 (set! server-pid pid)
		 #t))))

	(pass-if "connect"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_INET6 SOCK_STREAM 0)))
		(connect s AF_INET6 ipv6-addr server-port)
		#t)))

	(pass-if "connect/sockaddr"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_INET6 SOCK_STREAM 0)))
		(connect s (make-socket-address AF_INET6 ipv6-addr server-port))
		#t)))

	(pass-if "accept"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((status (cdr (waitpid server-pid))))
		(eq? 0 (status:exit-val status)))))

	#t)))

;; Switch back to the previous directory.
(false-if-exception (chdir %curdir))