The answer is ~a
" - (+ 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)) + + diff --git a/collects/web-server/dispatchers/dispatch-servlets.rkt b/collects/web-server/dispatchers/dispatch-servlets.rkt index 5b370746f7..1a0f8990ea 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.rkt +++ b/collects/web-server/dispatchers/dispatch-servlets.rkt @@ -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)] diff --git a/collects/web-server/scribblings/test.scrbl b/collects/web-server/scribblings/test.scrbl index 6d0a3599d8..0652335634 100644 --- a/collects/web-server/scribblings/test.scrbl +++ b/collects/web-server/scribblings/test.scrbl @@ -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 diff --git a/collects/web-server/test.rkt b/collects/web-server/test.rkt index cfcf6c9375..7cef89316f 100644 --- a/collects/web-server/test.rkt +++ b/collects/web-server/test.rkt @@ -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"