suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Servlet tests

Browse Source 
svn: r6615
This commit is contained in:
Jay McCarthy 2007-06-12 23:52:13 +00:00
parent 14c6f70199
commit bd370b3763
11 changed files with 162 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/web-server/default-web-root/servlets/examples/README
View File

@ -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".

26
collects/web-server/default-web-root/servlets/examples/add-call.ss Normal file
View File

@ -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"))))))))

28
collects/web-server/default-web-root/servlets/examples/add-ssd.ss Normal file
View File

@ -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"))))))))

32
collects/web-server/default-web-root/servlets/examples/add-v2.ss Normal file
View File

@ -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"))))))))

12
collects/web-server/default-web-root/servlets/examples/clear.ss Normal file
View File

@ -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."))))))

19
collects/web-server/default-web-root/servlets/examples/compound/README
View File

@ -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.

12
collects/web-server/default-web-root/servlets/examples/compound/add.ss
View File

@ -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"))))))))

23
collects/web-server/default-web-root/servlets/examples/compound/helper.ss
View File

@ -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."))))))))

87
collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
View File

@ -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)))))))))

13
collects/web-server/default-web-root/servlets/examples/cut.ss Normal file
View File

@ -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"))))))))

79
collects/web-server/tests/dispatchers/dispatch-servlets-test.ss
View File

@ -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!
)))