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

Supporting headers and stateless in web-server/test

Browse Source
This commit is contained in:
Jay McCarthy 2013-02-08 07:00:49 -07:00
parent 0e8b5f87b3
commit cd202f5411
4 changed files with 116 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/tests/web-server/test-tests.rkt
View File

@ -1,8 +1,10 @@
#lang racket/base
(require rackunit
racket/list
racket/match
xml/path
web-server/test
web-server/servlet-dispatch
net/url
racket/promise
web-server/http)
@ -12,8 +14,8 @@
(define xs (string->bytes/utf-8 (number->string x)))
(define y (random 500))
(define ys (string->bytes/utf-8 (number->string y)))
(define r0 (-s>))
(match-define (cons h r0) (-s> #:headers? #t))
(define k0 (se-path* '(form #:action) r0))
(define i0 (se-path* '(form input #:name) r0))
(define r1
@ -31,14 +33,11 @@
(let ()
(define r2
(-s> (format "~a?~a=~a" k1 i1 ys)
(list (make-binding:form (string->bytes/utf-8 i1) ys))
#:raw? #t))
(check-equal? r2
(string->bytes/utf-8
(format "<html><head><title>Sum</title></head><body bgcolor=\"white\"><p>The answer is ~a</p></body></html>"
(+ x y)))))
(list (make-binding:form (string->bytes/utf-8 i1) ys))))
(check-equal? (se-path* '(html body p) r2)
(format "The answer is ~a" (+ x y))))
(let ()
(let ()
(define r2
(-s>
(make-request #"GET" (string->url (format "~a?~a=~a" k1 i1 ys)) empty
@ -49,7 +48,8 @@
(format "The answer is ~a" (+ x y)))))
(require (prefix-in ex:add1: web-server/default-web-root/htdocs/servlets/examples/add)
(prefix-in ex:add2: web-server/default-web-root/htdocs/servlets/examples/add-v2))
(prefix-in ex:add2: web-server/default-web-root/htdocs/servlets/examples/add-v2)
(prefix-in ex:lang:add2: web-server/default-web-root/htdocs/lang-servlets/add02))
(require (prefix-in ex:double: web-server/default-web-root/htdocs/servlets/examples/wc))
(define (test-double-counters -s>)
@ -84,7 +84,17 @@
(test-case "add2"
(test-add-two-numbers
(make-servlet-tester ex:add2:start)))
(test-case "lang add2"
(test-add-two-numbers
(make-dispatcher-tester
(dispatch/servlet ex:lang:add2:start #:stateless? #t))))
(test-case "double-counters"
(test-double-counters
(make-servlet-tester ex:double:start)))))
(provide test-tests)
(module+ test
(require rackunit/text-ui)
(run-tests test-tests))

2
collects/web-server/dispatchers/dispatch-servlets.rkt
View File

@ -56,7 +56,7 @@
#:responders-servlet-loading [responders-servlet-loading servlet-loading-responder]
#:responders-servlet [responders-servlet servlet-error-responder])
(lambda (conn req)
(define uri (request-uri req))
(define uri (request-uri req))
(define instance-custodian (make-servlet-custodian))
(parameterize ([current-custodian instance-custodian]
[current-execution-context (make-execution-context req)]

58
collects/web-server/scribblings/test.scrbl
View File

@ -1,7 +1,9 @@
#lang scribble/doc
@(require "web-server.rkt"
(for-label web-server/http/request-structs
web-server/dispatchers/dispatch
web-server/servlet/servlet-structs
web-server/servlet-dispatch
xml
web-server/test
net/url
@ -12,28 +14,58 @@
@defmodule[web-server/test]
The @web-server provides a simple facility for writing tests for Web servlets.
The @web-server provides a simple facility for writing tests for Web
servlets and dispatchers.
The core functionality allows a request to be sent to the servlet and the response captured:
@defproc[(make-servlet-tester
[servlet
(-> request?
can-be-response?)])
(->* ()
((or/c string? url? request? false/c)
(listof binding?)
#:raw? boolean?)
(or/c bytes?
xexpr?))]{
This function accepts a servlet function and provides a function that accepts a request and returns the answer the servlet for that request. This interaction function has many possible calling patterns:
@defthing[tester/c contract?]{
This contract is equivalent to
@racketblock[
(->* ()
((or/c string? url? request? false/c)
(listof binding?)
#:raw? boolean?
#:headers? boolean?)
(or/c bytes?
xexpr?
(cons/c bytes?
(or/c bytes?
xexpr?))))
]
It represents a function that accepts a request and returns the answer the servlet for that request. This interaction function has many possible calling patterns:
@itemize[
@item{No arguments: a call to the root URL path with no bindings.}
@item{At least one argument: this may be a string, URL, or a request data structure.}
@item{Two arguments: the first argument must be a string or a URL, but the second argument can specify the request bindings.}
@item{The optional @racket[#:raw?] keyword controls whether an X-expression or a byte string is returned as a result.}
@item{The optional @racket[#:headers?] keyword controls whether the headers are included in the return value as a byte string. When this is used, the two returns are returned in a cons.}
]
}
@defproc[(make-servlet-tester
[servlet
(-> request?
can-be-response?)])
tester/c]{
This function accepts a servlet function and provides a tester
function as described above. It is equivalent to
@racket[(make-dispatcher-tester (dispatch/servlet servlet))], so if
you need custom arguments to @racket[dispatch/servlet], use
@racket[make-dispatcher-tester].
}
@defproc[(make-dispatcher-tester
[d dispatcher/c])
tester/c]{
This function accepts a dispatcher and provides a tester function as described above.
}
This facility is designed to be used in concert with a technique of

80
collects/web-server/test.rkt
View File

@ -1,19 +1,31 @@
#lang racket/base
(require racket/contract
web-server/dispatchers/dispatch
web-server/servlet/servlet-structs)
(define tester/c
(->* ()
((or/c string? url? request? false/c)
(listof binding?)
#:raw? boolean?
#:headers? boolean?)
(or/c bytes?
xexpr?
(cons/c bytes?
(or/c bytes?
xexpr?)))))
(provide/contract
[tester/c contract?]
[make-servlet-tester
(-> (-> request?
can-be-response?)
(->* ()
((or/c string? url? request? false/c)
(listof binding?)
#:raw? boolean?)
(or/c bytes?
xexpr?)))])
tester/c)]
[make-dispatcher-tester
(-> dispatcher/c
tester/c)])
; Real Library
;; Real Library
(require racket/list
racket/promise
net/url
@ -22,39 +34,47 @@
(define (make-servlet-tester servlet)
(define d (dispatch/servlet servlet))
(λ ([s-or-u-or-req #f]
(make-dispatcher-tester d))
(define (make-dispatcher-tester d)
(λ ([s-or-u-or-req #f]
[bs empty]
#:raw? [raw? #f])
#:raw? [raw? #f]
#:headers? [hs? #f])
(define req
(if (request? s-or-u-or-req)
s-or-u-or-req
(let ()
(define s-or-u
(if s-or-u-or-req
s-or-u-or-req
""))
(define u
(if (string? s-or-u)
(string->url s-or-u)
s-or-u))
(make-request #"GET" u empty (delay bs) #"" "127.0.0.1" 80 "127.0.0.1"))))
(call d req #:raw? raw?)))
s-or-u-or-req
(let ()
(define s-or-u
(if s-or-u-or-req
s-or-u-or-req
"/"))
(define u
(if (string? s-or-u)
(string->url s-or-u)
s-or-u))
(make-request #"GET" u empty (delay bs) #"" "127.0.0.1" 80 "127.0.0.1"))))
(call d req #:raw? raw? #:headers? hs?)))
; Intermediate Library
;; Intermediate Library
(require racket/match
xml
web-server/private/timer
web-server/private/connection-manager
web-server/private/web-server-structs)
(define (call d req #:raw? raw?)
(htxml (collect d req) raw?))
(define (htxml bs raw?)
(match (regexp-match #"^.+\r\n\r\n(.*)$" bs)
[(list _ s)
(if raw?
(define (call d req #:raw? raw? #:headers? hs?)
(htxml (collect d req) raw? hs?))
(define (htxml bs raw? hs?)
(match (regexp-match #"^(.+)\r\n\r\n(.*)$" bs)
[(list _ h s)
(define body
(if raw?
s
(string->xexpr (bytes->string/utf-8 s)))]
(string->xexpr (bytes->string/utf-8 s))))
(if hs?
(cons h body)
body)]
[_
(error 'servlet "Servlet did not return an HTTP response, instead returned ~v"
bs)]))
@ -77,7 +97,7 @@
op))
(define (redact b)
(regexp-replace
(regexp-replace
#"Date: [a-zA-Z0-9:, ]+ GMT\r\n"
(regexp-replace
#"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n"