Adding the basics of the servlet testing library, but then discovered a weird error, and took a sidetrack to catch it. I'm making a commit to be able see if there were any real problems or if it is just broken tests

collects/tests/web-server/all-web-server-tests.rkt

@@ -11,7 +11,8 @@
          "stuffers-test.rkt"
          "formlets-test.rkt"
          "dispatch-test.rkt"
-         "servlet-env-test.rkt")
+         "servlet-env-test.rkt"
+         "test-tests.rkt")
 (provide all-web-server-tests)
 
 (define all-web-server-tests  
@@ -28,4 +29,5 @@
    all-managers-tests
    all-private-tests
    all-servlet-tests
-   servlet-env-tests))
+   servlet-env-tests
+   test-tests))

collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt

@@ -13,7 +13,7 @@
          "../util.rkt")
 (provide dispatch-servlets-tests)
 
-(current-server-custodian (current-custodian))
+(current-server-custodian (make-custodian))
 
 (define (mkd p)
   (define-values (! u->s)

collects/tests/web-server/http/xexpr.rkt

@@ -10,7 +10,7 @@
   (define-values (i-port o-port) (make-pipe))
   (define conn
     (connection 0 (start-timer +inf.0 void)
-                i-port o-port (current-custodian) #t))
+                i-port o-port (make-custodian) #t))
   (output-response conn r)
   (close-output-port o-port)
   (define bs (port->bytes i-port))

collects/tests/web-server/private/connection-manager-test.rkt

@@ -15,7 +15,7 @@
     (check-true
      (let ([ib (open-input-bytes #"")]
            [ob (open-output-bytes)])
-       (new-connection 1 ib ob (current-custodian) #t)
+       (new-connection 1 ib ob (make-custodian) #t)
        (sleep 2)
        (with-handlers ([exn? (lambda _ #t)])
          (read ib) #f))))
@@ -25,7 +25,7 @@
     (check-true
      (let ([ib (open-input-bytes #"")]
            [ob (open-output-bytes)])
-       (new-connection 1 ib ob (current-custodian) #t)
+       (new-connection 1 ib ob (make-custodian) #t)
        (sleep 2)
        (with-handlers ([exn? (lambda _ #t)])
          (write 1 ob) #f))))
@@ -35,7 +35,7 @@
     (check-true
      (let* ([ib (open-input-bytes #"")]
             [ob (open-output-bytes)]
-            [c (new-connection 1 ib ob (current-custodian) #t)])
+            [c (new-connection 1 ib ob (make-custodian) #t)])
        (kill-connection! c)
        (and (with-handlers ([exn? (lambda _ #t)])
               (read ib) #f)
@@ -47,7 +47,7 @@
     (check-true
      (let* ([ib (open-input-bytes #"")]
             [ob (open-output-bytes)]
-            [c (new-connection 1 ib ob (current-custodian) #t)])
+            [c (new-connection 1 ib ob (make-custodian) #t)])
        (adjust-connection-timeout! c 1)
        (sleep 2)
        (and (with-handlers ([exn? (lambda _ #t)])

collects/tests/web-server/run-all-tests.rkt

@@ -4,7 +4,5 @@
 (require rackunit/text-ui)
 (run-tests all-web-server-tests)
 
-
 #;(require rackunit/gui)
 #;(test/gui all-web-server-tests)
-

collects/tests/web-server/test-tests.rkt

@@ -0,0 +1,90 @@
+#lang racket/base
+(require rackunit
+         racket/list
+         xml/path
+         web-server/test
+         net/url
+         racket/promise
+         web-server/http)
+
+(define (test-add-two-numbers -s>)
+  (define x (random 500))
+  (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>))
+  (define k0 (se-path* '(form #:action) r0))
+  (define i0 (se-path* '(form input #:name) r0))
+  (define r1 
+    (-s> (format "~a?~a=~a" k0 i0 xs)
+         (list (make-binding:form (string->bytes/utf-8 i0) xs))))
+  (define k1 (se-path* '(form #:action) r1))
+  (define i1 (se-path* '(form input #:name) r1))
+  (define r2 
+    (-s> (format "~a?~a=~a" k1 i1 ys)
+         (list (make-binding:form (string->bytes/utf-8 i1) ys))))
+  (define n (se-path* '(p) r2))
+  (check-equal? n
+                (format "The answer is ~a" (+ x y)))
+  
+  (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)))))
+  
+  (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)

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)))
    bytes<?))
 
-(define keyword->symbol (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))
 

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

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]{

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]

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 
+                              
+}

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[]

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

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

collects/xml/xml.scrbl

@@ -470,3 +470,11 @@ looks like the following, if re-formatted by:
   </dict>
 </plist>
 }|
+
+@; ----------------------------------------------------------------------
+
+@section{Simple X-expression Path Queries}
+
+@defmodule[xml/path]
+
+XXX