up

svn: r9979

collects/web-server/private/util.ss

@@ -158,7 +158,7 @@
    (string-downcase
     (if (bytes? s)
         (bytes->string/utf-8 s)
-        (string-copy s)))))
+        s))))
 
 (define (directory-part path)
   (let-values ([(base name must-be-dir) (split-path path)])

collects/web-server/tests/dispatchers/all-dispatchers-tests.ss

@@ -4,6 +4,7 @@
          "dispatch-files-test.ss"        
          "dispatch-servlets-test.ss"
          "dispatch-lang-test.ss"         
+         "dispatch-host-test.ss"
          "filesystem-map-test.ss")
 (provide all-dispatchers-tests)
 
@@ -11,6 +12,7 @@
   (test-suite
    "Dispatchers"
    dispatch-passwords-tests
+   dispatch-host-tests
    dispatch-files-tests
    dispatch-servlets-tests
    dispatch-lang-tests

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

@@ -0,0 +1,57 @@
+#lang scheme/base
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+         (planet "util.ss" ("schematics" "schemeunit.plt" 2))
+         (only-in mzlib/file
+                  make-temporary-file)
+         net/url
+         mzlib/list
+         (lib "request-structs.ss" "web-server" "private")
+         (lib "dispatch.ss" "web-server" "dispatchers")
+         (prefix-in host: (lib "dispatch-host.ss" "web-server" "dispatchers")))
+(provide dispatch-host-tests)
+
+(require/expose (lib "dispatch-host.ss" "web-server" "dispatchers")
+                (get-host))
+
+(define lower-url (make-url #f #f "www.plt-scheme.org" #f #t empty empty #f))
+(define upper-url (make-url #f #f "www.PLT-scheme.org" #f #t empty empty #f))
+(define no-host-url (make-url #f #f #f #f #t empty empty #f))
+
+(define dispatch-host-tests
+  (test-suite
+   "Host"
+   
+   (test-equal? "get-host - uri - lower"
+                'www.plt-scheme.org
+                (get-host lower-url empty))
+   
+   (test-equal? "get-host - uri - upper"
+                'www.plt-scheme.org
+                (get-host upper-url empty))
+   
+   (test-equal? "get-host - headers - lower key - lower val"
+                'www.plt-scheme.org
+                (get-host no-host-url (list (make-header #"host" #"www.plt-scheme.org"))))
+   (test-equal? "get-host - headers - lower key - upper val"
+                'www.plt-scheme.org
+                (get-host no-host-url (list (make-header #"host" #"www.PLT-scheme.org"))))
+
+   (test-equal? "get-host - headers - upper key - lower val"
+                'www.plt-scheme.org
+                (get-host no-host-url (list (make-header #"Host" #"www.plt-scheme.org"))))
+   (test-equal? "get-host - headers - upper key - upper val"
+                'www.plt-scheme.org
+                (get-host no-host-url (list (make-header #"Host" #"www.PLT-scheme.org"))))
+
+   (test-equal? "get-host - headers - caps key - lower val"
+                'www.plt-scheme.org
+                (get-host no-host-url (list (make-header #"HOST" #"www.plt-scheme.org"))))
+   (test-equal? "get-host - headers - caps key - upper val"
+                'www.plt-scheme.org
+                (get-host no-host-url (list (make-header #"HOST" #"www.PLT-scheme.org"))))
+   
+   (test-equal? "get-host - none"
+                'none
+                (get-host no-host-url empty))
+   
+   ))