Lang tests

svn: r6599

collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss

@@ -0,0 +1,29 @@
+(module add06 (lib "lang.ss" "web-server")
+  (provide start)
+  
+  ;; get-number-from-user: string -> number
+  ;; ask the user for a number
+  (define (gn msg)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(hmtl (head (title ,(format "Get ~a number" msg)))
+              (body
+               (form ([action ,(url->string 
+                                (embed/url 
+                                 (lambda (req)
+                                   (string->number
+                                    (bytes->string/utf-8
+                                     (binding:form-value
+                                      (bindings-assq #"number" 
+                                                     (request-bindings/raw req))))))))]
+                      [method "post"]
+                      [enctype "application/x-www-form-urlencoded"])
+                     ,(format "Enter the ~a number to add: " msg)
+                     (input ([type "text"] [name "number"] [value ""]))
+                     (input ([type "submit"]))))))))
+  
+  (define (start initial-request)
+    `(html (head (title "Final Page"))
+           (body
+            (h1 "Final Page")
+            (p ,(format "The answer is ~a" (+ (gn "first") (gn "second"))))))))

collects/web-server/default-web-root/htdocs/lang-servlets/temp.ss

@@ -1,18 +0,0 @@
-(module temp (lib "lang.ss" "web-server")
-  (provide start)
-  
-  (define msg (make-parameter "unknown"))
-  
-  (define (gn should-be i)
-    (let/cc k
-      (printf "~S == ~S~n" should-be (msg))
-      i))
-  
-  (define (start)
-    '(fun . #t)
-    (printf "12 + 1 = 13 = ~S~n"
-            (+
-             (parameterize ([msg "first"])
-               (gn "first" 12))
-             (parameterize ([msg "second"])
-               (gn "second" 1))))))

collects/web-server/default-web-root/htdocs/lang-servlets/toobig.ss

@@ -1,37 +0,0 @@
-(module toobig (lib "lang.ss" "web-server")
-  (provide start)
-  
-  (define (get-n)
-    (let ([req
-           (send/suspend/url
-            (lambda (k-url)
-              `(html (head (title "How many bytes?"))
-                     (body
-                      (form ([action ,(url->string k-url)]
-                             [method "POST"]
-                             [enctype "application/x-www-form-urlencoded"])
-                            "How many bytes? (Try 1024)"
-                            (input ([type "text"] [name "number"] [value ""]))
-                            (input ([type "submit"])))))))])
-      (string->number
-       (bytes->string/utf-8
-        (binding:form-value
-         (bindings-assq #"number" 
-                        (request-bindings/raw req)))))))
-  
-  (define (get-bytes)
-    (let* ([the-bytes
-            (make-bytes (get-n) (char->integer #\!))]
-           [req
-            (send/suspend/url
-             (lambda (k-url)
-               `(html (head (title "How are these bytes?"))
-                      (body
-                       (h3 ,(bytes->string/utf-8 the-bytes))
-                       (a ([href ,(url->string k-url)]) "OK!")))))])
-      the-bytes))
-  
-  (define (start initial-request)
-    `(html (head (title "You got here!"))
-           (body
-            (h1 ,(bytes->string/utf-8 (get-bytes)))))))

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

@@ -1,20 +1,138 @@
 (module dispatch-lang-test mzscheme
-  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+           (planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
+           (lib "etc.ss")
+           (lib "list.ss")
+           (lib "request-structs.ss" "web-server" "private")
+           (lib "namespace.ss" "web-server" "configuration")
+           (prefix lang: (lib "dispatch-lang.ss" "web-server" "dispatchers"))
+           "../util.ss")
   (provide dispatch-lang-tests)
   
+  (define (mkd p)
+    (lang:make #:url->path (lambda _ (values p url0s))
+               #:make-servlet-namespace
+               (make-make-servlet-namespace)
+               #:responders-servlet-loading
+               (lambda (u exn)
+                 ((error-display-handler) (exn-message exn) exn)
+                 (raise exn))
+               #:responders-servlet
+               (lambda (u exn)
+                 ((error-display-handler) (exn-message exn) exn)
+                 (raise exn))))
+  (define url0 "http://test.com/servlets/example.ss")
+  (define url0s (list (build-path "servlets") (build-path "example.ss")))
+  
+  (define example-servlets (build-path (collection-path "web-server") "default-web-root" "htdocs" "lang-servlets/"))
+  
+  (define (test-add-two-numbers t p)
+    (let* ([x (random 500)]
+           [xs (string->bytes/utf-8 (number->string x))]
+           [y (random 500)]
+           [ys (string->bytes/utf-8 (number->string y))])
+      (test-equal? 
+       t
+       (let* ([d (mkd p)]
+              [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
+              [k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
+                                                                 (list (make-binding:form #"number" xs)))))]
+              [n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
+                                                     (list (make-binding:form #"number" ys)))))])
+         n)
+       (format "The answer is ~a" (+ x y)))))
+  
+  (define (test-double-counters t p)
+    (define d (mkd p))
+    (define (invoke u)
+      (define sx (call d u empty))
+      (define ks ((sxpath "//div/div/a/@href/text()") sx))
+      (values ((sxpath "//div/div/h3/text()") sx)
+              (first ks)
+              (second ks)))
+    (test-equal? t
+                 (let*-values ([(v0.0 0.0+1 0.0+2) (invoke url0)]
+                               ; One add
+                               [(v1.0 1.0+1 1.0+2) (invoke 0.0+1)]
+                               [(v0.1 0.1+1 0.1+2) (invoke 0.0+2)]
+                               ; Two adds
+                               [(v2.0 2.0+1 2.0+2) (invoke 1.0+1)]
+                               [(v1.1 1.1+1 1.1+2) (invoke 0.1+1)]
+                               [(_v1.1 _1.1+1 _1.1+2) (invoke 1.0+2)]
+                               [(v0.2 0.2+1 0.2+2) (invoke 0.1+2)])
+                   (list v0.0
+                         v1.0 v0.1
+                         v2.0 v1.1 _v1.1 v0.2))
+                 (list (list "0" "0")
+                       (list "1" "0") (list "0" "1")
+                       (list "2" "0") (list "1" "1") (list "1" "1") (list "0" "2"))))
+  
   (define dispatch-lang-tests
     (test-suite
      "Web Language"
+          
+     (test-add-two-numbers
+      "add-param.ss - Parameters, s/s/u (should fail)"
+      (build-path example-servlets "add-param.ss"))
      
-     ; XXX test web.ss
+     (test-add-two-numbers
-     (test-suite
+      "add-simple.ss - Web Parameters, s/s/u"
-      "web.ss")
+      (build-path example-servlets "add-simple.ss"))
-
-     ; XXX test web-extras.ss
-     (test-suite
-      "web-extras.ss")
      
-     ; XXX test web-cells.ss
+     (test-add-two-numbers
-     (test-suite
+      "add.ss - s/s/u"
-      "web-cell.ss")
+      (build-path example-servlets "add.ss"))
+     
+     ; XXX
+     (let* ([x (random 500)]
+            [xs (string->bytes/utf-8 (number->string x))]
+            [y (random 500)]
+            [ys (string->bytes/utf-8 (number->string y))])
+       (test-equal? 
+        "add01.ss - no s/s, uri"
+        (let* ([d (mkd (build-path example-servlets "add01.ss"))]
+               [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
+               [k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?first=~a" k0 xs) (list (make-binding:form #"first" xs)))))]
+               [n (first ((sxpath "//p/text()") (call d (format "~a?first=~a&second=~a" k1 xs ys)
+                                                      (list (make-binding:form #"first" xs)
+                                                            (make-binding:form #"second" ys)))))])
+          n)
+        (format "The answer is ~a" (+ x y))))
+     
+     (test-add-two-numbers
+      "add02.ss - s/s/u, uri"
+      (build-path example-servlets "add02.ss"))
+     
+     ; XXX
+     (test-add-two-numbers
+      "add03.ss - s/s/h"
+      (build-path example-servlets "add03.ss"))
+     
+     (test-add-two-numbers
+      "add04.ss - s/s/u"
+      (build-path example-servlets "add04.ss"))
+     
+     (test-add-two-numbers
+      "add05.ss - extract-proc/url and embed-proc/url"
+      (build-path example-servlets "add05.ss"))
+     
+     (test-add-two-numbers
+      "add06.ss - send/suspend/dispatch"
+      (build-path example-servlets "add06.ss"))
+     
+     (test-double-counters
+      "wc-fake.ss - no cells"
+      (build-path example-servlets "wc-fake.ss"))
+     
+     (test-double-counters
+      "wc.ss - make-web-cell web-cell-ref web-cell-shadow"
+      (build-path example-servlets "wc.ss"))
+     
+     (test-double-counters
+      "wc-comp.ss - make-web-cell web-cell-ref web-cell-shadow web-cell-component"
+      (build-path example-servlets "wc-comp.ss"))
+     
+     ; XXX test web-extras.ss - redirect/get
+     ; XXX test web-cells.ss - web-cell?
+     ; XXX test check-dir.ss quiz-lib.ss quiz01.ss quiz02.ss
      )))

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

@@ -1,12 +1,8 @@
 (module dispatch-servlets-test mzscheme
   (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 "etc.ss")
-           (lib "url.ss" "net")
            (lib "list.ss")
-           (lib "pretty.ss")
            (lib "request-structs.ss" "web-server" "private")
            (lib "cache-table.ss" "web-server" "private")
            (lib "web-server-structs.ss" "web-server" "private")
@@ -30,12 +26,6 @@
     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/"))

collects/web-server/tests/util.ss

@@ -1,11 +1,26 @@
 (module util mzscheme
   (require (lib "connection-manager.ss" "web-server" "private")
+           (only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
+                 ssax:xml->sxml)
+           (lib "request-structs.ss" "web-server" "private")
+           (lib "url.ss" "net")
+           (lib "pretty.ss")
+           (lib "list.ss")
            (lib "timer.ss" "web-server" "private"))
   (provide make-module-eval
            make-eval/mod-path
            make-mock-connection
            redact
-           collect)
+           collect
+           htxml
+           call)
+  
+  (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 (collect d req)
     (define-values (c i o) (make-mock-connection #""))