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

Lang tests

Browse Source 
svn: r6599
This commit is contained in:
Jay McCarthy 2007-06-12 16:35:27 +00:00
parent f26c1c33df
commit c9bc26b06d
6 changed files with 174 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss Normal file
View File

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

18
collects/web-server/default-web-root/htdocs/lang-servlets/temp.ss
View File

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

37
collects/web-server/default-web-root/htdocs/lang-servlets/toobig.ss
View File

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

140
collects/web-server/tests/dispatchers/dispatch-lang-test.ss
View File

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

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

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

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

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