diff --git a/collects/web-server/default-web-root/servlets/examples/add-module.ss b/collects/web-server/default-web-root/servlets/examples/add-module.ss deleted file mode 100644 index 7c2d9e9746..0000000000 --- a/collects/web-server/default-web-root/servlets/examples/add-module.ss +++ /dev/null @@ -1,30 +0,0 @@ -(module add-module mzscheme - (require (lib "servlet.ss" "web-server") - (lib "date.ss")) - (provide (all-defined)) - - (define interface-version 'v1) - (define timeout 30) - - ; request-number : str -> num - (define (request-number which-number) - (string->number - (extract-binding/single - 'number - (request-bindings (send/suspend (build-request-page which-number)))))) - - ; build-request-page : str -> str -> response - (define (build-request-page which-number) - (lambda (k-url) - `(html (head (title "Enter a Number to Add")) - (body ([bgcolor "white"]) - (form ([action ,k-url] [method "post"]) - "Enter the " ,which-number " number to add: " - (input ([type "text"] [name "number"] [value ""])) - (input ([type "submit"] [name "enter"] [value "Enter"]))))))) - - (define (start initial-request) - `(html (head (title "Sum")) - (body ([bgcolor "white"]) - (p "The sum is " - ,(number->string (+ (request-number "first") (request-number "second")))))))) diff --git a/collects/web-server/tests/dispatchers/dispatch-files-test.ss b/collects/web-server/tests/dispatchers/dispatch-files-test.ss index 57c60a6bc7..da9e9289ac 100644 --- a/collects/web-server/tests/dispatchers/dispatch-files-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-files-test.ss @@ -32,11 +32,6 @@ #:mime-types-path (build-path "/etc/httpd/mime.types") #:indices (list (if i? (file-name-from-path tmp-file) not-there)))) - (define (collect d req) - (define-values (c i o) (make-mock-connection #"")) - (d c req) - (redact (get-output-bytes o))) - (define file-url (string->url "http://test.com/foo")) (define dir-url (string->url "http://test.com/foo/")) (define (req d? meth heads) diff --git a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss index 0e1ff6f2af..b13766e653 100644 --- a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss @@ -1,8 +1,94 @@ (module dispatch-servlets-test mzscheme - (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))) + (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 "file.ss") + (lib "etc.ss") + (lib "url.ss" "net") + (lib "list.ss") + (lib "xml.ss" "xml") + (lib "pretty.ss") + (lib "request-structs.ss" "web-server" "private") + (lib "util.ss" "web-server" "private") + (lib "dispatch.ss" "web-server" "dispatchers") + (lib "cache-table.ss" "web-server" "private") + (lib "web-server-structs.ss" "web-server" "private") + (lib "namespace.ss" "web-server" "configuration") + (prefix servlets: (lib "dispatch-servlets.ss" "web-server" "dispatchers")) + "../util.ss") (provide dispatch-servlets-tests) + (current-server-custodian (current-custodian)) + + (define (mkd p) + (define-values (! d) + (servlets:make #f (box (make-cache-table)) (make-make-servlet-namespace) + #:url->path (lambda _ (values p url0s)) + #:responders-servlet-loading + (lambda (u exn) + (raise exn)) + #:responders-servlet + (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 (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/")) + ; XXX (define dispatch-servlets-tests (test-suite - "Servlets"))) \ No newline at end of file + "Servlets" + + (test-pred "configure.ss" + string? + (let* ([d (mkd (build-path example-servlets 'up "configure.ss"))] + [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]) + k0)) + + (test-suite + "Examples" + (test-equal? "hello.ss" + (let* ([d (mkd (build-path example-servlets "hello.ss"))] + [t0 (first ((sxpath "//p/text()") (call d url0 empty)))]) + t0) + "Hello, Web!") + (test-equal? "add.ss" + (let* ([d (mkd (build-path example-servlets "add.ss"))] + [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))] + [k1 (first ((sxpath "//form/@action/text()") (call d k0 (list (make-binding:form #"number" #"23")))))] + [n (first ((sxpath "//p/text()") (call d k1 (list (make-binding:form #"number" #"12")))))]) + n) + "The sum is 35") + (test-equal? "count.ss" + (let* ([d (mkd (build-path example-servlets "count.ss"))] + [ext (lambda (c) + (rest (regexp-match #rx"This servlet was called (.+) times and (.+) times since loaded on" c)))] + [c1 (ext (first ((sxpath "//p/text()") (call d url0 empty))))] + [c2 (ext (first ((sxpath "//p/text()") (call d url0 empty))))]) + (list c1 c2)) + (list (list "1" "1") + (list "2" "1"))) + (test-equal? "dir.ss" + (let* ([d (mkd (build-path example-servlets "dir.ss"))] + [t0 (first ((sxpath "//p/em/text()") (call d url0 empty)))]) + t0) + (path->string example-servlets)) + (test-pred "quiz.ss" + string? + (let* ([d (mkd (build-path example-servlets "quiz.ss"))]) + (foldl (lambda (_ k) + (first ((sxpath "//form/@action/text()") (call d k (list (make-binding:form #"answer" #"0")))))) + url0 + (build-list 7 (lambda (i) i)))))) + + ))) \ No newline at end of file diff --git a/collects/web-server/tests/util.ss b/collects/web-server/tests/util.ss index 022ea7908c..af144be09b 100644 --- a/collects/web-server/tests/util.ss +++ b/collects/web-server/tests/util.ss @@ -4,7 +4,13 @@ (provide make-module-eval make-eval/mod-path make-mock-connection - redact) + redact + collect) + + (define (collect d req) + (define-values (c i o) (make-mock-connection #"")) + (d c req) + (redact (get-output-bytes o))) (define (make-mock-connection ib) (define ip (open-input-bytes ib))