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

Last change on this file since 37075 was 37075, checked in by zbigniew, 6 months ago

4/uri-generic: backport relative path fixes from Chicken 5

File size: 23.1 KB
Line 
1(require-extension srfi-1)
2(load "../uri-generic.scm")
3(import uri-generic)
4(require-extension test)
5
6(test-begin "uri-generic")
7
8(define  path-cases
9  '(;; test cases from Python URI implementation
10    ("foo:xyz" "bar:abc" "bar:abc")
11    ("http://example/x/y/z" "http://example/x/abc" "../abc")
12    ("http://example2/x/y/z" "http://example/x/abc" "//example/x/abc")
13    ("http://ex/x/y/z" "http://ex/x/r" "../r")
14
15    ("http://ex/x/y"  "http://ex/x/q/r" "q/r")
16    ("http://ex/x/y"  "http://ex/x/q/r#s" "q/r#s")
17    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "q/r#s/t")
18    ("http://ex/x/y"  "ftp://ex/x/q/r" "ftp://ex/x/q/r")
19    ("http://ex/x/y"  "http://ex/x/y"   "y")
20    ("http://ex/x/y/" "http://ex/x/y/"  ".")
21    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "pdq")
22    ("http://ex/x/y/" "http://ex/x/y/z/" "z/")
23    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "animal.rdf#Animal")
24    ("file:/e/x/y/z" "file:/e/x/abc" "../abc")
25    ("file:/example2/x/y/z" "file:/example/x/abc" "../../../example/x/abc")
26    ("file:/ex/x/y/z" "file:/ex/x/r" "../r")
27    ("file:/ex/x/y/z" "file:/r" "../../../r")
28    ("file:/ex/x/y" "file:/ex/x/q/r" "q/r")
29    ("file:/ex/x/y" "file:/ex/x/q/r#s" "q/r#s")
30    ("file:/ex/x/y" "file:/ex/x/q/r#" "q/r#")
31    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "q/r#s/t")
32    ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r")
33    ("file:/ex/x/y" "file:/ex/x/y" "y")
34    ("file:/ex/x/y/" "file:/ex/x/y/" ".")
35    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "pdq")
36    ("file:/ex/x/y/" "file:/ex/x/y/z/" "z/")
37    ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
38     "//meetings.example.com/cal#m1")
39    ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
40     "//meetings.example.com/cal#m1")
41    ("file:/some/dir/foo" "file:/some/dir/#blort" ".#blort")
42    ("file:/some/dir/foo" "file:/some/dir/#" ".#")
43    ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000
44    ("http://example/x/y%2Fz"  "http://example/x/abc"     "abc")
45    ("http://example/x/y/z"    "http://example/x%2Fabc"   "../../x%2Fabc")
46    ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "../x%2Fabc")
47    ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "abc")
48    ;; Ryan Lee
49    ("http://example/x/abc.efg" "http://example/x/" ".")
50    ))
51
52(define base "http://a/b/c/d;p?q")
53
54(define rfc-cases
55  `(;; Examples from section 5.2.4
56    ("/a/b/c/" "./../../g" "/a/g")
57    ("/a/b/c/xyz" "./../../g" "/a/g") ; Input could've had a trailing component
58    ("mid/content=5/" "../6" "mid/6")
59    ("mid/content=5/7" "../6" "mid/6") ; Same here
60
61    ;; "Normal examples", section 5.4.1
62    (,base "g:h" "g:h")
63    (,base "g" "http://a/b/c/g")
64    (,base "./g" "http://a/b/c/g")
65    (,base "g/" "http://a/b/c/g/")
66    (,base "/g" "http://a/g")
67    (,base "//g" "http://g")
68    (,base "?y" "http://a/b/c/?y") 
69    (,base "g?y" "http://a/b/c/g?y")
70    (,base "#s" "http://a/b/c/d;p?q#s") 
71    (,base "g#s" "http://a/b/c/g#s")
72    (,base "g?y#s" "http://a/b/c/g?y#s")
73    (,base ";x" "http://a/b/c/;x")
74    (,base "g;x" "http://a/b/c/g;x")
75    (,base "g;x?y#s" "http://a/b/c/g;x?y#s")
76    (,base "."  "http://a/b/c/")
77    (,base "./" "http://a/b/c/")
78    (,base ".." "http://a/b/")
79    (,base "../" "http://a/b/")
80    (,base "../g" "http://a/b/g")
81    (,base "../.." "http://a/")
82    (,base "../../" "http://a/")
83    (,base "../../g" "http://a/g")
84   
85    ;; "Abnormal examples", section 5.4.2
86    (,base "" ,base)
87    (,base "../../../g" "http://a/g") 
88    (,base "../../../../g" "http://a/g")
89    (,base "../../../.." "http://a/") ; Is this correct? Or http://a ?
90    (,base "../../../../" "http://a/")
91    (,base "/./g" "http://a/g")
92    (,base "/../g" "http://a/g")
93    (,base "g.." "http://a/b/c/g..")
94    (,base "..g" "http://a/b/c/..g")
95   
96    (,base "./../g" "http://a/b/g")
97    (,base "./g/." "http://a/b/c/g/") 
98    (,base "g/./h" "http://a/b/c/g/h") 
99    (,base "g/../h" "http://a/b/c/h")
100    (,base "g;x=1/./y" "http://a/b/c/g;x=1/y") 
101    (,base "g;x=1/../y" "http://a/b/c/y") 
102   
103    (,base "g?y/./x" "http://a/b/c/g?y/./x")
104    (,base "g?y/../x" "http://a/b/c/g?y/../x")
105    (,base "g#s/./x" "http://a/b/c/g#s/./x")
106    (,base "g#s/../x" "http://a/b/c/g#s/../x")
107    ))
108
109(define extra-cases
110  `(("?a=b&c=d" "" "?a=b&c=d")
111    (,base "" "http://a/b/c/d;p?q")
112    ("" ,base "http://a/b/c/d;p?q")
113    (,base "http:" "http:")
114    (,base "..%2f" "http://a/b/c/..%2f")
115    ;; Assume an empty uri-reference is identical to "."
116    ("http://a/b/c/d/" "" "http://a/b/c/d/")
117    ("http://a/b/c/d" "" "http://a/b/c/d")
118    ("http://a/b/c/d/" ".." "http://a/b/c/")
119    ("http://a/b/c/d/" "../e" "http://a/b/c/e")
120    ("http://a/b/c/d/" "../e/" "http://a/b/c/e/")
121    ("http://a/b//c///d///" "../.." "http://a/b//c///d/")
122    ("http://a/b/c/d/" "..//x" "http://a/b/c//x")
123    ("http://a" "b" "http://a/b") ; RFC3986, section 5.2.3, first bullet point
124   
125    ;; Empty segments are segments nonetheless, so should be treated as such
126    ;; [http://bugs.call-cc.org/ticket/396]
127    ("http://a//b//c" "../../../.." "http://a/")
128    ))
129
130(define ipv6-host-literal-cases
131  ;; From #1530, found by Vasilij Schneidermann
132  `(("http://[::1]:8080" "::1")
133    ;; From RFC 2732
134    ("http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210")
135    ("http://[1080:0:0:0:8:800:200C:417A]/index.html" "1080:0:0:0:8:800:200C:417A")
136    ("http://[3ffe:2a00:100:7031::1]" "3ffe:2a00:100:7031::1")
137    ("http://[1080::8:800:200C:417A]/foo" "1080::8:800:200C:417A")
138    ("http://[::192.9.5.5]/ipng" "::192.9.5.5")
139    ("http://[::FFFF:129.144.52.38]:80/index.html" "::FFFF:129.144.52.38")
140    ("http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179")
141    ;; ipv-future examples
142    ("http://[vA.123456:789]/" "vA.123456:789")
143    ;; Currently unsupported: ipv6 addresses are expected to always
144    ;; have a colon in them.
145    ;;("http://[vA.123456]/" "vA.123456")
146    ))
147
148(define reverse-extra-cases
149  `((,base ,base "d;p")
150    (,base "http://a/b/c/e" "e")
151    (,base "http://a/b/c/" ".")
152    (,base "http://a/b/e" "../e")
153    (,base "http://a/b/c" "../c") ;; Slightly weird: dir in base, file in target
154    (,base "http://a/b/" "..")
155    (,base "http://a/" "../..") ;; or "/", but that's not convenient
156    (,base "http://a" "//a") ; No relative representation possible
157    (,base "http://b" "//b")
158    (,base "http://b/" "//b/")
159    (,base "http://b/c" "//b/c")
160    (,base "ftp://a/b/c/d;p?q" "ftp://a/b/c/d;p?q")
161    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")
162    ;; Found by Jim Ursetto.  This would become "", which is not
163    ;; right when both are directories (see second case)
164    ("/foo/bar" "/foo/bar" "bar")
165    ("/foo/bar/" "/foo/bar/" ".")))
166
167(test-group "uri test"
168  (for-each (lambda (p)
169              (let ((ubase (uri-reference (first p)))
170                    (urabs  (uri-reference (second p)))
171                    (uex   (uri-reference (third p))))
172                (let* ((from (uri-relative-from urabs ubase))
173                       (to    (uri-relative-to from ubase)))
174                  (test (apply sprintf "~S * ~S -> ~S" p) uex from)
175                  (test (apply sprintf "~S * ~S -> ~S" p) urabs to)
176                  (unless (uri-fragment urabs)
177                    (let ((uabs  (absolute-uri (second p))))
178                      (test (sprintf "~S = ~S" uabs urabs) urabs uabs)))
179                  ))
180              (for-each
181               (lambda (s)
182                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
183                       s (uri->string (uri-reference s))))
184               p))
185            path-cases))
186
187(test-group "rfc test"
188  (for-each (lambda (p)
189              (let ((ubase (uri-reference (first p)))
190                    (urabs  (uri-reference (second p)))
191                    (uex   (uri-reference (third p))))
192                (let* ((to    (uri-relative-to urabs ubase)))
193                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
194                  ))
195              (for-each
196               (lambda (s)
197                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
198                       s (uri->string (uri-reference s))))
199               p))
200            rfc-cases))
201
202(test-group "extra-test"
203  (for-each (lambda (p)
204              (let ((ubase (uri-reference (first p)))
205                    (urabs  (uri-reference (second p)))
206                    (uex   (uri-reference (third p))))
207                (let* ((to    (uri-relative-to urabs ubase)))
208                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
209                  )))
210            extra-cases))
211
212(test-group "ipv6 host literals"
213  (for-each (lambda (p)
214              (let ((uri (uri-reference (first p))))
215                (test (apply sprintf "~S has host ~S" p)
216                      (second p) (uri-host uri))
217                (test-assert (sprintf "~S has an ipv6 host" (first p))
218                             (uri-ipv6-host? uri))
219                (test (sprintf "~S = ~S" (first p) (uri->string uri))
220                      (uri->string uri) (first p))
221                ))
222            ipv6-host-literal-cases))
223
224(test-group "reverse-extra-test"
225  (for-each (lambda (p)
226              (let ((ubase (uri-reference (first p)))
227                    (urabs  (uri-reference (second p)))
228                    (uex   (uri-reference (third p))))
229                (let* ((to    (uri-relative-from urabs ubase)))
230                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
231                  )))
232            reverse-extra-cases))
233
234(define encode/decode-cases
235  '(("foo?bar" "foo%3Fbar")
236    ("foo&bar" "foo%26bar")
237    ("foo%20bar" "foo%2520bar")
238    ("foo\x00bar\n" "foo%00bar%0A")
239    ;; UTF-8 breakage, reported by Adrien Ramos
240    ("D&D - Création persos.html"
241     "D%26D%20-%20Cr%C3%A9ation%20persos.html")))
242
243(test-group "uri-encode-string test"
244  (for-each (lambda (p)
245              (let ((expected (second p))
246                    (encoded (uri-encode-string (first p))))
247                  (test (sprintf "~S -> ~S" (first p) expected) expected encoded)))
248            encode/decode-cases))
249
250(test-group "uri-decode-string test"
251  (for-each (lambda (p)
252              (let ((expected (first p))
253                    (decoded (uri-decode-string (second p))))
254                  (test (sprintf "~S -> ~S" (second p) expected) expected decoded)))
255            encode/decode-cases))
256
257(define normalize-case-cases
258  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
259    ("http://EXA%2fMPLE/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
260    ("HTTP://example/" "http://example/")
261    ("http://user:PASS@example/FOO%2fbar" "http://user:PASS@example/FOO%2Fbar")
262    ("http://uS%2fer:PA%2fSS@example/FOO%2fbar" "http://uS%2Fer:PA%2FSS@example/FOO%2Fbar")
263    ("HTTP://example/?mooH=MUMBLe%2f" "http://example/?mooH=MUMBLe%2F")
264    ("http://example/#baR%2f" "http://example/#baR%2F")))
265
266(test-group "normalize-case test"
267  (for-each (lambda (p)
268              (let ((case-normalized (uri-normalize-case (uri-reference (first p))))
269                    (expected (second p)))
270                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
271            normalize-case-cases))
272
273(define internal-representation-cases
274  `(("scheme" ,uri-scheme
275     ;; pct-encoding not allowed in scheme
276     ("http.:" http.)
277     ("http+:" http+)
278     ("http-:" http-)
279     ("HTTP:" HTTP)
280     ("" #f)
281     ("/foo" #f))
282    ("host" ,uri-host
283     ("//:123" "")
284     ;; Thanks to Roel van der Hoorn for finding this one
285     ("//%20/" "%20"))
286    ("ipv6-host?" ,uri-ipv6-host?
287     ("http://[::1]/bla" #t)
288     ("http://127.0.0.1/bla" #f)
289     ("http://localhost/1234" #f))
290    ("ipv6-host?" ,uri-ipv6-host?
291     ("http://[::1]/bla" #t)
292     ("http://127.0.0.1/bla" #f)
293     ("http://localhost/1234" #f))
294    ("port" ,uri-port
295     ("//host:123" 123))
296    ("username" ,uri-username
297     ("//foo" #f)
298     ("//@" "")
299     ("//foo@" "foo")
300     ("//foo:bar@" "foo")
301     ("//foo:bar:qux@" "foo")
302     ("//foo%20bar@" "foo%20bar")
303     ("//foo%3Abar:qux@" "foo%3Abar") ;; %3A = ':'
304     ("//foo%2Ebar@" "foo.bar" "//foo.bar@"))
305    ("password ",uri-password
306     ("//foo" #f)
307     ("//@" #f)
308     ("//foo@" #f)
309     ("//foo:bar@" "bar")
310     ("//foo:bar:qux@" "bar:qux")
311     ("//foo:bar%20qux@" "bar%20qux")
312     ("//foo:bar%2Equx@" "bar.qux" "//foo:bar.qux@"))
313    ("path" ,uri-path
314     ("//foo" ())   ; Can path ever be #f?
315     ("foo%20bar" ("foo%20bar"))
316     ("foo%2Fbar" ("foo/bar"))
317     ("foo%2ebar" ("foo.bar") "foo.bar")
318     ("foo/bar%2Fqux" ("foo" "bar/qux"))
319     ("foo/" ("foo" ""))
320     
321     ;; Empty path components preserved?  [http://bugs.call-cc.org/ticket/396]
322     ("//foo//bar" (/ "" "bar"))
323     ("//foo///bar" (/ "" "" "bar"))
324     ("/foo//bar" (/ "foo" "" "bar"))
325     ("/foo///bar" (/ "foo" "" "" "bar"))
326     ("foo//bar" ("foo" "" "bar"))
327     ("foo///bar" ("foo" "" "" "bar"))
328     ("foo//" ("foo" "" ""))
329     ("foo///" ("foo" "" "" ""))
330     
331     ("foo/bar:qux" ("foo" "bar:qux"))
332     ("/foo%2Fbar" (/ "foo/bar"))
333     ("/foo/" (/ "foo" ""))
334     ("/" (/ ""))
335     ("/?foo" (/ ""))
336     ("/#foo" (/ ""))
337     ("/foo:bar" (/ "foo:bar"))
338
339     ;; UTF-8 breakage, reported by Adrien Ramos
340     ("/D&D%20-%20Cr%C3%A9ation%20persos.html"
341      (/ "D&D%20-%20Cr%C3%A9ation%20persos.html")))
342    ("query ",uri-query
343     ("//" #f)
344     ("/?foo" "foo")
345     ("?foo" "foo")
346     ("?foo?bar" "foo?bar")
347     ("?foo/bar" "foo/bar")
348     ("?foo%3Fbar" "foo%3Fbar")
349     ("?foo%2Ebar" "foo.bar" "?foo.bar"))
350    ("fragment" ,uri-fragment
351     ("?foo" #f)
352     ("#bar" "bar")
353     ("/#bar" "bar")
354     ("?foo#bar" "bar")
355     ("/?foo#bar" "bar")
356     ("#foo?bar" "foo?bar")
357     ("#foo/bar" "foo/bar")
358     ("#foo%3Fbar" "foo%3Fbar")
359     ("#foo%2Ebar" "foo.bar" "#foo.bar"))))
360
361(test-group "internal representations"
362  (for-each (lambda (p)
363              (test-group (car p)
364               (for-each (lambda (u)
365                           (let ((in (first u))
366                                 (internal (second u))
367                                 (out (if (null? (cddr u))
368                                          (first u)
369                                          (third u)))
370                                 (uri (uri-reference (first u))))
371                             (test (sprintf "~S decoded as ~S" in internal)
372                                   internal ((cadr p) uri))
373                             (test (sprintf "~S encoded to ~S" internal out)
374                                   out (uri->string uri
375                                                    (lambda (u p)
376                                                      (if p (conc u ":" p) u))))))
377                         (cddr p))))
378            internal-representation-cases))
379
380;; I wonder if there's a term for this :)
381(define non-relative-non-absolute-uri-references
382  '("http://foo#frag"
383    "http://foo?a=b#frag"
384    "http://foo/bar#frag"
385    "http://foo/bar?a=b#frag"))
386
387(define absolute-uris
388  '("http://foo"
389    "http://foo?a=b"
390    "http://foo/bar"
391    "http://foo/bar?a=b"))
392
393(define relative-refs
394  `(""
395    "bar"
396    "bar?a=b"
397    "bar#frag"
398    "bar?a=b#frag"
399    "/"
400    "/bar"
401    "/bar?a=b"
402    "/bar#frag"
403    "/bar?a=b#frag"
404    "//foo"
405    "//foo?a=b"
406    "//foo#frag"
407    "//foo?a=b#frag"
408    "//foo/bar"
409    "//foo/bar?a=b"
410    "//foo/bar#frag"
411    "//foo/bar?a=b#frag"))
412
413(test-group "absolute/relative distinction"
414  (for-each (lambda (s)
415              (test-assert (sprintf "~S is a relative ref" s)
416                           (relative-ref? (uri-reference s)))
417              (test-assert (sprintf "~S is not an URI" s)
418                           (not (uri? (uri-reference s))))
419              (test-assert (sprintf "~S is not an absolute URI" s)
420                           (not (absolute-uri? (uri-reference s))))
421              (test-error (absolute-uri s)))
422            relative-refs)
423  (for-each (lambda (s)
424              (test-assert (sprintf "~S is not a relative ref" s)
425                           (not (relative-ref? (uri-reference s))))
426              (test-assert (sprintf "~S is an URI" s)
427                           (uri? (uri-reference s)))
428              (test-assert (sprintf "~S is an absolute URI" s)
429                           (absolute-uri? (uri-reference s)))
430              (test (uri-reference s) (absolute-uri s)))
431            absolute-uris)
432  (for-each (lambda (s)
433              (test-assert (sprintf "~S is not a relative ref" s)
434                           (not (relative-ref? (uri-reference s))))
435              (test-assert (sprintf "~S is an URI" s)
436                           (uri? (uri-reference s)))
437              (test-assert (sprintf "~S is not an absolute URI" s)
438                           (not (absolute-uri? (uri-reference s))))
439              ;; Should this give an error in the fragment case?
440              (test-error (absolute-uri s)))
441            non-relative-non-absolute-uri-references))
442
443(define absolute-paths
444  '("/"
445    "/foo"
446    "//foo/"
447    "http://foo/bar"
448    "http://foo/"
449    "http://foo/#qux"
450    "http://foo/?bar=qux"))
451
452(define relative-paths
453  '(""
454    "http://foo"
455    "//foo"
456    "http://foo#bar"
457    "http://foo?bar=qux"))
458
459(test-group "absolute/relative path distinction"
460  (for-each (lambda (s)
461              (test-assert (sprintf "~S is not a relative path" s)
462                           (not (uri-path-relative? (uri-reference s))))
463              (test-assert (sprintf "~S is an absolute path" s)
464                           (uri-path-absolute? (uri-reference s))))
465            absolute-paths)
466  (for-each (lambda (s)
467              (test-assert (sprintf "~S is a relative path" s)
468                           (uri-path-relative? (uri-reference s)))
469              (test-assert (sprintf "~S is not an absolute path" s)
470                           (not (uri-path-absolute? (uri-reference s)))))
471            relative-paths))
472
473;; Uri-references not allowed by the BNF
474(define invalid-refs
475  `(":" ;; This should be encoded to %3a, since an empty scheme is not allowed
476    "1:" ;; scheme starts with ALPHA
477    "//host:abc"  ;; port must be a number
478    " " ;; make sure that any URIs with space < > " are rejected
479    "foo " 
480    " foo " 
481    "<foo" 
482    "foo>" 
483    "<foo>" 
484    "\"foo\"" 
485    "%" ;; % must be followed by two hex digits
486    "abc%xyz" 
487    "http://foo.com/bar?a=b|c" ;; | must be encoded as %7C
488    ))
489
490(test-group "Invalid URI-references"
491  (for-each (lambda (s)
492              (test (sprintf "~S is not a valid uri-reference" s)
493                    #f
494                    (uri-reference s)))
495            invalid-refs))
496
497(test-group "miscellaneous"
498  ;; Special case, see section 4.2
499  (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar")))))
500
501
502;; Examples URIs from RFC 4151 The 'tag' URI scheme
503;;
504;; Tag URIs always contain a colon, so uri->string will prefix their
505;; paths by ./ as per section 4.2 in RFC 3986
506(define rfc4151-refs
507  `(
508    ("tag:timothy@hpl.hp.com,2001:web/externalHome"
509     "tag:./timothy@hpl.hp.com,2001:web/externalHome")
510    ("tag:sandro@w3.org,2004-05:Sandro"
511     "tag:./sandro@w3.org,2004-05:Sandro"
512     )
513    ("tag:my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19"
514     "tag:./my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19"
515     )
516    ("tag:blogger.com,1999:blog-555" 
517     "tag:./blogger.com,1999:blog-555"
518     )
519    ("tag:yaml.org,2002:int" 
520     "tag:./yaml.org,2002:int"
521     )
522    ))
523
524(test-group "Example URIs from RFC 4151"
525  (for-each (lambda (s) 
526              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
527            rfc4151-refs))
528
529;; Examples URIs from RFC 4452 The 'info' URI scheme
530;;
531(define rfc4452-refs
532  `(
533    ("info:ddc/22/eng//004.678"
534     "info:ddc/22/eng//004.678")
535    ("info:lccn/2002022641"
536     "info:lccn/2002022641"
537     )
538    ("info:sici/0363-0277(19950315)120:5%3C%3E1.0.TX;2-V"
539     "info:sici/0363-0277(19950315)120:5%3C%3E1.0.TX;2-V")
540    ("info:bibcode/2003Icar..163..263Z"
541     "info:bibcode/2003Icar..163..263Z")
542    ))
543
544(test-group "Example URIs from RFC 4452"
545  (for-each (lambda (s) 
546              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
547            rfc4452-refs))
548
549;; Examples URIs from RFC 5724 URI scheme for global system for mobile communication
550;;
551(define rfc5724-refs
552  `(
553    ("sms:+15105550101"
554     "sms:+15105550101")
555    ("sms:+15105550101,+15105550102"
556     "sms:+15105550101,+15105550102")
557    ("sms:+15105550101?body=hello%20there"
558     "sms:+15105550101?body=hello%20there"
559     )
560    ))
561
562(test-group "Example URIs from RFC 4452"
563  (for-each (lambda (s) 
564              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
565            rfc5724-refs))
566
567
568;; Examples URIs from RFC 4501 DNS URIs
569;;
570(define rfc4501-refs
571  `(
572    ("dns:www.example.org.?clAsS=IN;tYpE=A"
573     "dns:www.example.org.?clAsS=IN;tYpE=A")
574    ("dns://192.168.1.1/ftp.example.org?type=A"
575     "dns://192.168.1.1/ftp.example.org?type=A")
576    ("dns:world%20wide%20web.example%5c.domain.org?TYPE=TXT"
577     "dns:world%20wide%20web.example%5c.domain.org?TYPE=TXT")
578    ("dns://fw.example.org/*.%20%00.example?type=TXT"
579     "dns://fw.example.org/*.%20%00.example?type=TXT")
580    ))
581
582(test-group "Example URIs from RFC 4501"
583  (for-each (lambda (s) 
584              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
585            rfc4501-refs))
586
587;; Examples URIs from RFC 5122
588;;
589(define rfc5122-refs
590  `(("xmpp:nasty!%23$%25()*+,-.;=%3F%5B%5C%5D%5E_%60%7B%7C%7D~node@example.com"
591     ("nasty!#$%()*+,-.;=?[\\]^_`{|}~node@example.com")) ;; the decoded path component
592    ("xmpp:node@example.com/repulsive%20!%23%22$%25&'()*+,-.%2F:;%3C=%3E%3F%40%5B%5C%5D%5E_%60%7B%7C%7D~resource"
593     ("node@example.com" "repulsive !#\"$%&'()*+,-./:;<=>?@[\\]^_`{|}~resource")) ;; the decoded path component
594    ))
595   
596
597(test-group "Example URIs from RFC 5122"
598  (for-each (lambda (s) 
599              (test (car s) (cadr s) (map uri-decode-string (uri-path (uri-reference (car s))))))
600            rfc5122-refs))
601
602(define make-cases
603  `(("http://example.com:123/foo/bar?a=b;c=d#location"
604     scheme: http host: "example.com" port: 123 path: (/ "foo" "bar")
605     query: "a=b;c=d" fragment: "location")
606    ("//example.com:123/foo/bar?a=b;c=d#location"
607     host: "example.com" port: 123 path: (/ "foo" "bar")
608     query: "a=b;c=d" fragment: "location")
609    ("/foo/bar?a=b;c=d#location"
610     port: 123 path: (/ "foo" "bar") query: "a=b;c=d" fragment: "location")
611    ("foo/bar?a=b;c=d#location"
612     path: ("foo" "bar") query: "a=b;c=d" fragment: "location")
613    ("/?a=b;c=d#location"
614     path: (/ "") query: "a=b;c=d" fragment: "location")
615    ("?a=b;c=d#location"
616     query: "a=b;c=d" fragment: "location")
617    ("#location"
618     fragment: "location")
619    ("//example.com?a=b;c=d"
620     host: "example.com" query: "a=b;c=d")
621    ("//example.com#location"
622     host: "example.com" fragment: "location")
623    ("/"
624     path: (/ ""))
625    ("/"
626     path: (/))                         ; Not sure if this works by accident
627    (""
628     path: ())
629    ("")))
630
631(test-group "manual constructor"
632  (for-each (lambda (u)
633              (let* ((input (cdr u))
634                     (oexp (first u))
635                     (oact (apply make-uri input)))
636                (test (sprintf "~S -> ~S" input oexp)
637                      oexp (uri->string oact))))
638            make-cases))
639
640(test-end "uri-generic")
641
642(unless (zero? (test-failure-count)) (exit 1))
Note: See TracBrowser for help on using the repository browser.