source: project/release/3/uri-generic/trunk/tests/run.scm @ 13212

Last change on this file since 13212 was 13212, checked in by sjamaan, 12 years ago

Merge latest changes in release 4 trunk

File size: 12.8 KB
Line 
1(require-extension srfi-1)
2(load "../uri-generic.scm")
3
4(require-extension test)
5
6;; test cases from Python URI implementation
7
8(define  path-cases
9  '(("foo:xyz" "bar:abc" "bar:abc")
10     ("http://example/x/y/z" "http://example/x/abc" "../abc")
11     ("http://example2/x/y/z" "http://example/x/abc" "//example/x/abc")
12     ("http://ex/x/y/z" "http://ex/x/r" "../r")
13
14    ("http://ex/x/y"  "http://ex/x/q/r" "./q/r")
15    ("http://ex/x/y"  "http://ex/x/q/r#s" "./q/r#s")
16    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "./q/r#s/t")
17    ("http://ex/x/y"  "ftp://ex/x/q/r" "ftp://ex/x/q/r")
18    ("http://ex/x/y"  "http://ex/x/y"   "")
19    ("http://ex/x/y/" "http://ex/x/y/"  "")
20    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "")
21    ("http://ex/x/y/" "http://ex/x/y/z/" "./z/")
22    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal")
23    ("file:/e/x/y/z" "file:/e/x/abc" "../abc")
24    ("file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc")   
25    ("file:/ex/x/y/z" "file:/ex/x/r" "../r")
26    ("file:/ex/x/y/z" "file:/r" "/r")       
27    ("file:/ex/x/y" "file:/ex/x/q/r" "./q/r")
28    ("file:/ex/x/y" "file:/ex/x/q/r#s" "./q/r#s")
29    ("file:/ex/x/y" "file:/ex/x/q/r#" "./q/r#")
30    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "./q/r#s/t")
31    ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r")
32    ("file:/ex/x/y" "file:/ex/x/y" "")
33    ("file:/ex/x/y/" "file:/ex/x/y/" "")
34    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "")
35    ("file:/ex/x/y/" "file:/ex/x/y/z/" "./z/")
36    ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
37     "//meetings.example.com/cal#m1")
38    ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
39     "//meetings.example.com/cal#m1")
40    ("file:/some/dir/foo" "file:/some/dir/#blort" "./#blort")
41    ("file:/some/dir/foo" "file:/some/dir/#" "./#")
42    ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000
43   ("http://example/x/y%2Fz"  "http://example/x/abc"     "./abc")
44   ("http://example/x/y/z"    "http://example/x%2Fabc"   "/x%2Fabc")
45   ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "/x%2Fabc")
46   ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "./abc")
47   ;; Ryan Lee
48   ("http://example/x/abc.efg" "http://example/x/" "./")
49   ))
50
51(define base "http://a/b/c/d;p?q")
52
53(define rfc-cases
54  `((,base "g:h" "g:h")
55    (,base "g" "http://a/b/c/g")
56    (,base "./g" "http://a/b/c/g")
57    (,base "g/" "http://a/b/c/g/")
58    (,base "/g" "http://a/g")
59    (,base "//g" "http://g")
60    (,base "?y" "http://a/b/c/?y") 
61    (,base "g?y" "http://a/b/c/g?y")
62    (,base "#s" "http://a/b/c/d;p?q#s") 
63    (,base "g#s" "http://a/b/c/g#s")
64    (,base "g?y#s" "http://a/b/c/g?y#s")
65    (,base ";x" "http://a/b/c/;x")
66    (,base "g;x" "http://a/b/c/g;x")
67    (,base "g;x?y#s" "http://a/b/c/g;x?y#s")
68    (,base "."  "http://a/b/c/")
69    (,base "./" "http://a/b/c/")
70    (,base ".." "http://a/b/")
71    (,base "../" "http://a/b/")
72    (,base "../g" "http://a/b/g")
73    (,base "../.." "http://a/")
74    (,base "../../" "http://a/")
75    (,base "../../g" "http://a/g")
76    ))
77
78(define extra-cases
79  `((,base "" ,base)
80    (,base "../../../g" "http://a/g") 
81    (,base "../../../../g" "http://a/g")
82    (,base "../../../.." "http://a/") ; Is this correct? Or http://a ?
83    (,base "../../../../" "http://a/")
84    (,base "/./g" "http://a/g")
85    (,base "/../g" "http://a/g")
86    (,base "g.." "http://a/b/c/g..")
87    (,base "..g" "http://a/b/c/..g")
88   
89    (,base "./../g" "http://a/b/g")
90    (,base "./g/." "http://a/b/c/g/") 
91    (,base "g/./h" "http://a/b/c/g/h") 
92    (,base "g/../h" "http://a/b/c/h")
93    (,base "g;x=1/./y" "http://a/b/c/g;x=1/y") 
94    (,base "g;x=1/../y" "http://a/b/c/y") 
95   
96    (,base "g?y/./x" "http://a/b/c/g?y/./x")
97    (,base "g?y/../x" "http://a/b/c/g?y/../x")
98    (,base "g#s/./x" "http://a/b/c/g#s/./x")
99    (,base "g#s/../x" "http://a/b/c/g#s/../x")
100   
101    ("?a=b&c=d" "" "?a=b&c=d")
102    (,base "" "http://a/b/c/d;p?q")
103    ("" ,base "http://a/b/c/d;p?q")
104    (,base "http:" "http:")
105    (,base "..%2f" "http://a/b/c/..%2f")
106    ("http://a/b/c/d/" ".." "http://a/b/c/")
107    ("http://a/b/c/d/" "../e" "http://a/b/c/e")
108    ("http://a/b/c/d/" "../e/" "http://a/b/c/e/")
109    ("http://a/b//c///d///" "..//.." "http://a/b/")
110    ("http://a" "b" "http://a/b") ; RFC3986, section 5.2.3, first bullet point
111    ))
112
113(define reverse-extra-cases
114  `((,base ,base "")
115    (,base "http://a/b/c/e" "./e")
116    (,base "http://a/b/e" "../e")
117    (,base "http://a/" "/") ;; or "../../"
118    (,base "http://a" "//a") ; No relative representation possible
119    (,base "http://b" "//b")
120    (,base "http://b/" "//b/")
121    (,base "http://b/c" "//b/c")
122    (,base "ftp://a/b/c/d;p?q" "ftp://a/b/c/d;p?q")
123    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")))
124
125(test-group "uri test"
126  (for-each (lambda (p)
127              (let ((ubase (uri-reference (first p)))
128                    (urabs  (uri-reference (second p)))
129                    (uabs  (absolute-uri (second p)))
130                    (uex   (uri-reference (third p))))
131                (let* ((from (uri-relative-from urabs ubase))
132                       (to    (uri-relative-to from ubase)))
133                  (test (apply sprintf "~S * ~S -> ~S" p) uex from)
134                  (test (apply sprintf "~S * ~S -> ~S" p) urabs to)
135                  (if (not (uri-fragment urabs))
136                      (test (sprintf "~S = ~S" uabs urabs) urabs uabs))
137                  ))
138              (for-each
139               (lambda (s)
140                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
141                       s (uri->string (uri-reference s))))
142               p))
143            path-cases))
144
145(test-group "rfc test"
146  (for-each (lambda (p)
147              (let ((ubase (uri-reference (first p)))
148                    (urabs  (uri-reference (second p)))
149                    (uex   (uri-reference (third p))))
150                (let* ((to    (uri-relative-to urabs ubase)))
151                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
152                  ))
153              (for-each
154               (lambda (s)
155                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
156                       s (uri->string (uri-reference s))))
157               p))
158            rfc-cases))
159
160(test-group "extra-test"
161  (for-each (lambda (p)
162              (let ((ubase (uri-reference (first p)))
163                    (urabs  (uri-reference (second p)))
164                    (uex   (uri-reference (third p))))
165                (let* ((to    (uri-relative-to urabs ubase)))
166                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
167                  )))
168            extra-cases))
169
170(test-group "reverse-extra-test"
171  (for-each (lambda (p)
172              (let ((ubase (uri-reference (first p)))
173                    (urabs  (uri-reference (second p)))
174                    (uex   (uri-reference (third p))))
175                (let* ((to    (uri-relative-from urabs ubase)))
176                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
177                  )))
178            reverse-extra-cases))
179
180(define encode/decode-cases
181  '(("foo?bar" "foo%3Fbar")
182    ("foo&bar" "foo%26bar")
183    ("foo%20bar" "foo%2520bar")
184    ("foo\x00bar\n" "foo%00bar%0A")))
185
186(test-group "uri-encode-string test"
187  (for-each (lambda (p)
188              (let ((expected (second p))
189                    (encoded (uri-encode-string (first p))))
190                  (test (sprintf "~S -> ~S" (first p) expected) expected encoded)))
191            encode/decode-cases))
192
193(test-group "uri-decode-string test"
194  (for-each (lambda (p)
195              (let ((expected (first p))
196                    (decoded (uri-decode-string (second p))))
197                  (test (sprintf "~S -> ~S" (second p) expected) expected decoded)))
198            encode/decode-cases))
199
200(define normalize-case-cases
201  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
202    ("http://EXA%2fMPLE/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
203    ("HTTP://example/" "http://example/")
204    ("http://user:PASS@example/FOO%2fbar" "http://user:PASS@example/FOO%2Fbar")
205    ("http://uS%2fer:PA%2fSS@example/FOO%2fbar" "http://uS%2Fer:PA%2FSS@example/FOO%2Fbar")
206    ("HTTP://example/?mooH=MUMBLe%2f" "http://example/?mooH=MUMBLe%2F")
207    ("http://example/#baR%2f" "http://example/#baR%2F")))
208
209(test-group "normalize-case test"
210  (for-each (lambda (p)
211              (let ((case-normalized (uri-normalize-case (uri-reference (first p))))
212                    (expected (second p)))
213                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
214            normalize-case-cases))
215
216(define internal-representation-cases
217  `(("scheme" ,uri-scheme
218     ;; pct-encoding not allowed in scheme
219     ("http.:" http.)
220     ("http+:" http+)
221     ("http-:" http-)
222     ("HTTP:" HTTP)
223     ("" #f)
224     ("/foo" #f)
225     (":" ||))
226    ("username" ,uri-username
227     ("//foo" #f)
228     ("//@" "")
229     ("//foo@" "foo")
230     ("//foo:bar@" "foo")
231     ("//foo:bar:qux@" "foo")
232     ("//foo%20bar@" "foo%20bar")
233     ("//foo%3Abar:qux@" "foo%3Abar") ;; %3A = ':'
234     ("//foo%2Ebar@" "foo.bar" "//foo.bar@"))
235    ("password ",uri-password
236     ("//foo" #f)
237     ("//@" #f)
238     ("//foo@" #f)
239     ("//foo:bar@" "bar")
240     ("//foo:bar:qux@" "bar:qux")
241     ("//foo:bar%20qux@" "bar%20qux")
242     ("//foo:bar%2Equx@" "bar.qux" "//foo:bar.qux@"))
243    ("path" ,uri-path
244     ("//foo" ())   ; Can path ever be #f?
245     ("foo%20bar" ("foo%20bar"))
246     ("foo%2Fbar" ("foo/bar"))
247     ("foo%2ebar" ("foo.bar") "foo.bar")
248     ("foo/bar%2Fqux" ("foo" "bar/qux"))
249     ("foo/" ("foo" ""))
250     ("foo/bar:qux" ("foo" "bar:qux"))
251     ("/foo%2Fbar" (/ "foo/bar"))
252     ("/foo/" (/ "foo" ""))
253     ("/foo:bar" (/ "foo:bar")))
254    ("query ",uri-query
255     ("//" #f)
256     ("?foo" "foo")
257     ("?foo?bar" "foo?bar")
258     ("?foo/bar" "foo/bar")
259     ("?foo%3Fbar" "foo%3Fbar")
260     ("?foo%2Ebar" "foo.bar" "?foo.bar"))
261    ("fragment" ,uri-fragment
262     ("?foo" #f)
263     ("#bar" "bar")
264     ("?foo#bar" "bar")
265     ("#foo?bar" "foo?bar")
266     ("#foo/bar" "foo/bar")
267     ("#foo%3Fbar" "foo%3Fbar")
268     ("#foo%2Ebar" "foo.bar" "#foo.bar"))))
269
270(test-group "internal representations"
271  (for-each (lambda (p)
272              (test-group (car p)
273               (for-each (lambda (u)
274                           (let ((in (first u))
275                                 (internal (second u))
276                                 (out (if (null? (cddr u))
277                                          (first u)
278                                          (third u)))
279                                 (uri (uri-reference (first u))))
280                             (test (sprintf "~S decoded as ~S" in internal)
281                                   internal ((cadr p) uri))
282                             (test (sprintf "~S encoded to ~S" internal out)
283                                   out (uri->string uri
284                                                    (lambda (u p)
285                                                      (if p (conc u ":" p) u))))))
286                         (cddr p))))
287            internal-representation-cases))
288
289;; I wonder if there's a term for this :)
290(define non-relative-non-absolute-uri-references
291  '("http://foo#frag"
292    "http://foo?a=b#frag"
293    "http://foo/bar#frag"
294    "http://foo/bar?a=b#frag"))
295
296(define absolute-uris
297  '("http://foo"
298    "http://foo?a=b"
299    "http://foo/bar"
300    "http://foo/bar?a=b"))
301
302(define relative-refs
303  `(""
304    "bar"
305    "bar?a=b"
306    "bar#frag"
307    "bar?a=b#frag"
308    "/"
309    "/bar"
310    "/bar?a=b"
311    "/bar#frag"
312    "/bar?a=b#frag"
313    "//foo"
314    "//foo?a=b"
315    "//foo#frag"
316    "//foo?a=b#frag"
317    "//foo/bar"
318    "//foo/bar?a=b"
319    "//foo/bar#frag"
320    "//foo/bar?a=b#frag"))
321
322(test-group "absolute/relative distinction"
323  (for-each (lambda (s)
324              (test-assert (sprintf "~S is relative" s)
325                           (relative-ref? (uri-reference s)))
326              (test-assert (sprintf "~S is not absolute" s)
327                           (not (absolute-uri? (uri-reference s))))
328              (test-error (absolute-uri s)))
329            relative-refs)
330  (for-each (lambda (s)
331              (test-assert (sprintf "~S is not relative" s)
332                           (not (relative-ref? (uri-reference s))))
333              (test-assert (sprintf "~S is absolute" s)
334                           (absolute-uri? (uri-reference s)))
335              (test (uri-reference s) (absolute-uri s)))
336            absolute-uris)
337  (for-each (lambda (s)
338              (test-assert (sprintf "~S is not relative" s)
339                           (not (relative-ref? (uri-reference s))))
340              (test-assert (sprintf "~S is not absolute" s)
341                           (not (absolute-uri? (uri-reference s))))
342              ;; Should this give an error in the fragment case?
343              (test-error (absolute-uri s)))
344            non-relative-non-absolute-uri-references))
345
346(test-group "miscellaneous"
347  ;; Special case, see section 4.2
348  (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar")))))
Note: See TracBrowser for help on using the repository browser.