guile/test-suite/tests/socket.test

;;;; socket.test --- test socket functions     -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008 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 2.1 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 (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 (temp-file-path)
  ;; Return a temporary file path that honors `$TMPDIR', which `tmpnam'
  ;; doesn't do.
  (let ((dir (or (getenv "TMPDIR") "/tmp")))
    (string-append dir "/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)))
		(> (sendto client "hello" AF_UNIX path) 0))))

	(pass-if "sendto/sockaddr"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (let ((client (socket AF_UNIX SOCK_DGRAM 0))
		    (sockaddr (make-socket-address AF_UNIX path)))
		(> (sendto client "hello" 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)))

	(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)))