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

Testing servlets!

Browse Source 
svn: r6583
This commit is contained in:
Jay McCarthy 2007-06-12 05:31:37 +00:00
parent ab492c3f7c
commit 4480a1308a
4 changed files with 95 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/web-server/default-web-root/servlets/examples/add-module.ss
View File

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

5
collects/web-server/tests/dispatchers/dispatch-files-test.ss
View File

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

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

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

8
collects/web-server/tests/util.ss
View File

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