source: project/release/5/uri-generic/trunk/tests/run.scm @ 36546

Last change on this file since 36546 was 36546, checked in by sjamaan, 17 months ago

uri-generic: Add several URI samples with ipv6 hosts literals and one ipvfuture host literal to test suite (C5)

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