The answer is ~a
" + (+ x y))))) + + (let () + (define r2 + (-s> + (make-request #"GET" (string->url (format "~a?~a=~a" k1 i1 ys)) empty + (delay (list (make-binding:form (string->bytes/utf-8 i1) ys))) + #"" "127.0.0.1" 80 "127.0.0.1"))) + (define n (se-path* '(p) r2)) + (check-equal? n + (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)) +(require (prefix-in ex:double: web-server/default-web-root/htdocs/servlets/examples/wc)) + +(define (test-double-counters -s>) + (define (invoke u) + (define sx (-s> u)) + (define ks (se-path*/list '(div div a #:href) sx)) + (values (se-path*/list '(div div h3) sx) + (first ks) + (second ks))) + ; One add + (define-values (v0.0 0.0+1 0.0+2) (invoke "")) + (check-equal? v0.0 (list "0" "0")) + (define-values (v1.0 1.0+1 1.0+2) (invoke 0.0+1)) + (check-equal? v1.0 (list "1" "0")) ; XXX infinite loop after this + (define-values (v0.1 0.1+1 0.1+2) (invoke 0.0+2)) + (check-equal? v0.1 (list "0" "1")) + ; Two adds + (define-values (v2.0 2.0+1 2.0+2) (invoke 1.0+1)) + (check-equal? v2.0 (list "2" "0")) + (define-values (v1.1 1.1+1 1.1+2) (invoke 0.1+1)) + (check-equal? v1.1 (list "1" "1")) + (define-values (_v1.1 _1.1+1 _1.1+2) (invoke 1.0+2)) + (check-equal? _v1.1 (list "1" "1")) + (define-values (v0.2 0.2+1 0.2+2) (invoke 0.1+2)) + (check-equal? v0.2 (list "0" "2"))) + +(define test-tests + (test-suite "Servlet testing tests" + (test-case "add1" + (test-add-two-numbers + (make-servlet-tester ex:add1:start))) + (test-case "add2" + (test-add-two-numbers + (make-servlet-tester ex:add2:start))) + (test-case "double-counters" + (test-double-counters + (make-servlet-tester ex:double:start))))) +(provide test-tests) \ No newline at end of file diff --git a/collects/tests/web-server/util.rkt b/collects/tests/web-server/util.rkt index 93586e59db..5ee7fb3f79 100644 --- a/collects/tests/web-server/util.rkt +++ b/collects/tests/web-server/util.rkt @@ -18,76 +18,17 @@ call bytes-sort) +(require xml/path) +(provide (rename-out + [se-path* simple-xpath*] + [se-path*/list simple-xpath*/list])) + (define (bytes-sort bs) (sort (with-input-from-bytes bs (λ () (port->bytes-lines #:line-mode 'return-linefeed))) bytessymbol (compose string->symbol keyword->string)) -(define (simple-xpath/xexpr p x) - (match p - [(list) - (list x)] - [(list-rest (? symbol? s) r) - (match x - [(list-rest (? (curry equal? s)) rs) - (simple-xpath/tag-body r rs)] - [_ - empty])] - [_ - empty])) -(define (simple-xpath/tag-body p x) - (match p - [(list) - (match x - [(list) empty] - [(list-rest (list (list (? symbol?) (? string?)) ...) rs) - (simple-xpath/tag-body p rs)] - [(? list?) - x] - [_ - empty])] - [(list-rest (? symbol?) _) - (match x - [(list-rest (list (list (? symbol?) (? string?)) ...) rs) - (simple-xpath/tag-body p rs)] - [(? list?) - (append-map (curry simple-xpath/xexpr p) x)] - [_ - empty])] - [(list (? keyword? k)) - (match x - [(list-rest (and attrs (list (list (? symbol?) (? string?)) ...)) rs) - (simple-xpath/attr (keyword->symbol k) attrs)] - [_ - empty])] - [_ - empty])) -(define (simple-xpath/attr k attrs) - (dict-ref attrs k empty)) -(define (simple-xpath*/list p x) - (append (simple-xpath/xexpr p x) - (match x - [(list-rest (list (cons (? symbol?) (? string?)) ...) rs) - (simple-xpath*/list p rs)] - [(? list?) - (append-map (curry simple-xpath*/list p) x)] - [_ - empty]))) -(define (simple-xpath* p x) - (match (simple-xpath*/list p x) - [(list) #f] - [(list-rest f rs) f])) - -(test - (simple-xpath*/list '(p) '(html (body (p "Hey") (p "Bar")))) => (list "Hey" "Bar") - (simple-xpath* '(p) '(html (body (p "Hey")))) => "Hey" - (simple-xpath* '(p #:bar) '(html (body (p ([bar "Zog"]) "Hey")))) => "Zog") - -(provide simple-xpath* - simple-xpath*/list) - (define (call d u bs) (htxml (collect d (make-request #"GET" (string->url u) empty (delay bs) #"" "127.0.0.1" 80 "127.0.0.1")))) (define (htxml bs) @@ -99,60 +40,20 @@ [_ (error 'html "Given ~S\n" bs)])) -; This causes infinite loop. I will try putting it in a thread like on the real server -#;(define (collect d req) - (define-values (c i o) (make-mock-connection #"")) - (parameterize ([current-server-custodian (current-custodian)]) - (d c req)) - (redact (get-output-bytes o))) - ; This causes errors because s/s/d tries to jump the barrier, but I have no idea why (define (collect d req) (define-values (c i o) (make-mock-connection #"")) - (parameterize ([current-server-custodian (current-custodian)]) + (parameterize ([current-server-custodian (make-custodian)]) (call-with-continuation-barrier (lambda () (d c req)))) (redact (get-output-bytes o))) -; This causes a dead lock, even though the log shows that the channel should sync -(define (channel-put* c v) - (printf "+CHAN ~S PUT: ~S\n" c v) - (channel-put c v) - (printf "-CHAN ~S PUT: ~S\n" c v)) - -(define (channel-get* c) - (printf "+CHAN ~S GET\n" c) - (let ([v (channel-get c)]) - (printf "-CHAN ~S GET: ~S\n" c v) - v)) - -#;(define (collect d req) - (define chan (make-channel)) - (define-values (c i o) (make-mock-connection #"")) - (parameterize ([current-server-custodian (current-custodian)]) - (thread - (lambda () - (d c req) - (channel-put* chan (get-output-bytes o)) - ))) - (redact (channel-get* chan))) - -; This causes an error, because the output bytes are #"" -#;(define (collect d req) - (define-values (c i o) (make-mock-connection #"")) - (parameterize ([current-server-custodian (current-custodian)]) - (thread-wait - (thread - (lambda () - (d c req))))) - (redact (get-output-bytes o))) - (define (make-mock-connection ib) (define ip (open-input-bytes ib)) (define op (open-output-bytes)) (values (make-connection 0 (make-timer never-evt +inf.0 (lambda () (void))) - ip op (current-custodian) #f) + ip op (make-custodian) #f) ip op)) diff --git a/collects/tests/xml/test-path.rkt b/collects/tests/xml/test-path.rkt new file mode 100644 index 0000000000..3c00624369 --- /dev/null +++ b/collects/tests/xml/test-path.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require xml/path + tests/eli-tester) + +(test + (se-path*/list '(p) '(html (body (p "Hey") (p "Bar")))) => (list "Hey" "Bar") + (se-path* '(p) '(html (body (p "Hey")))) => "Hey" + (se-path* '(p #:bar) '(html (body (p ([bar "Zog"]) "Hey")))) => "Zog") \ No newline at end of file diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 84697bb5eb..1d7778b52a 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -11,6 +11,7 @@ The @web-server implements many HTTP libraries that are provided by this module. @section[#:tag "request-structs"]{Requests} @(require (for-label web-server/http/request-structs xml + racket/promise racket/match)) @defmodule[web-server/http/request-structs]{ diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 5b079ee018..336e5c6853 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -14,6 +14,7 @@ web-server/dispatchers/dispatch-log racket/serialize web-server/stuffers + web-server/servlet/servlet-structs racket/list)) @defmodule[web-server/servlet-env] diff --git a/collects/web-server/scribblings/test.scrbl b/collects/web-server/scribblings/test.scrbl new file mode 100644 index 0000000000..798a34bde3 --- /dev/null +++ b/collects/web-server/scribblings/test.scrbl @@ -0,0 +1,29 @@ +#lang scribble/doc +@(require "web-server.rkt" + (for-label web-server/http/request-structs + xml + racket/promise + racket/match)) + +@title[#:tag "test"]{Testing Servlets} + +@defmodule[web-server/test] + +The @web-server provides a simple facility for writing tests for Web servlets. + +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?) + boolean?) + (or/c bytes? + xexpr?))]{ + +This function accepts + +} \ No newline at end of file diff --git a/collects/web-server/scribblings/web-server.scrbl b/collects/web-server/scribblings/web-server.scrbl index c6962365d6..ac056ffb15 100644 --- a/collects/web-server/scribblings/web-server.scrbl +++ b/collects/web-server/scribblings/web-server.scrbl @@ -34,6 +34,8 @@ This manual closes with a frequently asked questions section: @secref["faq"]. @include-section["templates.scrbl"] @include-section["page.scrbl"] +@include-section["test.scrbl"] + @include-section["faq.scrbl"] @index-section[] diff --git a/collects/web-server/test.rkt b/collects/web-server/test.rkt new file mode 100644 index 0000000000..64489e9775 --- /dev/null +++ b/collects/web-server/test.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require racket/contract + web-server/servlet/servlet-structs) + +(provide/contract + [make-servlet-tester + (-> (-> request? + can-be-response?) + (->* () + ((or/c string? url? request? false/c) + (listof binding?) + #:raw? boolean?) + (or/c bytes? + xexpr?)))]) + +; Real Library +(require racket/list + racket/promise + net/url + web-server/http + web-server/servlet-dispatch) + +(define (make-servlet-tester servlet) + (define d (dispatch/servlet servlet)) + (λ ([s-or-u-or-req #f] + [bs empty] + #:raw? [raw? #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?))) + +; 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? + s + (string->xexpr (bytes->string/utf-8 s)))] + [_ + (error 'servlet "Servlet did not return an HTTP response, instead returned ~v" + bs)])) + +(define (collect d req) + (parameterize ([current-custodian (make-custodian)]) + (define-values (c i o) (make-mock-connection #"")) + (parameterize ([current-server-custodian (current-custodian)]) + (call-with-continuation-barrier + (lambda () + (d c req)))) + (redact (get-output-bytes o)))) + +(define (make-mock-connection ib) + (define ip (open-input-bytes ib)) + (define op (open-output-bytes)) + (values (make-connection 0 (make-timer never-evt +inf.0 (lambda () (void))) + ip op (current-custodian) #f) + ip + op)) + +(define (redact b) + (regexp-replace + #"Date: [a-zA-Z0-9:, ]+ GMT\r\n" + (regexp-replace + #"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n" + b + #"Last-Modified: REDACTED GMT\r\n") + #"Date: REDACTED GMT\r\n")) diff --git a/collects/xml/path.rkt b/collects/xml/path.rkt new file mode 100644 index 0000000000..678d3c7dc5 --- /dev/null +++ b/collects/xml/path.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require racket/contract + racket/match + racket/dict + racket/function + racket/list + xml) + +(define keyword->symbol (compose string->symbol keyword->string)) +(define (se-path/xexpr p x) + (match p + [(list) + (list x)] + [(list-rest (? symbol? s) r) + (match x + [(list-rest (? (curry equal? s)) rs) + (se-path/tag-body r rs)] + [_ + empty])] + [_ + empty])) +(define (se-path/tag-body p x) + (match p + [(list) + (match x + [(list) empty] + [(list-rest (list (list (? symbol?) (? string?)) ...) rs) + (se-path/tag-body p rs)] + [(? list?) + x] + [_ + empty])] + [(list-rest (? symbol?) _) + (match x + [(list-rest (list (list (? symbol?) (? string?)) ...) rs) + (se-path/tag-body p rs)] + [(? list?) + (append-map (curry se-path/xexpr p) x)] + [_ + empty])] + [(list (? keyword? k)) + (match x + [(list-rest (and attrs (list (list (? symbol?) (? string?)) ...)) rs) + (se-path/attr (keyword->symbol k) attrs)] + [_ + empty])] + [_ + empty])) +(define (se-path/attr k attrs) + (dict-ref attrs k empty)) +(define (se-path*/list p x) + (append (se-path/xexpr p x) + (match x + [(list-rest (list (cons (? symbol?) (? string?)) ...) rs) + (se-path*/list p rs)] + [(? list?) + (append-map (curry se-path*/list p) x)] + [_ + empty]))) +(define (se-path* p x) + (match (se-path*/list p x) + [(list) #f] + [(list-rest f rs) f])) + +(define se-path? + (match-lambda + [(list) #t] + [(list (? keyword?)) #t] + [(list-rest (? symbol?) l) (se-path? l)] + [_ #f])) + +(provide/contract + [se-path? contract?] + [se-path* + (-> se-path? xexpr? + ; XXX maybe this shouldn't be any/c + any/c)] + [se-path*/list + (-> se-path? xexpr? + ; XXX see above + (listof any/c))]) \ No newline at end of file diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index e7bf212488..99faa00e5b 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -470,3 +470,11 @@ looks like the following, if re-formatted by: }| + +@; ---------------------------------------------------------------------- + +@section{Simple X-expression Path Queries} + +@defmodule[xml/path] + +XXX