diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index 6c6988f157..73b652b2e2 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss @@ -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")) diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index 83c9e00dcf..7e6e2d7485 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.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) \ No newline at end of file diff --git a/collects/tests/web-server/dispatchers/servlet-test-util.ss b/collects/tests/web-server/dispatchers/servlet-test-util.ss new file mode 100644 index 0000000000..1bc3612cfc --- /dev/null +++ b/collects/tests/web-server/dispatchers/servlet-test-util.ss @@ -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")))) diff --git a/collects/tests/web-server/util.ss b/collects/tests/web-server/util.ss index 0d83521bec..82bcbaf310 100644 --- a/collects/tests/web-server/util.ss +++ b/collects/tests/web-server/util.ss @@ -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)) diff --git a/collects/web-server/default-web-root/servlets/examples/wc-fake.ss b/collects/web-server/default-web-root/servlets/examples/wc-fake.ss index 22140caf5b..af6b1ae131 100644 --- a/collects/web-server/default-web-root/servlets/examples/wc-fake.ss +++ b/collects/web-server/default-web-root/servlets/examples/wc-fake.ss @@ -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)) diff --git a/collects/web-server/default-web-root/servlets/examples/wc.ss b/collects/web-server/default-web-root/servlets/examples/wc.ss index eadf948870..485e192785 100644 --- a/collects/web-server/default-web-root/servlets/examples/wc.ss +++ b/collects/web-server/default-web-root/servlets/examples/wc.ss @@ -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)) diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss index d465f0d1a9..d52ee1adcd 100644 --- a/collects/web-server/servlet/web.ss +++ b/collects/web-server/servlet/web.ss @@ -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