Testing servlets!

svn: r6583

collects/web-server/default-web-root/servlets/examples/add-module.ss

@@ -1,30 +0,0 @@
-(module add-module mzscheme
-  (require (lib "servlet.ss" "web-server")
-           (lib "date.ss"))
-  (provide (all-defined))
-  
-  (define interface-version 'v1)
-  (define timeout 30)
-  
-  ; request-number : str -> num
-  (define (request-number which-number)
-    (string->number
-     (extract-binding/single
-      'number
-      (request-bindings (send/suspend (build-request-page which-number))))))
-
-  ; build-request-page : str -> str -> response
-  (define (build-request-page which-number)
-    (lambda (k-url)
-      `(html (head (title "Enter a Number to Add"))
-             (body ([bgcolor "white"])
-                   (form ([action ,k-url] [method "post"])
-                         "Enter the " ,which-number " number to add: "
-                         (input ([type "text"] [name "number"] [value ""]))
-                         (input ([type "submit"] [name "enter"] [value "Enter"])))))))
-
-  (define (start initial-request)
-    `(html (head (title "Sum"))
-           (body ([bgcolor "white"])
-                 (p "The sum is "
-                    ,(number->string (+ (request-number "first") (request-number "second"))))))))

collects/web-server/tests/dispatchers/dispatch-files-test.ss

@@ -32,11 +32,6 @@
                 #:mime-types-path (build-path "/etc/httpd/mime.types")
                 #:indices (list (if i? (file-name-from-path tmp-file) not-there))))
   
-  (define (collect d req)
-    (define-values (c i o) (make-mock-connection #""))
-    (d c req)
-    (redact (get-output-bytes o)))
-  
   (define file-url (string->url "http://test.com/foo"))
   (define dir-url (string->url "http://test.com/foo/"))
   (define (req d? meth heads)

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

@@ -1,8 +1,94 @@
 (module dispatch-servlets-test mzscheme
-  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
+  (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 "file.ss")
+           (lib "etc.ss")
+           (lib "url.ss" "net")
+           (lib "list.ss")
+           (lib "xml.ss" "xml")
+           (lib "pretty.ss")
+           (lib "request-structs.ss" "web-server" "private")
+           (lib "util.ss" "web-server" "private")
+           (lib "dispatch.ss" "web-server" "dispatchers")
+           (lib "cache-table.ss" "web-server" "private")
+           (lib "web-server-structs.ss" "web-server" "private")
+           (lib "namespace.ss" "web-server" "configuration")
+           (prefix servlets: (lib "dispatch-servlets.ss" "web-server" "dispatchers"))
+           "../util.ss")
   (provide dispatch-servlets-tests)
   
+  (current-server-custodian (current-custodian))
+  
+  (define (mkd p)
+    (define-values (! d)
+      (servlets:make #f (box (make-cache-table)) (make-make-servlet-namespace)
+                     #:url->path (lambda _ (values p url0s))
+                     #:responders-servlet-loading
+                     (lambda (u exn)
+                       (raise exn))
+                     #:responders-servlet
+                     (lambda (u exn)
+                       (raise exn))))
+    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/"))
+  
   ; XXX
   (define dispatch-servlets-tests
     (test-suite
-     "Servlets")))
+     "Servlets"
+     
+     (test-pred "configure.ss"
+                string?
+                (let* ([d (mkd (build-path example-servlets 'up "configure.ss"))]
+                       [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))])
+                  k0))
+     
+     (test-suite
+      "Examples"
+      (test-equal? "hello.ss"
+                   (let* ([d (mkd (build-path example-servlets "hello.ss"))]
+                          [t0 (first ((sxpath "//p/text()") (call d url0 empty)))])
+                     t0)
+                   "Hello, Web!")
+      (test-equal? "add.ss"
+                   (let* ([d (mkd (build-path example-servlets "add.ss"))]
+                          [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
+                          [k1 (first ((sxpath "//form/@action/text()") (call d k0 (list (make-binding:form #"number" #"23")))))]
+                          [n (first ((sxpath "//p/text()") (call d k1 (list (make-binding:form #"number" #"12")))))])
+                     n)
+                   "The sum is 35")
+      (test-equal? "count.ss"
+                   (let* ([d (mkd (build-path example-servlets "count.ss"))]
+                          [ext (lambda (c)
+                                 (rest (regexp-match #rx"This servlet was called (.+) times and (.+) times since loaded on" c)))]
+                          [c1 (ext (first ((sxpath "//p/text()") (call d url0 empty))))]
+                          [c2 (ext (first ((sxpath "//p/text()") (call d url0 empty))))])
+                     (list c1 c2))
+                   (list (list "1" "1")
+                         (list "2" "1")))
+      (test-equal? "dir.ss"
+                   (let* ([d (mkd (build-path example-servlets "dir.ss"))]
+                          [t0 (first ((sxpath "//p/em/text()") (call d url0 empty)))])
+                     t0)
+                   (path->string example-servlets))
+      (test-pred "quiz.ss"
+                 string?
+                 (let* ([d (mkd (build-path example-servlets "quiz.ss"))])
+                   (foldl (lambda (_ k)
+                            (first ((sxpath "//form/@action/text()") (call d k (list (make-binding:form #"answer" #"0"))))))
+                          url0
+                          (build-list 7 (lambda (i) i))))))
+     
+     )))

collects/web-server/tests/util.ss

@@ -4,7 +4,13 @@
   (provide make-module-eval
            make-eval/mod-path
            make-mock-connection
-           redact)
+           redact
+           collect)
+  
+  (define (collect d req)
+    (define-values (c i o) (make-mock-connection #""))
+    (d c req)
+    (redact (get-output-bytes o)))
   
   (define (make-mock-connection ib)
     (define ip (open-input-bytes ib))