diff --git a/collects/web-server/default-web-root/servlets/examples/README b/collects/web-server/default-web-root/servlets/examples/README index 688ba3f08a..25c1658a3e 100644 --- a/collects/web-server/default-web-root/servlets/examples/README +++ b/collects/web-server/default-web-root/servlets/examples/README @@ -14,7 +14,3 @@ add.ss quiz.ss english-measure-questions.ss The quiz servlet demonstrates how to implement a web-based multiple choice quiz. A big thank you to Don Felgar for providing this sample. - - -To construct a multi-unit servlet that combines code from several files, -see the subdirectory "compound". diff --git a/collects/web-server/default-web-root/servlets/examples/add-call.ss b/collects/web-server/default-web-root/servlets/examples/add-call.ss new file mode 100644 index 0000000000..bafcfc620a --- /dev/null +++ b/collects/web-server/default-web-root/servlets/examples/add-call.ss @@ -0,0 +1,26 @@ +(module add-call mzscheme + (require (lib "servlet.ss" "web-server")) + (provide (all-defined)) + (define interface-version 'v1) + (define timeout +inf.0) + + ; request-number : str -> num + (define (request-number which-number) + (send/suspend/callback + `(html (head (title "Enter a Number to Add")) + (body ([bgcolor "white"]) + (form ([action ,(lambda (request) + (string->number + (extract-binding/single + 'number + (request-bindings request))))] + [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")))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/add-ssd.ss b/collects/web-server/default-web-root/servlets/examples/add-ssd.ss new file mode 100644 index 0000000000..31bfa39b14 --- /dev/null +++ b/collects/web-server/default-web-root/servlets/examples/add-ssd.ss @@ -0,0 +1,28 @@ +(module add-ssd mzscheme + (require (lib "servlet.ss" "web-server")) + (provide (all-defined)) + (define interface-version 'v1) + (define timeout +inf.0) + + ; request-number : str -> num + (define (request-number which-number) + (send/suspend/dispatch + (lambda (embed/url) + `(html (head (title "Enter a Number to Add")) + (body ([bgcolor "white"]) + (form ([action ,(embed/url + (lambda (request) + (string->number + (extract-binding/single + 'number + (request-bindings request)))))] + [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")))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/add-v2.ss b/collects/web-server/default-web-root/servlets/examples/add-v2.ss new file mode 100644 index 0000000000..b6dde8bf40 --- /dev/null +++ b/collects/web-server/default-web-root/servlets/examples/add-v2.ss @@ -0,0 +1,32 @@ +(module add-v2 mzscheme + (require (lib "servlet.ss" "web-server") + (lib "timeouts.ss" "web-server" "managers")) + (provide (all-defined)) + (define interface-version 'v2) + (define manager + (create-timeout-manager + (lambda _ `(html (body "Expired"))) + 360 360)) + + ; 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")))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/clear.ss b/collects/web-server/default-web-root/servlets/examples/clear.ss new file mode 100644 index 0000000000..e1eefc6453 --- /dev/null +++ b/collects/web-server/default-web-root/servlets/examples/clear.ss @@ -0,0 +1,12 @@ +(module clear mzscheme + (require (lib "servlet.ss" "web-server")) + (provide (all-defined)) + (define interface-version 'v1) + (define timeout +inf.0) + (define (start initial-request) + (parameterize ([current-servlet-continuation-expiration-handler + (lambda _ + `(html (body "Expired")))]) + (send/suspend (lambda (k-url) `(html (a ([href ,k-url]) "Link")))) + (send/forward (lambda (k-url) `(html (a ([href ,k-url]) "Link")))) + (send/finish `(html (body "Done.")))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/compound/README b/collects/web-server/default-web-root/servlets/examples/compound/README deleted file mode 100644 index bf9cf26d6e..0000000000 --- a/collects/web-server/default-web-root/servlets/examples/compound/README +++ /dev/null @@ -1,19 +0,0 @@ -To build libraries that use send/suspend, the library code must reside inside -a unit that imports send/suspend. Servlets that use the library must -link the main servlet with the code from the library using a compound-unit. - -helper.ss - This file provides the function _get-number_ that uses send/suspend - to interact with the consumer. - -helper-sig.ss - This file provides a unit signature required for linking to the helper - library. - -add.ss - The add servlet links to the helper unit and calls get-number. - -multiply.ss - The multiply servlet also uses the helper library. - - diff --git a/collects/web-server/default-web-root/servlets/examples/compound/add.ss b/collects/web-server/default-web-root/servlets/examples/compound/add.ss deleted file mode 100644 index fb8d215f0b..0000000000 --- a/collects/web-server/default-web-root/servlets/examples/compound/add.ss +++ /dev/null @@ -1,12 +0,0 @@ -(module add mzscheme - (require "helper.ss") - (provide (all-defined)) - (define interface-version 'v1) - (define timeout +inf.0) - - (define (start initial-request) - `(html (head (title "Sum")) - (body ([bgcolor "white"]) - (p "The sum is " - ,(number->string (+ (get-number "the first number to add") - (get-number "the second number to add")))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss deleted file mode 100644 index a3132b3c6d..0000000000 --- a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss +++ /dev/null @@ -1,23 +0,0 @@ -(module helper mzscheme - (require (lib "servlet.ss" "web-server")) - (provide (all-defined)) - - ; get-number : string -> number - ; to prompt the user for a number - (define (get-number which-number) - (let ask ([error-message null]) - (let* ([n-str - (extract-binding/single - 'n - (request-bindings - (send/suspend - (lambda (k-url) - (let ([prompt (string-append "Enter " which-number ": ")]) - `(html (head (title ,prompt)) - (body (form ([action ,k-url] - [method "post"]) - ,@error-message - (p ,prompt (input ([type "text"] [name "n"]))) - (input ([type "submit"] [value "Okay"]))))))))))] - [n (string->number n-str)]) - (or n (ask `((p (font ([color "red"]) ,n-str) " is not a number. Please enter a number.")))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss deleted file mode 100644 index 36918bd640..0000000000 --- a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss +++ /dev/null @@ -1,87 +0,0 @@ -(module multiply mzscheme - (require (lib "servlet.ss" "web-server") - (lib "etc.ss") - "helper.ss") - (provide (all-defined)) - (define interface-version 'v1) - (define timeout +inf.0) - - ; matrix = (listof (listof num)) - - ; matrix-multiply : matrix matrix -> matrix - (define (matrix-multiply a b) - (map (lambda (a-row) - (side-map (lambda (b-column) - (apply + (map * a-row b-column))) - b)) - a)) - - ; side-map : ((listof a) -> b) (listof (listof a)) -> (listof b) - (define (side-map f m) - (cond - [(null? (car m)) null] - [else (cons (f (map car m)) - (side-map f (map cdr m)))])) - - ; --- - - ; get-dimentions : -> nat nat - ; to ask for and return the number of rows and columns - (define (get-dimentions) - (values - (get-number "the number of rows in the first matrix") - (get-number "the number of rows in the second matrix"))) - - ; get-matrix : nat nat -> matrix - (define (get-matrix rows columns) - (let ([b (get-matrix-bindings rows columns)]) - (build-list - rows - (lambda (r) - (build-list - columns - (lambda (c) - (string->number (extract-binding/single (string->symbol (field-name r c)) b)))))))) - - ; get-matrix-bindings : nat nat -> (listof (cons sym str)) - (define (get-matrix-bindings rows columns) - (request-bindings - (send/suspend - (lambda (k-url) - `(html (head (title "Enter a " ,(number->string rows) " by " - ,(number->string columns) " Matrix")) - (body (form ([action ,k-url] [method "post"]) - (table ,(build-list - rows - (lambda (r) - `(tr . ,(build-list - columns - (lambda (c) - `(td (input ([type "text"] [name ,(field-name r c)]))))))))) - (input ([type "submit"] [name "submit"] [value "Okay"]))))))))) - - ; field-name : nat nat -> str - (define (field-name row column) - (format "x-~a-~a" row column)) - - ; --- - - ; render-matrix : matrix -> html - (define (render-matrix m) - `(table - ([border "1"]) - . ,(map (lambda (row) - `(tr . ,(map (lambda (n) - `(td ,(number->string n))) - row))) - m))) - - ; main - (define (start initial-request) - `(html (head (title "Matrix Product")) - (body - (p "The matrix product is" - ,(render-matrix - (let-values ([(r c) (get-dimentions)]) - (matrix-multiply (get-matrix r c) - (get-matrix c r))))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/servlets/examples/cut.ss b/collects/web-server/default-web-root/servlets/examples/cut.ss new file mode 100644 index 0000000000..973af78030 --- /dev/null +++ b/collects/web-server/default-web-root/servlets/examples/cut.ss @@ -0,0 +1,13 @@ +(module cut mzscheme + (require (lib "servlet.ss" "web-server")) + (provide (all-defined)) + (define interface-version 'v1) + (define timeout +inf.0) + (define (start initial-request) + (parameterize ([current-url-transform + (lambda (k-url) "#")]) + (send/suspend + (lambda (k-url) + `(html (head (title "Hello")) + (body (a ([href ,k-url]) + "Link")))))))) \ 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 90a40c71d1..b21a9aedeb 100644 --- a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss @@ -27,6 +27,22 @@ (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/")) @@ -35,7 +51,6 @@ "Servlets" ; XXX test update cache - ; XXX test different versions (test-pred "configure.ss" string? @@ -45,19 +60,20 @@ (test-suite "Examples" - (test-equal? "hello.ss" + (test-equal? "hello.ss - loading" (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" + (test-add-two-numbers "add.ss - send/suspend" + (build-path example-servlets "add.ss")) + (test-add-two-numbers "add-v2.ss - send/suspend, version 2" + (build-path example-servlets "add-v2.ss")) + (test-add-two-numbers "add-ssd.ss - send/suspend/dispatch" + (build-path example-servlets "add-ssd.ss")) + (test-add-two-numbers "add-call.ss - send/suspend/callback" + (build-path example-servlets "add-call.ss")) + (test-equal? "count.ss - state" (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)))] @@ -66,33 +82,40 @@ (list c1 c2)) (list (list "1" "1") (list "2" "1"))) - (test-equal? "dir.ss" + (test-equal? "dir.ss - current-directory" (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" + (test-pred "quiz.ss - send/suspend" 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)))))) - - (test-suite - "servlet/web.ss" - ; XXX current-url-transform - ; XXX current-servlet-continuation-expiration-handler - ; XXX redirect/get - ; XXX redirect/get/forget - ; XXX adjust-timeout! - ; XXX clear-continuation-table! - ; XXX send/back - ; XXX send/finish - ; XXX send/suspend - ; XXX send/forward - ; XXX send/suspend/dispatch - ; XXX send/suspend/callback + (build-list 7 (lambda (i) i))))) + (test-equal? "cut.ss - current-url-transform" + (let* ([d (mkd (build-path example-servlets "cut.ss"))] + [k0 (first ((sxpath "//a/@href/text()") (call d url0 empty)))]) + k0) + "#") + (test-equal? "clear.ss - current-servlet-continuation-expiration-handler, clear-continuation-table!, send/finish, send/forward" + (let* ([d (mkd (build-path example-servlets "clear.ss"))] + [k0 (first ((sxpath "//a/@href/text()") (call d url0 empty)))] + [k1 (first ((sxpath "//a/@href/text()") (call d k0 empty)))] + [k0-expired (first ((sxpath "//body/text()") (call d k0 empty)))] + [done (first ((sxpath "//body/text()") (call d k1 empty)))] + [k1-expired (first ((sxpath "//body/text()") (call d k1 empty)))]) + (list k0-expired + done + k1-expired)) + (list "Expired" + "Done." + "Expired")) ) + ; XXX redirect/get + ; XXX redirect/get/forget + ; XXX adjust-timeout! + ))) \ No newline at end of file