source: project/release/4/uri-generic/trunk/tests/run.scm @ 12719

(require-extension srfi-1)
(load "../uri-generic.scm")
(import uri-generic)
(require-extension test)

;; test cases from Python URI implementation

(define  path-cases
  '(("foo:xyz" "bar:abc" "bar:abc")
     ("http://example/x/y/z" "http://example/x/abc" "../abc")
     ("http://example2/x/y/z" "http://example/x/abc" "//example/x/abc")
     ("http://ex/x/y/z" "http://ex/x/r" "../r")

    ("http://ex/x/y"  "http://ex/x/q/r" "./q/r")
    ("http://ex/x/y"  "http://ex/x/q/r#s" "./q/r#s")
    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "./q/r#s/t")
    ("http://ex/x/y"  "ftp://ex/x/q/r" "ftp://ex/x/q/r")
    ("http://ex/x/y"  "http://ex/x/y"   "")
    ("http://ex/x/y/" "http://ex/x/y/"  "")
    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "")
    ("http://ex/x/y/" "http://ex/x/y/z/" "./z/")
    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal")
    ("file:/e/x/y/z" "file:/e/x/abc" "../abc")
    ("file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc")   
    ("file:/ex/x/y/z" "file:/ex/x/r" "../r")
    ("file:/ex/x/y/z" "file:/r" "/r")        
    ("file:/ex/x/y" "file:/ex/x/q/r" "./q/r")
    ("file:/ex/x/y" "file:/ex/x/q/r#s" "./q/r#s")
    ("file:/ex/x/y" "file:/ex/x/q/r#" "./q/r#")
    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "./q/r#s/t")
    ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r")
    ("file:/ex/x/y" "file:/ex/x/y" "")
    ("file:/ex/x/y/" "file:/ex/x/y/" "")
    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "")
    ("file:/ex/x/y/" "file:/ex/x/y/z/" "./z/")
    ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
     "//meetings.example.com/cal#m1")
    ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
     "//meetings.example.com/cal#m1")
    ("file:/some/dir/foo" "file:/some/dir/#blort" "./#blort")
    ("file:/some/dir/foo" "file:/some/dir/#" "./#")
    ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000
   ("http://example/x/y%2Fz"  "http://example/x/abc"     "./abc")
   ("http://example/x/y/z"    "http://example/x%2Fabc"   "/x%2Fabc")
   ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "/x%2Fabc")
   ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "./abc")
   ;; Ryan Lee
   ("http://example/x/abc.efg" "http://example/x/" "./")
   ))

(define base "http://a/b/c/d;p?q")

(define rfc-cases
  `((,base "g:h" "g:h")
    (,base "g" "http://a/b/c/g")
    (,base "./g" "http://a/b/c/g")
    (,base "g/" "http://a/b/c/g/")
    (,base "/g" "http://a/g")
    (,base "//g" "http://g")
    (,base "?y" "http://a/b/c/?y") 
    (,base "g?y" "http://a/b/c/g?y")
    (,base "#s" "http://a/b/c/d;p?q#s") 
    (,base "g#s" "http://a/b/c/g#s")
    (,base "g?y#s" "http://a/b/c/g?y#s")
    (,base ";x" "http://a/b/c/;x")
    (,base "g;x" "http://a/b/c/g;x")
    (,base "g;x?y#s" "http://a/b/c/g;x?y#s")
    (,base "."  "http://a/b/c/")
    (,base "./" "http://a/b/c/")
    (,base ".." "http://a/b/")
    (,base "../" "http://a/b/")
    (,base "../g" "http://a/b/g")
    (,base "../.." "http://a/")
    (,base "../../" "http://a/")
    (,base "../../g" "http://a/g")
    ))

(define extra-cases
  `((,base "" ,base)
    (,base "../../../g" "http://a/g") 
    (,base "../../../../g" "http://a/g") 
    (,base "/./g" "http://a/g")
    (,base "/../g" "http://a/g")
    (,base "g.." "http://a/b/c/g..")
    (,base "..g" "http://a/b/c/..g")
    
    (,base "./../g" "http://a/b/g")
    (,base "./g/." "http://a/b/c/g/") 
    (,base "g/./h" "http://a/b/c/g/h") 
    (,base "g/../h" "http://a/b/c/h")
    (,base "g;x=1/./y" "http://a/b/c/g;x=1/y") 
    (,base "g;x=1/../y" "http://a/b/c/y")  
    
    (,base "g?y/./x" "http://a/b/c/g?y/./x")
    (,base "g?y/../x" "http://a/b/c/g?y/../x")
    (,base "g#s/./x" "http://a/b/c/g#s/./x")
    (,base "g#s/../x" "http://a/b/c/g#s/../x")
    
    ("?a=b&c=d" "" "?a=b&c=d")
    (,base "" "http://a/b/c/d;p?q")
    ("" ,base "http://a/b/c/d;p?q")
    (,base "http:" "http:")
    (,base "..%2f" "http://a/b/c/..%2f")
    ))

(test-group "uri test"
  (for-each (lambda (p)
              (let ((ubase (uri-reference (first p)))
                    (urabs  (uri-reference (second p)))
                    (uabs  (absolute-uri (second p)))
                    (uex   (uri-reference (third p))))
                (let* ((from (uri-relative-from urabs ubase))
                       (to    (uri-relative-to from ubase)))
                  (test (apply sprintf "~S * ~S -> ~S" p) uex from)
                  (test (apply sprintf "~S * ~S -> ~S" p) urabs to)
                  (if (not (uri-fragment urabs))
                      (test (sprintf "~S = ~S" uabs urabs) urabs uabs))
                  ))
              (for-each
               (lambda (s)
                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
                       s (uri->string (uri-reference s))))
               p))
            path-cases))

(test-group "rfc test"
  (for-each (lambda (p)
              (let ((ubase (uri-reference (first p)))
                    (urabs  (uri-reference (second p)))
                    (uex   (uri-reference (third p))))
                (let* ((to    (uri-relative-to urabs ubase)))
                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
                  ))
              (for-each
               (lambda (s)
                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
                       s (uri->string (uri-reference s))))
               p))
            rfc-cases))

(test-group "extra-test"
  (for-each (lambda (p)
              (let ((ubase (uri-reference (first p)))
                    (urabs  (uri-reference (second p)))
                    (uex   (uri-reference (third p))))
                (let* ((to    (uri-relative-to urabs ubase)))
                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
                  )))
            extra-cases))

(define encode/decode-cases
  '(("foo?bar" "foo%3fbar")
    ("foo&bar" "foo%26bar")
    ("foo%20bar" "foo%2520bar")))

(test-group "uri-encode-string test"
  (for-each (lambda (p)
              (let ((expected (second p))
                    (encoded (uri-encode-string (first p))))
                  (test (sprintf "~S -> ~S" (first p) expected) expected encoded)))
            encode/decode-cases))

(test-group "uri-decode-string test"
  (for-each (lambda (p)
              (let ((expected (first p))
                    (decoded (uri-decode-string (second p))))
                  (test (sprintf "~S -> ~S" (second p) expected) expected decoded)))
            encode/decode-cases))

(define update-cases
  '(("/foo" (path: ("/bar")) "/bar")
    ("/foo" (host: "localhost") "//localhost/foo")
    ("http://foo" (query: ((a . "b") (c . #t) (d . "e"))) "http://foo?a=b&c&d=e")
    ("http://foo" (host: #f) "http:")
    ("http://foo" (authority: #f) "http:")))

(test-group "update-uri test"
  (for-each (lambda (p)
              (let ((expected (uri-reference (third p)))
                    (updated (apply update-uri (uri-reference (first p)) (second p))))
                  (test (sprintf "~S * ~S -> ~S" (first p) (second p) (third p)) expected updated)))
            update-cases))

(define normalize-case-cases
  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
    ("http://EXA%2fMPLE/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
    ("HTTP://example/" "http://example/")
    ("http://user:PASS@example/FOO%2fbar" "http://user:PASS@example/FOO%2Fbar")
    ("http://uS%2fer:PA%2fSS@example/FOO%2fbar" "http://uS%2Fer:PA%2FSS@example/FOO%2Fbar")
    ("HTTP://example/?mooH=MUMBLe%2f" "http://example/?mooH=MUMBLe%2F")
    ("http://example/#baR%2f" "http://example/#baR%2F")))

(test-group "normalize-case test"
  (for-each (lambda (p)
              (let ((case-normalized (uri-normalize-case (uri-reference (first p))))
                    (expected (second p)))
                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
            normalize-case-cases))