diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss new file mode 100644 index 0000000000..b55277092c --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss @@ -0,0 +1,29 @@ +(module add06 (lib "lang.ss" "web-server") + (provide start) + + ;; get-number-from-user: string -> number + ;; ask the user for a number + (define (gn msg) + (send/suspend/dispatch + (lambda (embed/url) + `(hmtl (head (title ,(format "Get ~a number" msg))) + (body + (form ([action ,(url->string + (embed/url + (lambda (req) + (string->number + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req))))))))] + [method "post"] + [enctype "application/x-www-form-urlencoded"]) + ,(format "Enter the ~a number to add: " msg) + (input ([type "text"] [name "number"] [value ""])) + (input ([type "submit"])))))))) + + (define (start initial-request) + `(html (head (title "Final Page")) + (body + (h1 "Final Page") + (p ,(format "The answer is ~a" (+ (gn "first") (gn "second")))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/temp.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/temp.ss deleted file mode 100644 index 27f8aaa130..0000000000 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/temp.ss +++ /dev/null @@ -1,18 +0,0 @@ -(module temp (lib "lang.ss" "web-server") - (provide start) - - (define msg (make-parameter "unknown")) - - (define (gn should-be i) - (let/cc k - (printf "~S == ~S~n" should-be (msg)) - i)) - - (define (start) - '(fun . #t) - (printf "12 + 1 = 13 = ~S~n" - (+ - (parameterize ([msg "first"]) - (gn "first" 12)) - (parameterize ([msg "second"]) - (gn "second" 1)))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/toobig.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/toobig.ss deleted file mode 100644 index ea604e239e..0000000000 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/toobig.ss +++ /dev/null @@ -1,37 +0,0 @@ -(module toobig (lib "lang.ss" "web-server") - (provide start) - - (define (get-n) - (let ([req - (send/suspend/url - (lambda (k-url) - `(html (head (title "How many bytes?")) - (body - (form ([action ,(url->string k-url)] - [method "POST"] - [enctype "application/x-www-form-urlencoded"]) - "How many bytes? (Try 1024)" - (input ([type "text"] [name "number"] [value ""])) - (input ([type "submit"])))))))]) - (string->number - (bytes->string/utf-8 - (binding:form-value - (bindings-assq #"number" - (request-bindings/raw req))))))) - - (define (get-bytes) - (let* ([the-bytes - (make-bytes (get-n) (char->integer #\!))] - [req - (send/suspend/url - (lambda (k-url) - `(html (head (title "How are these bytes?")) - (body - (h3 ,(bytes->string/utf-8 the-bytes)) - (a ([href ,(url->string k-url)]) "OK!")))))]) - the-bytes)) - - (define (start initial-request) - `(html (head (title "You got here!")) - (body - (h1 ,(bytes->string/utf-8 (get-bytes))))))) \ No newline at end of file diff --git a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss index f68019075e..666baf7cb5 100644 --- a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss @@ -1,20 +1,138 @@ (module dispatch-lang-test mzscheme - (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))) + (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) + (planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) + (lib "etc.ss") + (lib "list.ss") + (lib "request-structs.ss" "web-server" "private") + (lib "namespace.ss" "web-server" "configuration") + (prefix lang: (lib "dispatch-lang.ss" "web-server" "dispatchers")) + "../util.ss") (provide dispatch-lang-tests) + (define (mkd p) + (lang:make #:url->path (lambda _ (values p url0s)) + #:make-servlet-namespace + (make-make-servlet-namespace) + #:responders-servlet-loading + (lambda (u exn) + ((error-display-handler) (exn-message exn) exn) + (raise exn)) + #:responders-servlet + (lambda (u exn) + ((error-display-handler) (exn-message exn) exn) + (raise exn)))) + (define url0 "http://test.com/servlets/example.ss") + (define url0s (list (build-path "servlets") (build-path "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" + + (test-add-two-numbers + "add-param.ss - Parameters, s/s/u (should fail)" + (build-path example-servlets "add-param.ss")) - ; XXX test web.ss - (test-suite - "web.ss") - - ; XXX test web-extras.ss - (test-suite - "web-extras.ss") + (test-add-two-numbers + "add-simple.ss - Web Parameters, s/s/u" + (build-path example-servlets "add-simple.ss")) - ; XXX test web-cells.ss - (test-suite - "web-cell.ss") + (test-add-two-numbers + "add.ss - s/s/u" + (build-path example-servlets "add.ss")) + + ; XXX + (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? + "add01.ss - no s/s, uri" + (let* ([d (mkd (build-path example-servlets "add01.ss"))] + [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))] + [k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?first=~a" k0 xs) (list (make-binding:form #"first" xs)))))] + [n (first ((sxpath "//p/text()") (call d (format "~a?first=~a&second=~a" k1 xs ys) + (list (make-binding:form #"first" xs) + (make-binding:form #"second" ys)))))]) + n) + (format "The answer is ~a" (+ x y)))) + + (test-add-two-numbers + "add02.ss - s/s/u, uri" + (build-path example-servlets "add02.ss")) + + ; XXX + (test-add-two-numbers + "add03.ss - s/s/h" + (build-path example-servlets "add03.ss")) + + (test-add-two-numbers + "add04.ss - s/s/u" + (build-path example-servlets "add04.ss")) + + (test-add-two-numbers + "add05.ss - extract-proc/url and embed-proc/url" + (build-path example-servlets "add05.ss")) + + (test-add-two-numbers + "add06.ss - send/suspend/dispatch" + (build-path example-servlets "add06.ss")) + + (test-double-counters + "wc-fake.ss - no cells" + (build-path example-servlets "wc-fake.ss")) + + (test-double-counters + "wc.ss - make-web-cell web-cell-ref web-cell-shadow" + (build-path example-servlets "wc.ss")) + + (test-double-counters + "wc-comp.ss - make-web-cell web-cell-ref web-cell-shadow web-cell-component" + (build-path example-servlets "wc-comp.ss")) + + ; XXX test web-extras.ss - redirect/get + ; XXX test web-cells.ss - web-cell? + ; XXX test check-dir.ss quiz-lib.ss quiz01.ss quiz02.ss ))) \ No newline at end of file diff --git a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss index b120c750eb..b53ebe4e16 100644 --- a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss @@ -1,12 +1,8 @@ (module dispatch-servlets-test mzscheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) - ssax:xml->sxml) (planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) (lib "etc.ss") - (lib "url.ss" "net") (lib "list.ss") - (lib "pretty.ss") (lib "request-structs.ss" "web-server" "private") (lib "cache-table.ss" "web-server" "private") (lib "web-server-structs.ss" "web-server" "private") @@ -30,12 +26,6 @@ d) (define url0 "http://test.com/servlets/example.ss") (define url0s (list (build-path "servlets") (build-path "example.ss"))) - (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) (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/")) diff --git a/collects/web-server/tests/util.ss b/collects/web-server/tests/util.ss index af144be09b..cfb0c0dc78 100644 --- a/collects/web-server/tests/util.ss +++ b/collects/web-server/tests/util.ss @@ -1,11 +1,26 @@ (module util mzscheme (require (lib "connection-manager.ss" "web-server" "private") + (only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) + ssax:xml->sxml) + (lib "request-structs.ss" "web-server" "private") + (lib "url.ss" "net") + (lib "pretty.ss") + (lib "list.ss") (lib "timer.ss" "web-server" "private")) (provide make-module-eval make-eval/mod-path make-mock-connection redact - collect) + collect + htxml + call) + + (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) (define (collect d req) (define-values (c i o) (make-mock-connection #""))