;;;; socket.test --- test socket functions -*- scheme -*- ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, ;;;; 2011, 2013, 2014 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)) ;;; ;;; 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")))))) ;;; ;;; 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)))) (eqv? 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)))) (eqv? 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)) ;; On Linux-based systems, when `ipv6' support is ;; missing (for instance, `ipv6' is loaded and ;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set ;; to 1), the socket call above succeeds but ;; bind(2) fails like this. ((= errno EADDRNOTAVAIL) (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)) ((= errno EADDRNOTAVAIL) (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)))) (eqv? 0 (status:exit-val status))))) #t))) ;; Switch back to the previous directory. (false-if-exception (chdir %curdir))