Adding tests

svn: r6455

collects/web-server/private/connection-manager.ss

@@ -1,7 +1,3 @@
-;; this is a trivial implementation of the connection-manger interface that
-;; uses timeouts instead of a queued-model.
-
-;; the queued-model is also fully implemented but won't be used at this time.
 (module connection-manager mzscheme
   (require "connection-structs.ss"
            "timer.ss"

collects/web-server/private/mime-types.ss

@@ -4,8 +4,30 @@
            (lib "string.ss"))
   (require "util.ss")
   (provide/contract
+   [read-mime-types (path? . -> . hash-table?)]
    [make-get-mime-type (path? . -> . (path? . -> . bytes?))])
   
+  ; read-mime-types : path? -> hash-table?
+  (define (read-mime-types a-path)
+    (define MIME-TYPE-TABLE (make-hash-table))
+    (with-input-from-file a-path
+      (lambda ()
+        (let loop ()
+          (match (read-line (current-input-port) 'any)
+            [(? eof-object?)
+             (void)]
+            [(regexp #"^([^\t ]+)[\t ]+(.+)$"
+                     (list s type exts))
+             (for-each (lambda (ext)
+                         (hash-table-put! MIME-TYPE-TABLE
+                                          (lowercase-symbol! ext)
+                                          type))
+                       (regexp-split #" " exts))
+             (loop)]
+            [_
+             (loop)]))))
+    MIME-TYPE-TABLE)
+  
   ;; make-get-mime-type : path? -> path? -> bytes?
   ;; determine the mime type based on the filename's suffix
   ;;
@@ -13,25 +35,10 @@
   ;; 1. Can we determine the mime type based on file contents?
   ;; 2. Assuming that 7-bit ASCII is correct for mime-type
   (define (make-get-mime-type a-path)
-    (let ([MIME-TYPE-TABLE (make-hash-table)]
+    (let ([MIME-TYPE-TABLE (read-mime-types a-path)]
           [DEFAULT-MIME-TYPE #"text/plain; charset=utf-8"]
           [file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")])
-      (with-input-from-file a-path
+      
-        (lambda ()
-          (let loop ()
-            (match (read-line (current-input-port) 'any)
-              [(? eof-object?)
-               (void)]
-              [(regexp #"^([^\t ]+)[\t ]+(.+)$"
-                       (list s type exts))
-               (for-each (lambda (ext)
-                           (hash-table-put! MIME-TYPE-TABLE
-                                            (lowercase-symbol! ext)
-                                            type))
-                         (regexp-split #" " exts))
-               (loop)]
-              [_
-               (loop)]))))
       (lambda (path)
         (match (regexp-match file-suffix-regexp (path->bytes path))
           [(list path-bytes sffx)

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

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide dispatch-files-tests)
   
+  ; XXX
   (define dispatch-files-tests
     (test-suite
      "Files")))

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

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide dispatch-lang-tests)
   
+  ; XXX
   (define dispatch-lang-tests
     (test-suite
      "Web Language")))

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

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide dispatch-passwords-tests)
   
+  ; XXX
   (define dispatch-passwords-tests
     (test-suite
      "Passwords")))

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

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide dispatch-servlets-tests)
   
+  ; XXX
   (define dispatch-servlets-tests
     (test-suite
      "Servlets")))

collects/web-server/tests/lang/abort-resume-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide abort-resume-tests)
   
+  ; XXX
   (define abort-resume-tests
     (test-suite
      "Abort Resume")))

collects/web-server/tests/lang/web-cells-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide web-cells-tests)
   
+  ; XXX
   (define web-cells-tests
     (test-suite
      "Web Cells")))

collects/web-server/tests/lang/web-extras-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide web-extras-tests)
   
+  ; XXX
   (define web-extras-tests
     (test-suite
      "Web Extras")))

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

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide web-tests)
   
+  ; XXX
   (define web-tests
     (test-suite
      "Web")))

collects/web-server/tests/private/cache-table-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide cache-table-tests)
   
+  ; XXX
   (define cache-table-tests
     (test-suite
      "Cache Table")))

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

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide connection-manager-tests)
   
+  ; XXX
   (define connection-manager-tests
     (test-suite
      "Connection Manager")))

collects/web-server/tests/private/mime-types-test.ss

@@ -1,7 +1,42 @@
 (module mime-types-test mzscheme
-  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+           (lib "file.ss")
+           (lib "mime-types.ss" "web-server" "private"))
   (provide mime-types-tests)
   
+  (define test-file (make-temporary-file))
+  (with-output-to-file test-file
+    (lambda ()
+      (printf #<<END
+video/mp4                       mp4
+video/mpeg                      mpeg mpg mpe
+END
+              ))
+    'replace)  
+  
   (define mime-types-tests
     (test-suite
-     "MIME Types")))
+     "MIME Types"
+     
+     (test-case
+      "Distribution mime.types parses"
+      (check-not-false (read-mime-types (build-path (collection-path "web-server") "default-web-root" "mime.types"))))
+     
+     (test-case
+      "Test file parses"
+      (check-not-false (read-mime-types test-file)))
+     (test-case
+      "Default mime-type given"
+      (check-equal? ((make-get-mime-type test-file) (build-path "test.html")) #"text/plain; charset=utf-8"))
+     (test-case
+      "MIME type resolves (single in file)"
+      (check-equal? ((make-get-mime-type test-file) (build-path "test.mp4")) #"video/mp4"))
+     (test-case
+      "MIME type resolves (multiple in file)"
+      (check-equal? ((make-get-mime-type test-file) (build-path "test.mpeg")) #"video/mpeg"))
+     (test-case
+      "MIME type resolves (multiple in file)"
+      (check-equal? ((make-get-mime-type test-file) (build-path "test.mpg")) #"video/mpeg"))
+     (test-case
+      "MIME type resolves (multiple in file)"
+      (check-equal? ((make-get-mime-type test-file) (build-path "test.mpe")) #"video/mpeg")))))

collects/web-server/tests/private/request-test.ss

@@ -36,6 +36,7 @@
                       (lambda (f s) s)))
   
   
+  ; XXX
   (define request-tests
     (test-suite
      "Request Parsing"

collects/web-server/tests/private/response-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide response-tests)
   
+  ; XXX
   (define response-tests
     (test-suite
      "HTTP Responses")))

collects/web-server/tests/private/servlet-test.ss

@@ -3,6 +3,7 @@
            (lib "servlet.ss" "web-server"))
   (provide servlet-tests)
   
+  ; XXX
   (define servlet-tests
     (test-suite
      "Servlets")))

collects/web-server/tests/private/session-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide session-tests)
   
+  ; XXX
   (define session-tests
     (test-suite
      "Sessions")))

collects/web-server/tests/private/url-param-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide url-param-tests)
   
+  ; XXX
   (define url-param-tests
     (test-suite
      "URL Parameters")))

collects/web-server/tests/private/util-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide util-tests)
   
+  ; XXX
   (define util-tests
     (test-suite
      "Utilities")))

collects/web-server/tests/servlet-test.ss

@@ -3,6 +3,7 @@
            (lib "servlet.ss" "web-server"))
   (provide servlet-tests)
   
+  ; XXX
   (define servlet-tests
     (test-suite
      "Servlets")))

collects/web-server/tests/servlet/basic-auth-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide basic-auth-tests)
   
+  ; XXX
   (define basic-auth-tests
     (test-suite
      "BASIC Authentication")))

collects/web-server/tests/servlet/bindings-test.ss

@@ -1,7 +1,33 @@
 (module bindings-test mzscheme
-  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+           (lib "bindings.ss" "web-server" "servlet"))
   (provide bindings-tests)
   
+  (define bs `([foo . 3] [foos . 1] [foos . 2]))
+  
   (define bindings-tests
     (test-suite
-     "Bindings")))
+     "Bindings"
+     
+     (test-case
+      "exists-binding? - true"
+      (check-true (exists-binding? 'foo bs)))
+     (test-case
+      "exists-binding? - false"
+      (check-false (exists-binding? 'bar bs)))
+     
+     (test-case
+      "extract-bindings"
+      (check-equal? (extract-bindings 'foos bs) (list 1 2)))
+     
+     (test-case
+      "extract-binding/single - success"
+      (check-equal? (extract-binding/single 'foo bs) 3))
+     (test-case
+      "extract-binding/single - failure"
+      (check-exn (lambda (exn) (regexp-match "not found" (exn-message exn)))
+                 (lambda () (extract-binding/single 'bar bs) 3)))
+     (test-case
+      "extract-binding/single - multiple"
+      (check-exn (lambda (exn) (regexp-match "multiple times" (exn-message exn)))
+                 (lambda () (extract-binding/single 'foos bs) 3))))))

collects/web-server/tests/servlet/helpers-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide helpers-tests)
   
+  ; XXX
   (define helpers-tests
     (test-suite
      "Helpers")))

collects/web-server/tests/servlet/servlet-url-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide servlet-url-tests)
   
+  ; XXX
   (define servlet-url-tests
     (test-suite
      "Servlet URLs")))

collects/web-server/tests/servlet/web-test.ss

@@ -2,6 +2,7 @@
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
   (provide web-tests)
   
+  ; XXX
   (define web-tests
     (test-suite
      "Web")))