New tests
svn: r11484
This commit is contained in:
parent
d55fdaa65e
commit
5d4338ff24
|
@ -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"))
|
||||
|
||||
|
|
|
@ -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
54
collects/tests/web-server/dispatchers/servlet-test-util.ss
Normal 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"))))
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user