suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

New tests

Browse Source 
svn: r11484
This commit is contained in:
Jay McCarthy 2008-08-29 18:13:40 +00:00
parent d55fdaa65e
commit 5d4338ff24
7 changed files with 203 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/tests/web-server/dispatchers/dispatch-lang-test.ss
View File

@ -7,6 +7,7 @@
web-server/private/request-structs
web-server/configuration/namespace
(prefix-in lang: web-server/dispatchers/dispatch-lang)
"servlet-test-util.ss"
"../util.ss")
(provide dispatch-lang-tests)
@ -22,51 +23,9 @@
(lambda (u exn)
((error-display-handler) (exn-message exn) exn)
(raise exn))))
(define url0 "http://test.com/servlets/example.ss")
(define example-servlets (build-path (collection-path "web-server") "default-web-root" "htdocs" "lang-servlets/"))
(define (test-add-two-numbers t p)
(let* ([x (random 500)]
[xs (string->bytes/utf-8 (number->string x))]
[y (random 500)]
[ys (string->bytes/utf-8 (number->string y))])
(test-equal?
t
(let* ([d (mkd p)]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
(list (make-binding:form #"number" xs)))))]
[n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
(list (make-binding:form #"number" ys)))))])
n)
(format "The answer is ~a" (+ x y)))))
(define (test-double-counters t p)
(define d (mkd p))
(define (invoke u)
(define sx (call d u empty))
(define ks ((sxpath "//div/div/a/@href/text()") sx))
(values ((sxpath "//div/div/h3/text()") sx)
(first ks)
(second ks)))
(test-equal? t
(let*-values ([(v0.0 0.0+1 0.0+2) (invoke url0)]
; One add
[(v1.0 1.0+1 1.0+2) (invoke 0.0+1)]
[(v0.1 0.1+1 0.1+2) (invoke 0.0+2)]
; Two adds
[(v2.0 2.0+1 2.0+2) (invoke 1.0+1)]
[(v1.1 1.1+1 1.1+2) (invoke 0.1+1)]
[(_v1.1 _1.1+1 _1.1+2) (invoke 1.0+2)]
[(v0.2 0.2+1 0.2+2) (invoke 0.1+2)])
(list v0.0
v1.0 v0.1
v2.0 v1.1 _v1.1 v0.2))
(list (list "0" "0")
(list "1" "0") (list "0" "1")
(list "2" "0") (list "1" "1") (list "1" "1") (list "0" "2"))))
(define dispatch-lang-tests
(test-suite
"Web Language"
@ -86,10 +45,12 @@
n)))
(test-add-two-numbers
mkd
"add-simple.ss - Web Parameters, s/s/u"
(build-path example-servlets "add-simple.ss"))
(test-add-two-numbers
mkd
"add.ss - s/s/u"
(build-path example-servlets "add.ss"))
@ -109,32 +70,39 @@
(format "The answer is: ~a" (+ x y))))
(test-add-two-numbers
mkd
"add02.ss - s/s/u, uri"
(build-path example-servlets "add02.ss"))
; XXX Use kont
#;(test-add-two-numbers
mkd
"add03.ss - s/s/h"
(build-path example-servlets "add03.ss"))
(test-add-two-numbers
mkd
"add04.ss - s/s/u"
(build-path example-servlets "add04.ss"))
(test-add-two-numbers
mkd
"add06.ss - send/suspend/dispatch"
(build-path example-servlets "add06.ss"))
; XXX test something is not d-c
(test-double-counters
mkd
"wc-fake.ss - no cells"
(build-path example-servlets "wc-fake.ss"))
(test-double-counters
mkd
"wc.ss - make-web-cell web-cell-ref web-cell-shadow"
(build-path example-servlets "wc.ss"))
(test-double-counters
mkd
"wc-comp.ss - make-web-cell web-cell-ref web-cell-shadow web-cell-component"
(build-path example-servlets "wc-comp.ss"))

46
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -8,6 +8,7 @@
web-server/private/web-server-structs
web-server/configuration/namespace
(prefix-in servlets: web-server/dispatchers/dispatch-servlets)
"servlet-test-util.ss"
"../util.ss")
(provide dispatch-servlets-tests)
@ -24,27 +25,9 @@
(lambda (u exn)
(raise exn))))
d)
(define url0 "http://test.com/servlets/example.ss")
(define url0s (list (build-path "servlets") (build-path "example.ss")))
(define (test-add-two-numbers t p)
(let* ([x (random 500)]
[xs (string->bytes/utf-8 (number->string x))]
[y (random 500)]
[ys (string->bytes/utf-8 (number->string y))])
(test-equal?
t
(let* ([d (mkd p)]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
(list (make-binding:form #"number" xs)))))]
[n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
(list (make-binding:form #"number" ys)))))])
n)
(format "The sum is ~a" (+ x y)))))
(define test-servlets (build-path (collection-path "web-server") "tests" "servlets"))
(define example-servlets (build-path (collection-path "web-server") "default-web-root" "servlets" "examples/"))
(define example-servlets
(build-path (collection-path "web-server") "default-web-root" "servlets" "examples/"))
(define dispatch-servlets-tests
(test-suite
@ -67,11 +50,11 @@
[t0 (first ((sxpath "//p/text()") (call d url0 empty)))])
t0)
"Hello, Web!")
(test-add-two-numbers "add.ss - send/suspend"
(test-add-two-numbers mkd "add.ss - send/suspend"
(build-path example-servlets "add.ss"))
(test-add-two-numbers "add-v2.ss - send/suspend, version 2"
(test-add-two-numbers mkd "add-v2.ss - send/suspend, version 2"
(build-path example-servlets "add-v2.ss"))
(test-add-two-numbers "add-ssd.ss - send/suspend/dispatch"
(test-add-two-numbers mkd "add-ssd.ss - send/suspend/dispatch"
(build-path example-servlets "add-ssd.ss"))
(test-equal? "count.ss - state"
(let* ([d (mkd (build-path example-servlets "count.ss"))]
@ -112,6 +95,17 @@
(list "Expired"
"Done."
"Expired"))
(test-double-counters
mkd
"wc-fake.ss - no cells"
(build-path example-servlets "wc-fake.ss"))
(test-double-counters
mkd
"wc.ss - make-web-cell web-cell-ref web-cell-shadow"
(build-path example-servlets "wc.ss"))
; XXX Broken
#;(test-equal? "adjust.ss - adjust-timeout!"
(let* ([d (mkd (build-path example-servlets "adjust.ss"))]
@ -119,3 +113,9 @@
(sleep 3)
(call d k0 empty))
"#"))))
; Comment in to run tests
#;(require #;(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2))
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
#;(test/text-ui dispatch-servlets-tests)

54
collects/tests/web-server/dispatchers/servlet-test-util.ss Normal file
View File

@ -0,0 +1,54 @@
#lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
mzlib/list
web-server/private/request-structs
"../util.ss")
(provide test-add-two-numbers
test-double-counters
url0
url0s)
(define url0 "http://test.com/servlets/example.ss")
(define url0s (list (build-path "servlets") (build-path "example.ss")))
(define (test-add-two-numbers mkd t p)
(let* ([x (random 500)]
[xs (string->bytes/utf-8 (number->string x))]
[y (random 500)]
[ys (string->bytes/utf-8 (number->string y))])
(test-equal?
t
(let* ([d (mkd p)]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
(list (make-binding:form #"number" xs)))))]
[n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
(list (make-binding:form #"number" ys)))))])
n)
(format "The answer is ~a" (+ x y)))))
(define (test-double-counters mkd t p)
(define d (mkd p))
(define (invoke u)
(define sx (call d u empty))
(define ks ((sxpath "//div/div/a/@href/text()") sx))
(values ((sxpath "//div/div/h3/text()") sx)
(first ks)
(second ks)))
(test-equal? t
(let*-values ([(v0.0 0.0+1 0.0+2) (invoke url0)]
; One add
[(v1.0 1.0+1 1.0+2) (invoke 0.0+1)] ; XXX infinite loop after this
[(v0.1 0.1+1 0.1+2) (invoke 0.0+2)]
; Two adds
[(v2.0 2.0+1 2.0+2) (invoke 1.0+1)]
[(v1.1 1.1+1 1.1+2) (invoke 0.1+1)]
[(_v1.1 _1.1+1 _1.1+2) (invoke 1.0+2)]
[(v0.2 0.2+1 0.2+2) (invoke 0.1+2)])
(list v0.0
v1.0 v0.1
v2.0 v1.1 _v1.1 v0.2))
(list (list "0" "0")
(list "1" "0") (list "0" "1")
(list "2" "0") (list "1" "1") (list "1" "1") (list "0" "2"))))

57
collects/tests/web-server/util.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang scheme
(require (for-syntax scheme/base)
web-server/private/connection-manager
(only-in (planet "ssax.ss" ("lizorkin" "ssax.plt" 2 0))
@ -20,16 +20,63 @@
(define (call d u bs)
(htxml (collect d (make-request 'get (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1"))))
(define (htxml bs)
(define sx (ssax:xml->sxml (open-input-bytes (second (regexp-match #"^.+\r\n\r\n(.+)$" bs))) empty))
(pretty-print sx)
sx)
(match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
[(list _ s)
(define sx (ssax:xml->sxml (open-input-bytes s) empty))
(pretty-print sx)
sx]
[_
(error 'html "Given ~S~n" bs)]))
; This causes infinite loop. I will try putting it in a thread like on the real server
#;(define (collect d req)
(define-values (c i o) (make-mock-connection #""))
(parameterize ([current-server-custodian (current-custodian)])
(d c req))
(redact (get-output-bytes o)))
; This causes errors because s/s/d tries to jump the barrier, but I have no idea why
(define (collect d req)
(define-values (c i o) (make-mock-connection #""))
(parameterize ([current-server-custodian (current-custodian)])
(d c req))
(call-with-continuation-barrier
(lambda ()
(d c req))))
(redact (get-output-bytes o)))
; This causes a dead lock, even though the log shows that the channel should sync
(define (channel-put* c v)
(printf "+CHAN ~S PUT: ~S~n" c v)
(channel-put c v)
(printf "-CHAN ~S PUT: ~S~n" c v))
(define (channel-get* c)
(printf "+CHAN ~S GET~n" c)
(let ([v (channel-get c)])
(printf "-CHAN ~S GET: ~S~n" c v)
v))
#;(define (collect d req)
(define chan (make-channel))
(define-values (c i o) (make-mock-connection #""))
(parameterize ([current-server-custodian (current-custodian)])
(thread
(lambda ()
(d c req)
(channel-put* chan (get-output-bytes o))
)))
(redact (channel-get* chan)))
; This causes an error, because the output bytes are #""
#;(define (collect d req)
(define-values (c i o) (make-mock-connection #""))
(parameterize ([current-server-custodian (current-custodian)])
(thread-wait
(thread
(lambda ()
(d c req)))))
(redact (get-output-bytes o)))
(define (make-mock-connection ib)
(define ip (open-input-bytes ib))
(define op (open-output-bytes))

13
collects/web-server/default-web-root/servlets/examples/wc-fake.ss
View File

@ -9,15 +9,19 @@
(define counter2 0)
(send/suspend/dispatch
(lambda (embed/url)
(let*-values ([(inc1 next-counter1 next-counter2) (include-counter counter1 counter2 embed/url)]
[(inc2 next-counter2 next-counter1) (include-counter next-counter2 next-counter1 embed/url)])
(let*-values ([(inc1 next-counter1 next-counter2)
(include-counter counter1 counter2 embed/url)]
[(inc2 next-counter2 next-counter1)
(include-counter next-counter2 next-counter1 embed/url)])
`(html
(body (h2 "Web Cell Test")
(div (h3 "First") ,(inc1 next-counter1 next-counter2))
(div (h3 "Second") ,(inc2 next-counter2 next-counter1))))))))
(define (include-counter my-counter other-counter embed/url)
(let/cc k
; XXX This shouldn't be necessary (but is for testing, not in production)
(call-with-current-continuation
(lambda (k)
(letrec ([include
(lambda (next-my-counter next-other-counter)
`(div (h3 ,(number->string next-my-counter))
@ -30,4 +34,5 @@
"Increment")))])
(values include
my-counter
other-counter))))
other-counter)))
servlet-prompt))

33
collects/web-server/default-web-root/servlets/examples/wc.ss
View File

@ -26,18 +26,21 @@
(make-web-cell 0))
(define (include-counter a-counter)
(let/cc k
(define (generate)
(k
(lambda (embed/url)
`(div (h3 ,(number->string (web-cell-ref a-counter)))
(a ([href ,(embed/url
(lambda _
; A new frame has been created
(define last (web-cell-ref a-counter))
; It is a child of the parent frame, so we can inspect the value
(web-cell-shadow a-counter (add1 last))
; The new frame has been modified
(generate)))])
"+")))))
(generate)))
; XXX This shouldn't be necessary (but is for testing, not in production)
(call-with-current-continuation
(lambda (k)
(define (generate)
(k
(lambda (embed/url)
`(div (h3 ,(number->string (web-cell-ref a-counter)))
(a ([href ,(embed/url
(lambda _
; A new frame has been created
(define last (web-cell-ref a-counter))
; It is a child of the parent frame, so we can inspect the value
(web-cell-shadow a-counter (add1 last))
; The new frame has been modified
(generate)))])
"+")))))
(generate))
servlet-prompt))

72
collects/web-server/servlet/web.ss
View File

@ -12,6 +12,8 @@
"../private/response-structs.ss"
"../private/request-structs.ss")
(provide servlet-prompt)
;; ************************************************************
;; HELPERS
(provide/contract
@ -114,51 +116,51 @@
;; send a response and apply the continuation to the next request
(define (send/suspend response-generator
[expiration-handler (current-servlet-continuation-expiration-handler)])
(with-frame-after
(call-with-composable-continuation
(lambda (k)
(define instance-id (current-servlet-instance-id))
(define ctxt (current-execution-context))
(define k-embedding ((manager-continuation-store! (current-servlet-manager))
instance-id
(make-custodian-box (current-custodian) k)
expiration-handler))
(define k-url ((current-url-transform)
(embed-ids
(list* instance-id k-embedding)
(request-uri (execution-context-request ctxt)))))
(send/back (response-generator k-url)))
servlet-prompt)))
(with-frame-after
(call-with-composable-continuation
(lambda (k)
(define instance-id (current-servlet-instance-id))
(define ctxt (current-execution-context))
(define k-embedding ((manager-continuation-store! (current-servlet-manager))
instance-id
(make-custodian-box (current-custodian) k)
expiration-handler))
(define k-url ((current-url-transform)
(embed-ids
(list* instance-id k-embedding)
(request-uri (execution-context-request ctxt)))))
(send/back (response-generator k-url)))
servlet-prompt)))
;; send/forward: (url -> response) [(request -> response)] -> request
;; clear the continuation table, then behave like send/suspend
(define (send/forward response-generator
[expiration-handler (current-servlet-continuation-expiration-handler)])
(clear-continuation-table!)
(send/suspend response-generator expiration-handler))
(clear-continuation-table!)
(send/suspend response-generator expiration-handler))
;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request
;; send/back a response generated from a procedure that may convert
;; procedures to continuation urls
(define (send/suspend/dispatch response-generator)
; This restores the tail position.
; Note: Herman's syntactic strategy would fail without the new-request capture.
; (Moving this to the tail-position is not possible anyway, by the way.)
(let ([thunk
(call-with-current-continuation
(lambda (k0)
(send/back
(response-generator
(lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/ec k1
; This makes the second continuation captured by send/suspend smaller
(call-with-continuation-prompt
(lambda ()
(let ([new-request (send/suspend k1 expiration-handler)])
(k0 (lambda () (proc new-request)))))
servlet-prompt))))))
servlet-prompt)])
(thunk)))
; This restores the tail position.
; Note: Herman's syntactic strategy would fail without the new-request capture.
; (Moving this to the tail-position is not possible anyway, by the way.)
(let ([thunk
(call-with-current-continuation
(lambda (k0)
(send/back
(response-generator
(lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/ec k1
; This makes the second continuation captured by send/suspend smaller
(call-with-continuation-prompt
(lambda ()
(let ([new-request (send/suspend k1 expiration-handler)])
(k0 (lambda () (proc new-request)))))
servlet-prompt))))))
servlet-prompt)])
(thunk)))
;; ************************************************************
;; HIGHER-LEVEL EXPORTS