;;; -*- Mode: Scheme; scheme48-package: network-tests -*- ;;;; Scheme48 Networking Framework ;;;; Tests ;;; This code is written by Taylor R. Campbell and placed in the Public ;;; Domain. All warranties are disclaimed. (define *tests* '()) (define (make-test name thunk) (cons name thunk)) (define (test-name test) (car test)) (define (test-thunk test) (cdr test)) (define (set-test-thunk! test thunk) (set-cdr! test thunk)) (define (find-test name) (assq name *tests*)) (define (add-test name thunk) (cond ((find-test name) => (lambda (test) (warn "redefining test" name) (set-test-thunk! test thunk))) (else (set! *tests* (cons (make-test name thunk) *tests*))))) (define (delete-test name) (if (pair? *tests*) (if (eq? name (test-name (car *tests*))) (set! *tests* (cdr *tests*)) (let loop ((previous *tests*) (tests (cdr *tests*))) (if (pair? tests) (if (eq? name (test-name (car tests))) (set-cdr! previous (cdr tests)) (loop tests (cdr tests)))))))) (define (run-test test) (call-with-current-continuation (lambda (exit) (with-handler (lambda (condition propagate) propagate (exit `(SIGNALLED ,condition))) (lambda () ((test-thunk test))))))) (define-syntax test-run (syntax-rules () ((TEST-RUN expression) (LAMBDA () expression #F)))) (define-syntax test-equal? (syntax-rules () ((TEST-EQUAL? expected-exp actual-exp) (LAMBDA () (LET ((EXPECTED expected-exp) (ACTUAL actual-exp)) (AND (NOT (EQUAL? EXPECTED ACTUAL)) `(EXPECTED ,EXPECTED GOT ,ACTUAL))))))) (define-syntax test-predicate (syntax-rules () ((TEST-PREDICATE predicate expression) (LAMBDA () (AND (NOT (predicate expression)) 'FAILED))))) (define (run-tests prelude win lose) (let loop ((tests (reverse *tests*)) (won '()) (lost '())) (if (null? tests) (values won lost) (let* ((test (car tests)) (name (test-name test))) (prelude name) (cond ((run-test test) => (lambda (lossage-reason) (lose name lossage-reason) (loop (cdr tests) won (cons (cons name lossage-reason) lost)))) (else (win name) (loop (cdr tests) (cons name won) lost))))))) (define (show-tests) (display ";** RUNNING TESTS") (newline) (receive (won lost) (*show-tests) (display ";** ") (write (length won)) (display " tests passed.") (newline) (display ";** ") (write (length lost)) (display " tests failed") (if (> (length lost) 0) (begin (display ": ") (write lost)) (display ".")) (newline) (force-output (current-output-port)))) (define (*show-tests) (run-tests (lambda (name) (display ";") (display name) (display "...") (let ((len (string-length (symbol->string name)))) (if (< len 40) (display (make-string (- 40 len) #\space))))) (lambda (name) (display "passed") (newline) (force-output (current-output-port))) (lambda (name lossage-reason) (display "failed") (newline) (cond ((not (eq? lossage-reason 'failed)) (display " ") (pretty-print lossage-reason (current-output-port) 2) (newline))) (force-output (current-output-port))))) ;;;; Socket Address Tests (add-test 'socket-address.unix (test-equal? "/tmp/socket" (socket-address->unix-address (unix-address->socket-address "/tmp/socket")))) (define (internet-address-list socket-address) (receive (address port) (socket-address->internet-address socket-address) (list address port))) (add-test 'socket-address.internet (test-equal? '(#x7F000001 1234) (internet-address-list (internet-address->socket-address #x7F000001 1234)))) (add-test 'socket-address->string.unix (test-equal? "/tmp/socket" (socket-address->string (unix-address->socket-address "/tmp/socket")))) (add-test 'socket-address->string.internet (test-equal? "127.0.0.1:1234" (socket-address->string (internet-address->socket-address #x7F000001 1234)))) ;;; IPv6 tests, &c. (define (unwind-protect thunk protect) ;Randomness (let ((exited? #f)) (dynamic-wind (lambda () (values)) thunk (lambda () (if exited? (error "returning twice from UNWIND-PROTECT" `(UNWIND-PROTECT ,thunk ,protect)) (begin (set! exited? #t) (protect))))))) (define (call-with-socket domain type receiver) (let ((socket (create-socket domain type))) (unwind-protect (lambda () (receiver socket)) (lambda () (close-socket socket))))) (define (socket-test domain type) (call-with-socket domain type values)) (add-test 'create-socket.unix-stream (test-run (socket-test protocol-family/unix socket-type/stream))) (add-test 'create-socket.internet-stream (test-run (socket-test protocol-family/internet socket-type/stream))) (add-test 'create-socket.unix-datagram (test-run (socket-test protocol-family/unix socket-type/datagram))) (add-test 'create-socket.internet-datagram (test-run (socket-test protocol-family/internet socket-type/datagram))) (define (socket-option-test domain type option) (call-with-socket domain type (lambda (socket) (socket-option socket level/socket option)))) (add-test 'socket-option.type.unix-stream (test-equal? socket-type/stream (socket-option-test protocol-family/unix socket-type/stream socket/type))) (add-test 'socket-option.type.unix-datagram (test-equal? socket-type/datagram (socket-option-test protocol-family/unix socket-type/datagram socket/type))) (add-test 'socket-option.type.internet-stream (test-equal? socket-type/stream (socket-option-test protocol-family/internet socket-type/stream socket/type))) (add-test 'socket-option.type.internet-datagram (test-equal? socket-type/datagram (socket-option-test protocol-family/internet socket-type/datagram socket/type))) (define (call-with-internet-socket type receiver) (call-with-socket protocol-family/internet type receiver)) (add-test 'listen-socket.internet (test-run (call-with-socket protocol-family/internet socket-type/stream (lambda (socket) (listen-socket socket 5))))) (add-test 'bind-socket.internet.any (test-run (call-with-internet-socket socket-type/stream (lambda (socket) (bind-socket socket (internet-address->socket-address internet-address/any 0)))))) (add-test 'bind-socket.internet.loopback (test-run (call-with-internet-socket socket-type/stream (lambda (socket) (bind-socket socket (internet-address->socket-address internet-address/loopback 0)))))) (add-test 'socket-local-address.internet.any (test-equal? 0 (call-with-internet-socket socket-type/stream (lambda (socket) (bind-socket socket (internet-address->socket-address internet-address/any 0)) (car (internet-address-list (socket-local-address socket))))))) (add-test 'socket-local-address.internet.loopback (test-equal? #x7F000001 (call-with-internet-socket socket-type/stream (lambda (socket) (bind-socket socket (internet-address->socket-address internet-address/loopback 0)) (car (internet-address-list (socket-local-address socket))))))) (define (call-with-local-socket-pair type receiver) (receive (left right) (create-socket-pair protocol-family/unix type) (unwind-protect (lambda () (receiver left right)) (lambda () (close-socket left) (close-socket right))))) (add-test 'socket-pair.stream (test-equal? '(#\l #\r) (call-with-local-socket-pair socket-type/stream (lambda (left right) (write-char #\l (socket:outport left)) (write-char #\r (socket:outport right)) (list (read-char (socket:inport right)) (read-char (socket:inport left))))))) (add-test 'socket-pair.datagram (test-equal? '(from-left from-right) (call-with-local-socket-pair socket-type/datagram (lambda (left right) (write 'from-left (socket:outport left)) (newline (socket:outport left)) (write 'from-right (socket:outport right)) (newline (socket:outport right)) (list (read (socket:inport right)) (read (socket:inport left))))))) (define (call-with-internet-stream-socket-pair receiver) (call-with-socket protocol-family/internet socket-type/stream (lambda (listener-socket) (call-with-socket protocol-family/internet socket-type/stream (lambda (client-socket) (bind-socket listener-socket (internet-address->socket-address 0 0)) (listen-socket listener-socket 5) (let ((address (socket-local-address listener-socket))) (connect-socket-no-wait client-socket address) (receive (server-socket client-address) (accept-connection listener-socket) (unwind-protect (lambda () (if (connect-socket-successful? client-socket) (receiver server-socket client-socket) (error "socket connection unsuccessful"))) (lambda () (close-socket server-socket)))))))))) (add-test 'internet-connection.stream.null (test-run (call-with-internet-stream-socket-pair (lambda (server client) server client (values))))) (add-test 'internet-connection.stream.port-i/o (test-equal? '(from-client from-server) (call-with-internet-stream-socket-pair (lambda (server client) (write 'from-server (socket:outport server)) (newline (socket:outport server)) (write 'from-client (socket:outport client)) (newline (socket:outport client)) (list (read (socket:inport server)) (read (socket:inport client))))))) (define (string->byte-vector string) (let* ((length (string-length string)) (bytev (make-byte-vector length 0))) (copy-bytes! string 0 bytev 0 length) bytev)) (define (call-with-internet-datagram-socket receiver) (call-with-socket protocol-family/internet socket-type/datagram receiver)) (define (call-with-internet-datagram-pair receiver) (call-with-internet-datagram-socket (lambda (left) (bind-socket left (internet-address->socket-address internet-address/loopback 0)) (let ((left-address (socket-local-address left))) (call-with-internet-datagram-socket (lambda (right) (bind-socket right (internet-address->socket-address internet-address/loopback 0)) (let ((right-address (socket-local-address right))) (receiver left left-address right right-address)))))))) (add-test 'internet-datagram.null (test-run (call-with-internet-datagram-pair (lambda (left left-address right right-address) left left-address right right-address (values))))) (add-test 'internet-datagram.i/o (test-equal? (list #x7F #xF7 internet-address/loopback internet-address/loopback) (call-with-internet-datagram-pair (lambda (left left-address right right-address) (send-message left (make-byte-vector 1 #x7F) 0 1 0 right-address) (send-message right (make-byte-vector 1 #xF7) 0 1 0 left-address) (receive (right-msg right-from) (receive-message right 1) (receive (left-msg left-from) (receive-message left 1) (list (byte-vector-ref right-msg 0) (byte-vector-ref left-msg 0) (car (internet-address-list right-from)) (car (internet-address-list left-from)))))))))