Streamline more test suits.
This commit is contained in:
parent
482214e053
commit
6260b4c239
|
@ -1,5 +1,5 @@
|
|||
#lang scheme/base
|
||||
(require file/gzip file/gunzip scheme/file tests/eli-tester)
|
||||
#lang racket/base
|
||||
(require file/gzip file/gunzip racket/file tests/eli-tester)
|
||||
|
||||
(define ((io->str-op io) buf [check-ratio #f])
|
||||
(let* ([b? (bytes? buf)]
|
||||
|
@ -42,6 +42,7 @@
|
|||
(gzip-through-ports in (open-output-bytes) "defalte-me.dat" (current-seconds)))))
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests) (test do (run-tests)))
|
||||
|
||||
|
||||
|
|
|
@ -1,10 +1,11 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require tests/eli-tester
|
||||
(prefix-in gzip: "gzip.rkt")
|
||||
(prefix-in md5: "md5.rkt"))
|
||||
|
||||
(define (tests)
|
||||
(test do (begin (gzip:tests) (md5:tests))))
|
||||
(test do (gzip:tests)
|
||||
do (md5:tests)))
|
||||
|
||||
(tests)
|
||||
|
|
|
@ -1,7 +1,10 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require file/md5 tests/eli-tester)
|
||||
|
||||
(define (run-tests)
|
||||
(provide tests)
|
||||
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(test
|
||||
(md5 #"")
|
||||
=> #"d41d8cd98f00b204e9800998ecf8427e"
|
||||
|
@ -24,6 +27,3 @@
|
|||
(md5 #"" #f)
|
||||
=> #"\324\35\214\331\217\0\262\4\351\200\t\230\354\370B~"
|
||||
))
|
||||
|
||||
(provide tests)
|
||||
(define (tests) (test do (run-tests)))
|
||||
|
|
|
@ -8,6 +8,7 @@
|
|||
(get-bindings)))
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(putenv "REQUEST_METHOD" "GET")
|
||||
(test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3")
|
||||
|
|
|
@ -4,6 +4,7 @@
|
|||
;; cookie tests --- JBM, 2006-12-01
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
;; cookie-test : (cookie -> cookie) string -> test
|
||||
(define (cookie-test fn expected)
|
||||
|
|
|
@ -69,6 +69,7 @@
|
|||
(for-each (check-same-file encode decode line-rx max-w) files)))
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(test
|
||||
do (check-same-all (lambda (i o) (qp-encode-stream i o))
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
(values thd (port->splitstr port)))
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(define cop (open-output-string))
|
||||
(define-values [pasv1-thd pasv1-port] (tcp-serve* (current-output-port) DIRLIST))
|
||||
|
|
|
@ -4,6 +4,7 @@
|
|||
;; a few tests of head.rkt -- JBC, 2006-07-31
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(define test-header
|
||||
(string-append "From: abc\r\nTo: field is\r\n continued\r\n"
|
||||
|
|
|
@ -1,21 +1,28 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require tests/eli-tester
|
||||
(prefix-in ucodec: "uri-codec.rkt")
|
||||
(prefix-in url: "url.rkt")
|
||||
(prefix-in cgi: "cgi.rkt")
|
||||
(prefix-in ftp: "ftp.rkt")
|
||||
(prefix-in head: "head.rkt")
|
||||
(prefix-in cookie: "cookie.rkt")
|
||||
(prefix-in encoders: "encoders.rkt"))
|
||||
(prefix-in ucodec: "uri-codec.rkt")
|
||||
(prefix-in url: "url.rkt")
|
||||
(prefix-in cgi: "cgi.rkt")
|
||||
(prefix-in ftp: "ftp.rkt")
|
||||
(prefix-in head: "head.rkt")
|
||||
(prefix-in cookie: "cookie.rkt")
|
||||
(prefix-in encoders: "encoders.rkt")
|
||||
(prefix-in mime: "mime.rkt")
|
||||
(prefix-in url-port: "url-port.rkt")
|
||||
(prefix-in websocket: "websocket.rkt"))
|
||||
|
||||
(define (tests)
|
||||
(test do (begin (url:tests)
|
||||
(ucodec:tests)
|
||||
(cgi:tests)
|
||||
(ftp:tests)
|
||||
(head:tests)
|
||||
(cookie:tests)
|
||||
(encoders:tests))))
|
||||
(test do (url:tests)
|
||||
do (ucodec:tests)
|
||||
do (ucodec:noels-tests)
|
||||
do (cgi:tests)
|
||||
do (ftp:tests)
|
||||
do (head:tests)
|
||||
do (cookie:tests)
|
||||
do (encoders:tests)
|
||||
do (mime:tests)
|
||||
do (url-port:tests)
|
||||
do (websocket:tests)))
|
||||
|
||||
(tests)
|
||||
|
|
|
@ -1,10 +1,6 @@
|
|||
#lang racket/base
|
||||
(require net/mime)
|
||||
|
||||
(define-syntax-rule (test expect expr)
|
||||
(let ([val expr])
|
||||
(unless (equal? expect val)
|
||||
(error 'test "failed at ~s: ~e" 'expr val))))
|
||||
(require tests/eli-tester net/mime)
|
||||
|
||||
;; This test is based on an example from Jordan Schatz
|
||||
|
||||
|
@ -12,7 +8,7 @@
|
|||
(open-input-string
|
||||
(regexp-replace* #rx"(\r\n|\n)"
|
||||
#<<EOS
|
||||
Server: MochiWeb/1.1 WebMachine/1.9.0 (someone had painted it blue)
|
||||
Server: MochiWeb/1.1 WebMachine/1.9.0 (blah blah)
|
||||
Expires: Fri, 06 Jan 2012 02:01:12 GMT
|
||||
Date: Fri, 06 Jan 2012 01:51:12 GMT
|
||||
Content-Type: multipart/mixed; boundary=9nbsYRvJBLRyuL4VOuuejw9LcAy
|
||||
|
@ -37,29 +33,29 @@ Last-Modified: Wed, 04 Jan 2012 17:12:32 GMT
|
|||
EOS
|
||||
"\r\n")))
|
||||
|
||||
(let* ([analyzed (mime-analyze ip)]
|
||||
[our-entity (message-entity analyzed)]
|
||||
[parts (entity-parts our-entity)]
|
||||
[inner-message (car parts)]
|
||||
[inner-entity (message-entity inner-message)]
|
||||
[body-proc (entity-body inner-entity)]
|
||||
[tmp (open-output-string)])
|
||||
(test '("Server: MochiWeb/1.1 WebMachine/1.9.0 (someone had painted it blue)"
|
||||
"Expires: Fri, 06 Jan 2012 02:01:12 GMT"
|
||||
"Date: Fri, 06 Jan 2012 01:51:12 GMT")
|
||||
(message-fields analyzed))
|
||||
(test 1 (length parts))
|
||||
(test '() body-proc)
|
||||
(test 1 (length (entity-parts inner-entity)))
|
||||
(define sub (message-entity (car (entity-parts inner-entity))))
|
||||
(test 'application (entity-type sub))
|
||||
(test 'json (entity-subtype sub))
|
||||
((entity-body sub) tmp)
|
||||
(test "{\"date\": \"11/02/2011\"}" (get-output-string tmp)))
|
||||
|
||||
(test 'not-there (with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(and (missing-multipart-boundary-parameter? exn)
|
||||
'not-there))])
|
||||
(mime-analyze
|
||||
(open-input-string "Content-Type: multipart/mixed\r\n\r\n"))))
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(define analyzed (mime-analyze ip))
|
||||
(define our-entity (message-entity analyzed))
|
||||
(define parts (entity-parts our-entity))
|
||||
(define inner-message (car parts))
|
||||
(define inner-entity (message-entity inner-message))
|
||||
(define body-proc (entity-body inner-entity))
|
||||
(define tmp (open-output-string))
|
||||
(define sub (message-entity (car (entity-parts inner-entity))))
|
||||
(test (message-fields analyzed)
|
||||
=> '("Server: MochiWeb/1.1 WebMachine/1.9.0 (blah blah)"
|
||||
"Expires: Fri, 06 Jan 2012 02:01:12 GMT"
|
||||
"Date: Fri, 06 Jan 2012 01:51:12 GMT")
|
||||
(length parts) => 1
|
||||
body-proc => '()
|
||||
(length (entity-parts inner-entity)) => 1
|
||||
(entity-type sub) => 'application
|
||||
(entity-subtype sub) => 'json
|
||||
((entity-body sub) tmp)
|
||||
(get-output-string tmp) => "{\"date\": \"11/02/2011\"}"
|
||||
(mime-analyze
|
||||
(open-input-string "Content-Type: multipart/mixed\r\n\r\n"))
|
||||
=error> missing-multipart-boundary-parameter?
|
||||
))
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
(require net/uri-codec tests/eli-tester)
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(define sepmode current-alist-separator-mode)
|
||||
(test (uri-decode "%Pq") => "%Pq"
|
||||
|
@ -72,6 +73,8 @@
|
|||
))
|
||||
|
||||
;; tests adapted from Noel Welsh's original test suite
|
||||
(provide noels-tests)
|
||||
(module+ main (noels-tests))
|
||||
(define (noels-tests)
|
||||
(define (pad2 str)
|
||||
(if (= (string-length str) 1) (string-append "0" str) str))
|
||||
|
|
|
@ -45,18 +45,18 @@
|
|||
(make-tester get-pure-port/headers))
|
||||
(define get-pure/headers/redirect
|
||||
(make-tester (λ (x) (get-pure-port/headers x #:redirections 1))))
|
||||
|
||||
|
||||
(test
|
||||
(get-pure
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n")
|
||||
=>
|
||||
"This is the data in the first chunk and this is the second one"
|
||||
|
||||
|
||||
(get-pure
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one")
|
||||
=>
|
||||
"This is the data in the first chunk and this is the second one"
|
||||
|
||||
|
||||
(get-pure
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n")
|
||||
=>
|
||||
|
@ -66,12 +66,12 @@
|
|||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n")
|
||||
=>
|
||||
"This is the data in the first chunk and this is the second one"
|
||||
|
||||
|
||||
(get-pure/redirect
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one")
|
||||
=>
|
||||
"This is the data in the first chunk and this is the second one"
|
||||
|
||||
|
||||
(get-pure/redirect
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n")
|
||||
=>
|
||||
|
@ -81,32 +81,32 @@
|
|||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n")
|
||||
=>
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n"
|
||||
|
||||
|
||||
(get-pure/headers
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n")
|
||||
=>
|
||||
(values "This is the data in the first chunk and this is the second one"
|
||||
"Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\n")
|
||||
|
||||
|
||||
(get-pure/headers
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one")
|
||||
=>
|
||||
(values "This is the data in the first chunk and this is the second one"
|
||||
"Content-Type: text/plain\r\n")
|
||||
|
||||
|
||||
(get-pure/headers
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n")
|
||||
=>
|
||||
(values "This is the data in the first chand this is the second oneXXXXXXX"
|
||||
"Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\n")
|
||||
|
||||
|
||||
(get-pure/headers
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n")
|
||||
=>
|
||||
(values "This is the data in the first chand this is the second oneXXXXXXX"
|
||||
"Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n")
|
||||
)
|
||||
|
||||
|
||||
(unless skip-actual-redirect?
|
||||
(test
|
||||
(get-pure/redirect
|
||||
|
@ -114,18 +114,21 @@
|
|||
(string-append
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n"
|
||||
"24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n"))
|
||||
|
||||
|
||||
(get-pure/headers/redirect
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n")
|
||||
=>
|
||||
(values "This is the data in the first chand this is the second oneXXXXXXX"
|
||||
"Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n"))))
|
||||
|
||||
(run-tests "http" values #f)
|
||||
(run-tests "https" (let ([ctx (ssl-make-server-context)])
|
||||
(ssl-load-certificate-chain! ctx (collection-file-path "test.pem" "openssl"))
|
||||
(ssl-load-private-key! ctx (collection-file-path "test.pem" "openssl"))
|
||||
(lambda (in out)
|
||||
(ports->ssl-ports in out #:mode 'accept #:context ctx)))
|
||||
#t)
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(test
|
||||
(run-tests "http" values #f)
|
||||
(run-tests "https" (let ([ctx (ssl-make-server-context)])
|
||||
(ssl-load-certificate-chain! ctx (collection-file-path "test.pem" "openssl"))
|
||||
(ssl-load-private-key! ctx (collection-file-path "test.pem" "openssl"))
|
||||
(lambda (in out)
|
||||
(ports->ssl-ports in out #:mode 'accept #:context ctx)))
|
||||
#t)))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme
|
||||
#lang racket
|
||||
(require net/url tests/eli-tester
|
||||
(only-in net/uri-codec current-alist-separator-mode))
|
||||
|
||||
|
@ -354,4 +354,5 @@
|
|||
)
|
||||
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests) (test do (run-tests)))
|
||||
|
|
|
@ -10,89 +10,89 @@
|
|||
|
||||
(define RANDOM-K 100)
|
||||
|
||||
(test
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define o (random 256))
|
||||
(define t (random 256))
|
||||
(define bot (if (o . < . t) o t))
|
||||
(define top (if (o . < . t) t o))
|
||||
(define botc (integer->char bot))
|
||||
(define topc (integer->char top))
|
||||
(test #:failure-prefix (format "~a / ~a" botc topc)
|
||||
(<= bot (char->integer (random-char-between botc topc)) top)))
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(test (char-alphabetic? (random-alpha-char))))
|
||||
|
||||
(count-spaces "") => 0
|
||||
(count-spaces " ") => 3
|
||||
(count-spaces (make-string RANDOM-K #\space)) => RANDOM-K
|
||||
|
||||
(count-spaces "18x 6]8vM;54 *(5: { U1]8 z [ 8") => 12
|
||||
(count-spaces "1_ tx7X d < nw 334J702) 7]o}` 0") => 10
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define len (add1 i))
|
||||
(define s (make-string len #\0))
|
||||
(define how-many (random len))
|
||||
(test (count-spaces (add-spaces how-many s)) => how-many))
|
||||
|
||||
(remove-alphas "A0A") => "0"
|
||||
(remove-alphas "0") => "0"
|
||||
(remove-alphas (make-string RANDOM-K #\A)) => ""
|
||||
|
||||
(remove-alphas "18x 6]8vM;54 *(5: { U1]8 z [ 8") => "1868545188"
|
||||
(remove-alphas "1_ tx7X d < nw 334J702) 7]o}` 0") => "1733470270"
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define s (number->string i))
|
||||
(test (remove-alphas (add-alphas s)) => s))
|
||||
|
||||
(key->number "18x 6]8vM;54 *(5: { U1]8 z [ 8") => 155712099
|
||||
(key->number "1_ tx7X d < nw 334J702) 7]o}` 0") => 173347027
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(test (key->number (number->key i)) => i))
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define-values (k1 k2 k3 ans) (generate-key))
|
||||
(test (handshake-solution k1 k2 k3) => ans))
|
||||
|
||||
(handshake-solution "18x 6]8vM;54 *(5: { U1]8 z [ 8"
|
||||
"1_ tx7X d < nw 334J702) 7]o}` 0"
|
||||
#"Tm[K T2u")
|
||||
=>
|
||||
#"fQJ,fN/4F4!~K~MH"
|
||||
|
||||
(local [(define (test-echo-server)
|
||||
(define conn #f)
|
||||
(define r (number->string (random 1000)))
|
||||
(define shutdown! #f)
|
||||
(define p #f)
|
||||
(define confirm (make-async-channel))
|
||||
|
||||
(test (set! shutdown!
|
||||
(ws-serve #:port 0
|
||||
#:confirmation-channel confirm
|
||||
(λ (wsc _)
|
||||
(let loop ()
|
||||
(define m (ws-recv wsc))
|
||||
(unless (eof-object? m)
|
||||
(ws-send! wsc m)
|
||||
(loop))))))
|
||||
shutdown!
|
||||
(set! p (async-channel-get confirm))
|
||||
p
|
||||
(set! conn (ws-connect (string->url (format "ws://localhost:~a" p))))
|
||||
conn
|
||||
(ws-send! conn r)
|
||||
(ws-recv conn) => r
|
||||
(ws-send! conn "a")
|
||||
(ws-recv conn) => "a"
|
||||
(ws-close! conn)
|
||||
(shutdown!)))]
|
||||
(test
|
||||
#:failure-prefix "old"
|
||||
(parameterize ([framing-mode 'old]) (test-echo-server))
|
||||
#:failure-prefix "new"
|
||||
(parameterize ([framing-mode 'new]) (test-echo-server)))))
|
||||
(provide tests)
|
||||
(module+ main (tests))
|
||||
(define (tests)
|
||||
(test
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define o (random 256))
|
||||
(define t (random 256))
|
||||
(define bot (if (o . < . t) o t))
|
||||
(define top (if (o . < . t) t o))
|
||||
(define botc (integer->char bot))
|
||||
(define topc (integer->char top))
|
||||
(test #:failure-prefix (format "~a / ~a" botc topc)
|
||||
(<= bot (char->integer (random-char-between botc topc)) top)))
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(test (char-alphabetic? (random-alpha-char))))
|
||||
|
||||
(count-spaces "") => 0
|
||||
(count-spaces " ") => 3
|
||||
(count-spaces (make-string RANDOM-K #\space)) => RANDOM-K
|
||||
|
||||
(count-spaces "18x 6]8vM;54 *(5: { U1]8 z [ 8") => 12
|
||||
(count-spaces "1_ tx7X d < nw 334J702) 7]o}` 0") => 10
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define len (add1 i))
|
||||
(define s (make-string len #\0))
|
||||
(define how-many (random len))
|
||||
(test (count-spaces (add-spaces how-many s)) => how-many))
|
||||
|
||||
(remove-alphas "A0A") => "0"
|
||||
(remove-alphas "0") => "0"
|
||||
(remove-alphas (make-string RANDOM-K #\A)) => ""
|
||||
|
||||
(remove-alphas "18x 6]8vM;54 *(5: { U1]8 z [ 8") => "1868545188"
|
||||
(remove-alphas "1_ tx7X d < nw 334J702) 7]o}` 0") => "1733470270"
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define s (number->string i))
|
||||
(test (remove-alphas (add-alphas s)) => s))
|
||||
|
||||
(key->number "18x 6]8vM;54 *(5: { U1]8 z [ 8") => 155712099
|
||||
(key->number "1_ tx7X d < nw 334J702) 7]o}` 0") => 173347027
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(test (key->number (number->key i)) => i))
|
||||
|
||||
(for ([i (in-range RANDOM-K)])
|
||||
(define-values (k1 k2 k3 ans) (generate-key))
|
||||
(test (handshake-solution k1 k2 k3) => ans))
|
||||
|
||||
(handshake-solution "18x 6]8vM;54 *(5: { U1]8 z [ 8"
|
||||
"1_ tx7X d < nw 334J702) 7]o}` 0"
|
||||
#"Tm[K T2u")
|
||||
=> #"fQJ,fN/4F4!~K~MH"
|
||||
|
||||
(local [(define (test-echo-server)
|
||||
(define conn #f)
|
||||
(define r (number->string (random 1000)))
|
||||
(define shutdown! #f)
|
||||
(define p #f)
|
||||
(define confirm (make-async-channel))
|
||||
(test (set! shutdown!
|
||||
(ws-serve #:port 0
|
||||
#:confirmation-channel confirm
|
||||
(λ (wsc _)
|
||||
(let loop ()
|
||||
(define m (ws-recv wsc))
|
||||
(unless (eof-object? m)
|
||||
(ws-send! wsc m)
|
||||
(loop))))))
|
||||
shutdown!
|
||||
(set! p (async-channel-get confirm))
|
||||
p
|
||||
(set! conn (ws-connect (string->url (format "ws://localhost:~a" p))))
|
||||
conn
|
||||
(ws-send! conn r)
|
||||
(ws-recv conn) => r
|
||||
(ws-send! conn "a")
|
||||
(ws-recv conn) => "a"
|
||||
(ws-close! conn)
|
||||
(shutdown!)))]
|
||||
(test #:failure-prefix "old"
|
||||
(parameterize ([framing-mode 'old]) (test-echo-server))
|
||||
#:failure-prefix "new"
|
||||
(parameterize ([framing-mode 'new]) (test-echo-server))))))
|
||||
|
|
|
@ -1,108 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require tests/eli-tester profile/structs profile/analyzer
|
||||
scheme/match scheme/list "topsort.rkt")
|
||||
(require tests/eli-tester "topsort.rkt" "analyze.rkt")
|
||||
|
||||
(define A '(A . #f))
|
||||
(define B '(B . #f))
|
||||
(define C '(C . #f))
|
||||
|
||||
(define (analyze cpu+lists)
|
||||
(profile->sexpr
|
||||
(analyze-samples
|
||||
(cons (car cpu+lists)
|
||||
(map (lambda (x) (append (take x 2) (reverse (drop x 2))))
|
||||
(reverse (cdr cpu+lists)))))))
|
||||
|
||||
(define (profile->sexpr prof)
|
||||
(define (node-id* node)
|
||||
(or (node-id node) (if (node-src node) '??? '*)))
|
||||
(define (edges->sexprs node get get-time)
|
||||
(for/list ([edge (get node)])
|
||||
`(,(node-id* (edge-caller edge)) -> ,(node-id* (edge-callee edge))
|
||||
time= ,(get-time edge)
|
||||
total= ,(edge-total edge))))
|
||||
(define (node->sexpr node)
|
||||
`(,(node-id* node)
|
||||
total= ,(node-total node)
|
||||
self= ,(node-self node)
|
||||
callers: ,@(edges->sexprs node node-callers edge-caller-time)
|
||||
callees: ,@(edges->sexprs node node-callees edge-callee-time)
|
||||
threads= ,(node-thread-ids node)))
|
||||
`(total= ,(profile-total-time prof)
|
||||
samples= ,(profile-sample-number prof)
|
||||
cpu= ,(profile-cpu-time prof)
|
||||
thread-times= ,(profile-thread-times prof)
|
||||
,@(map node->sexpr (cons (profile-*-node prof) (profile-nodes prof)))))
|
||||
|
||||
(test
|
||||
|
||||
do (topological-sort-tests)
|
||||
|
||||
(match (analyze `(10
|
||||
[0 0 ,A]
|
||||
[0 1 ,A]))
|
||||
[`(total= 2 samples= 2 cpu= 10 thread-times= ([0 . 2])
|
||||
[* total= 2 self= 0
|
||||
callers: [A -> * time= 2 total= 2]
|
||||
callees: [* -> A time= 2 total= 2]
|
||||
threads= ()]
|
||||
[A total= 2 self= 2
|
||||
callers: [* -> A time= 2 total= 2]
|
||||
callees: [A -> * time= 2 total= 2]
|
||||
threads= (0)])
|
||||
'ok]
|
||||
[bad (error 'test ">>> ~s" bad)])
|
||||
|
||||
;; demonstrates different edge-caller/lee-times
|
||||
(match (analyze `(10
|
||||
[0 0 ,A ,B ,A]
|
||||
[0 1 ,A ,B ,A]))
|
||||
[`(total= 2 samples= 2 cpu= 10 thread-times= ([0 . 2])
|
||||
[* total= 2 self= 0
|
||||
callers: [A -> * time= 2 total= 2]
|
||||
callees: [* -> A time= 2 total= 2]
|
||||
threads= ()]
|
||||
[A total= 2 self= 2
|
||||
callers: [B -> A time= 2/2 total= 2]
|
||||
[* -> A time= 2/2 total= 2]
|
||||
callees: [A -> B time= 2/2 total= 2]
|
||||
[A -> * time= 2/2 total= 2]
|
||||
threads= (0)]
|
||||
[B total= 2 self= 0
|
||||
callers: [A -> B time= 2 total= 2]
|
||||
callees: [B -> A time= 2 total= 2]
|
||||
threads= (0)])
|
||||
'ok]
|
||||
[bad (error 'test ">>> ~s" bad)])
|
||||
|
||||
(match (analyze `(10
|
||||
[0 0 ,A ,B ,A]
|
||||
[0 1 ,A ,C ,A]
|
||||
[0 2 ,A ,C ,A]
|
||||
[0 3 ,A ,C ,A]))
|
||||
[`(total= 4 samples= 4 cpu= 10 thread-times= ([0 . 4])
|
||||
[* total= 4 self= 0
|
||||
callers: [A -> * time= 4 total= 4]
|
||||
callees: [* -> A time= 4 total= 4]
|
||||
threads= ()]
|
||||
[A total= 4 self= 4
|
||||
callers: [* -> A time= 4/2 total= 4]
|
||||
[C -> A time= 3/2 total= 3]
|
||||
[B -> A time= 1/2 total= 1]
|
||||
callees: [A -> * time= 4/2 total= 4]
|
||||
[A -> C time= 3/2 total= 3]
|
||||
[A -> B time= 1/2 total= 1]
|
||||
threads= (0)]
|
||||
[C total= 3 self= 0
|
||||
callers: [A -> C time= 3 total= 3]
|
||||
callees: [C -> A time= 3 total= 3]
|
||||
threads= (0)]
|
||||
[B total= 1 self= 0
|
||||
callers: [A -> B time= 1 total= 1]
|
||||
callees: [B -> A time= 1 total= 1]
|
||||
threads= (0)])
|
||||
'ok]
|
||||
[bad (error 'test ">>> ~s" bad)])
|
||||
|
||||
)
|
||||
(test do (topological-sort-tests)
|
||||
do (analyze-tests))
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require tests/eli-tester profile/structs profile/utils
|
||||
scheme/list scheme/match)
|
||||
racket/list racket/match)
|
||||
|
||||
(define arrow-sym->times
|
||||
;; arrows with caller/callee times
|
||||
|
@ -67,6 +67,7 @@
|
|||
;; to see a result: (sort-graph '(* -> A)) (exit)
|
||||
|
||||
(provide topological-sort-tests)
|
||||
(module+ main (topological-sort-tests))
|
||||
(define (topological-sort-tests)
|
||||
(test
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user