fixed url code in various ways

svn: r1752 original commit: c6992e0307
2006-01-03 14:02:25 +00:00 · 2006-01-03 14:02:25 +00:00 · 1a8d0070b7
commit 1a8d0070b7
parent 18ac669ebc
1 changed files with 142 additions and 37 deletions
--- a/collects/tests/mzscheme/net.ss
+++ b/collects/tests/mzscheme/net.ss
@ -140,11 +140,12 @@

 (let ()
  (define (test-s->u vec str)
-    (define (string->url/vec str) (url->vec (string->url str)))
-    (define (url/vec->string vec) (url->string (vec->url vec)))
    (test vec string->url/vec str)
    (test str url/vec->string vec))
  
+  (define (string->url/vec str) (url->vec (string->url str)))
+  (define (url/vec->string vec) (url->string (vec->url vec)))
+
  (define (test-c-u/r expected base relative)
    (define (combine-url/relative-vec x y)
      (url->vec (combine-url/relative (vec->url x) y)))
@ -156,82 +157,104 @@
     (vector-ref vec 1)
     (vector-ref vec 2)
     (vector-ref vec 3)
-     (map (lambda (x) (if (string? x)
-                          x
-                          (make-path/param (vector-ref x 0) (vector-ref x 1))))
-          (vector-ref vec 4))
-     (vector-ref vec 5)
-     (vector-ref vec 6)))
+     (vector-ref vec 4)
+     (map (lambda (x)
+            (let ([lst (vector->list x)])
+              (make-path/param (car lst) (cdr lst))))
+          (vector-ref vec 5))
+     (vector-ref vec 6)
+     (vector-ref vec 7)))
  
  (define (url->vec url)
    (vector (url-scheme url)
            (url-user url)
            (url-host url)
            (url-port url)
-            (map (lambda (x) (if (string? x)
-                                 x
-                                 (vector (path/param-path x) (path/param-param x))))
+            (url-path-absolute? url)
+            (map (lambda (x) (list->vector (cons (path/param-path x) (path/param-param x))))
                 (url-path url))
            (url-query url)
            (url-fragment url)))
  
-  (test-s->u (vector #f #f #f #f '("") '() #f)
+  (test-s->u (vector #f #f #f #f #t '(#("")) '() #f)
             "/")
-  (test-s->u (vector #f #f #f #f '() '() #f)
+  (test-s->u (vector #f #f #f #f #f '() '() #f)
             "")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f '("") '() #f)
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #f '() '() #f)
+             "http://www.drscheme.org")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t '(#("")) '() #f)
             "http://www.drscheme.org/")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '() #f)
+  
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '() #f)
             "http://www.drscheme.org/a/b/c")
-  (test-s->u (vector "http" "robby" "www.drscheme.org" #f (list "a" "b" "c") '() #f)
+  (test-s->u (vector "http" "robby" "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '() #f)
             "http://robby@www.drscheme.org/a/b/c")
-  (test-s->u (vector "http" #f "www.drscheme.org" 8080 (list "a" "b" "c") '() #f)
+  (test-s->u (vector "http" #f "www.drscheme.org" 8080 #t (list #("a") #("b") #("c")) '() #f)
             "http://www.drscheme.org:8080/a/b/c")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '() "joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '() "joe")
             "http://www.drscheme.org/a/b/c#joe")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tim . "")) #f)
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tim . "")) #f)
             "http://www.drscheme.org/a/b/c?tim=")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tim . "")) "joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tim . "")) "joe")
             "http://www.drscheme.org/a/b/c?tim=#joe")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tim . "tim")) "joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tim . "tim")) "joe")
             "http://www.drscheme.org/a/b/c?tim=tim#joe")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom")) "joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tam . "tom")) "joe")
             "http://www.drscheme.org/a/b/c?tam=tom#joe")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom") (pam . "pom")) "joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tam . "tom") (pam . "pom")) "joe")
             "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe")
  (parameterize ([current-alist-separator-mode 'semi])  
-    (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom") (pam . "pom")) "joe")
+    (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tam . "tom") (pam . "pom")) "joe")
 	       "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe"))
  (parameterize ([current-alist-separator-mode 'amp])  
-    (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom") (pam . "pom")) "joe")
+    (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((tam . "tom") (pam . "pom")) "joe")
 	       "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe"))
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" #("c" "b")) '() #f)
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c" "b")) '() #f)
             "http://www.drscheme.org/a/b/c;b")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list #("a" "x") "b" #("c" "b")) '() #f)
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a" "x") #("b") #("c" "b")) '() #f)
             "http://www.drscheme.org/a;x/b/c;b")
    
  ;; test unquoting for %
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((ti#m . "")) "jo e")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a") #("b") #("c")) '((ti#m . "")) "jo e")
             "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e")
-  (test-s->u (vector "http" #f "www.drscheme.org" #f (list #("a " " a") " b " " c ") '() #f)
-             "http://www.drscheme.org/a ; a/ b / c ")
-  (test-s->u (vector "http" "robb y" "www.drscheme.org" #f '("") '() #f)
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a " " a") #(" b ") #(" c ")) '() #f)
+             "http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20")
+  (test-s->u (vector "http" "robb y" "www.drscheme.org" #f #t '(#("")) '() #f)
             "http://robb%20y@www.drscheme.org/")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("%a") #("b/") #("c")) '() #f)
+             "http://www.drscheme.org/%25a/b%2f/c")
  
-  (test-s->u (vector "mailto" #f #f #f '("robby@plt-scheme.org") () #f)
+  ;; test the characters that need to be encoded in paths vs those that do not need to 
+  ;; be encoded in paths
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("a:@!$&'()*+,=z") #("/?#[];") #("")) '() #f)
+             "http://www.drscheme.org/a:@!$&'()*+,=z/%2f%3f%23%5b%5d%3b/")
+  
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #(".") #("..") '#(same) '#(up) #("...") #("abc.def")) '() #f)
+             "http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) '() #f)
+             "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;")
+
+
+  (test (vector "http" "ROBBY" "www.drscheme.org" 80 #t '(#("INDEX.HTML" "XXX")) '((T . "P")) "YYY")
+        string->url/vec
+        "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY")
+  
+  (test-s->u (vector "mailto" #f #f #f #f '(#("robby@plt-scheme.org")) '() #f)
             "mailto:robby@plt-scheme.org")
  
-  (let ([empty-url (make-url #f #f #f #f '() '() #f)])
+  (let ([empty-url (make-url #f #f #f #f #f '() '() #f)])
    (test-c-u/r (string->url "http://www.drscheme.org")
                empty-url
-                "http://www.drscheme.org")
+                "http://www.drscheme.org"))
+
  (test-c-u/r (string->url "http://www.drscheme.org")
              (string->url "http://www.drscheme.org")
-                ""))
+              "")
  
  (test-c-u/r (string->url "http://www.mzscheme.org")
              (string->url "http://www.drscheme.org/")
              "http://www.mzscheme.org")
+  
  (test-c-u/r (string->url "http://www.drscheme.org/index.html")
              (string->url "http://www.drscheme.org/")
              "index.html")
@ -253,6 +276,25 @@
  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/d/index.html")
              (string->url "http://www.drscheme.org/a/b/c/")
              "d/index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/")
+              "../index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/")
+              "./index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/%2e%2e/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/")
+              "%2e%2e/index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/index.html")
+              (string->url "http://www.drscheme.org/a/b/../c/")
+              "../index.html")
+  
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/d/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/d/index.html#ghijkl")
+              "index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/d/index.html#abcdef")
+              (string->url "http://www.drscheme.org/a/b/c/d/index.html#ghijkl")
+              "#abcdef")

  (test-c-u/r (string->url "file:///a/b/c/d/index.html")
              (string->url "file:///a/b/c/")
@ -260,6 +302,69 @@
  (test-c-u/r (string->url "file:///a/b/d/index.html")
              (string->url "file:///a/b/c")
              "d/index.html")
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; tests from rfc 3986
+  ;;
+  
+  (for-each
+   (λ (line)
+     (test-c-u/r (string->url (caddr line))
+                 (string->url "http://a/b/c/d;p?q")
+                 (car line)))
+   '(("g:h"           =  "g:h")
+     ("g"             =  "http://a/b/c/g")
+     ("./g"           =  "http://a/b/c/g")
+     ("g/"            =  "http://a/b/c/g/")
+     ("/g"            =  "http://a/g")
+     ("//g"           =  "http://g")
+     ("?y"            =  "http://a/b/c/d;p?y")
+     ("g?y"           =  "http://a/b/c/g?y")
+     ("#s"            =  "http://a/b/c/d;p?q#s")
+     ("g#s"           =  "http://a/b/c/g#s")
+     ("g?y#s"         =  "http://a/b/c/g?y#s")
+     (";x"            =  "http://a/b/c/;x")
+     ("g;x"           =  "http://a/b/c/g;x")
+     ("g;x?y#s"       =  "http://a/b/c/g;x?y#s")
+     (""              =  "http://a/b/c/d;p?q")
+     ("."             =  "http://a/b/c/")
+     ("./"            =  "http://a/b/c/")
+     (".."            =  "http://a/b/")
+     ("../"           =  "http://a/b/")
+     ("../g"          =  "http://a/b/g")
+     ("../.."         =  "http://a/")
+     ("../../"        =  "http://a/")
+     ("../../g"       =  "http://a/g")
+     
+     ;; abnormal examples follow
+     
+     ("../../../g"    =  "http://a/g")
+     ("../../../../g" =  "http://a/g")
+
+     ("/./g"          =  "http://a/g")
+     ("/../g"         =  "http://a/g")
+     ("g."            =  "http://a/b/c/g.")
+     (".g"            =  "http://a/b/c/.g")
+     ("g.."           =  "http://a/b/c/g..")
+     ("..g"           =  "http://a/b/c/..g")
+     
+     ("./../g"        =  "http://a/b/g")
+     ("./g/."         =  "http://a/b/c/g/")
+     ("g/./h"         =  "http://a/b/c/g/h")
+     ("g/../h"        =  "http://a/b/c/h")
+     ("g;x=1/./y"     =  "http://a/b/c/g;x=1/y")
+     ("g;x=1/../y"    =  "http://a/b/c/y")
+     
+     ("g?y/./x"       =  "http://a/b/c/g?y/./x")
+     ("g?y/../x"      =  "http://a/b/c/g?y/../x")
+     ("g#s/./x"       =  "http://a/b/c/g#s/./x")
+     ("g#s/../x"      =  "http://a/b/c/g#s/../x")
+     ("http:g"        =  "http:g")         ; for strict parsers
+
+     ))
+
+  
  )

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;