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

Last change on this file since 36547 was 36547, checked in by sjamaan, 15 months ago

uri-generic: Delete early return in tests added for testing purposes

File size: 22.9 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"   "")
20    ("http://ex/x/y/" "http://ex/x/y/"  "")
21    ("http://ex/x/y/pdq" "http://ex/x/y/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")
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" "")
34    ("file:/ex/x/y/" "file:/ex/x/y/" "")
35    ("file:/ex/x/y/pdq" "file:/ex/x/y/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 "")
150    (,base "http://a/b/c/e" "./e")
151    (,base "http://a/b/c/" "./")  ;; Not sure if the trailing slash belongs here
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 "../../"
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
163(test-group "uri test"
164  (for-each (lambda (p)
165              (let ((ubase (uri-reference (first p)))
166                    (urabs  (uri-reference (second p)))
167                    (uex   (uri-reference (third p))))
168                (let* ((from (uri-relative-from urabs ubase))
169                       (to    (uri-relative-to from ubase)))
170                  (test (apply sprintf "~S * ~S -> ~S" p) uex from)
171                  (test (apply sprintf "~S * ~S -> ~S" p) urabs to)
172                  (unless (uri-fragment urabs)
173                    (let ((uabs  (absolute-uri (second p))))
174                      (test (sprintf "~S = ~S" uabs urabs) urabs uabs)))
175                  ))
176              (for-each
177               (lambda (s)
178                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
179                       s (uri->string (uri-reference s))))
180               p))
181            path-cases))
182
183(test-group "rfc test"
184  (for-each (lambda (p)
185              (let ((ubase (uri-reference (first p)))
186                    (urabs  (uri-reference (second p)))
187                    (uex   (uri-reference (third p))))
188                (let* ((to    (uri-relative-to urabs ubase)))
189                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
190                  ))
191              (for-each
192               (lambda (s)
193                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
194                       s (uri->string (uri-reference s))))
195               p))
196            rfc-cases))
197
198(test-group "extra-test"
199  (for-each (lambda (p)
200              (let ((ubase (uri-reference (first p)))
201                    (urabs  (uri-reference (second p)))
202                    (uex   (uri-reference (third p))))
203                (let* ((to    (uri-relative-to urabs ubase)))
204                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
205                  )))
206            extra-cases))
207
208(test-group "ipv6 host literals"
209  (for-each (lambda (p)
210              (let ((uri (uri-reference (first p))))
211                (test (apply sprintf "~S has host ~S" p)
212                      (second p) (uri-host uri))
213                (test-assert (sprintf "~S has an ipv6 host" (first p))
214                             (uri-ipv6-host? uri))
215                (test (sprintf "~S = ~S" (first p) (uri->string uri))
216                      (uri->string uri) (first p))
217                ))
218            ipv6-host-literal-cases))
219
220(test-group "reverse-extra-test"
221  (for-each (lambda (p)
222              (let ((ubase (uri-reference (first p)))
223                    (urabs  (uri-reference (second p)))
224                    (uex   (uri-reference (third p))))
225                (let* ((to    (uri-relative-from urabs ubase)))
226                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
227                  )))
228            reverse-extra-cases))
229
230(define encode/decode-cases
231  '(("foo?bar" "foo%3Fbar")
232    ("foo&bar" "foo%26bar")
233    ("foo%20bar" "foo%2520bar")
234    ("foo\x00bar\n" "foo%00bar%0A")
235    ;; UTF-8 breakage, reported by Adrien Ramos
236    ("D&D - Création persos.html"
237     "D%26D%20-%20Cr%C3%A9ation%20persos.html")))
238
239(test-group "uri-encode-string test"
240  (for-each (lambda (p)
241              (let ((expected (second p))
242                    (encoded (uri-encode-string (first p))))
243                  (test (sprintf "~S -> ~S" (first p) expected) expected encoded)))
244            encode/decode-cases))
245
246(test-group "uri-decode-string test"
247  (for-each (lambda (p)
248              (let ((expected (first p))
249                    (decoded (uri-decode-string (second p))))
250                  (test (sprintf "~S -> ~S" (second p) expected) expected decoded)))
251            encode/decode-cases))
252
253(define normalize-case-cases
254  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
255    ("http://EXA%2fMPLE/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
256    ("HTTP://example/" "http://example/")
257    ("http://user:PASS@example/FOO%2fbar" "http://user:PASS@example/FOO%2Fbar")
258    ("http://uS%2fer:PA%2fSS@example/FOO%2fbar" "http://uS%2Fer:PA%2FSS@example/FOO%2Fbar")
259    ("HTTP://example/?mooH=MUMBLe%2f" "http://example/?mooH=MUMBLe%2F")
260    ("http://example/#baR%2f" "http://example/#baR%2F")))
261
262(test-group "normalize-case test"
263  (for-each (lambda (p)
264              (let ((case-normalized (uri-normalize-case (uri-reference (first p))))
265                    (expected (second p)))
266                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
267            normalize-case-cases))
268
269(define internal-representation-cases
270  `(("scheme" ,uri-scheme
271     ;; pct-encoding not allowed in scheme
272     ("http.:" http.)
273     ("http+:" http+)
274     ("http-:" http-)
275     ("HTTP:" HTTP)
276     ("" #f)
277     ("/foo" #f))
278    ("host" ,uri-host
279     ("//:123" "")
280     ;; Thanks to Roel van der Hoorn for finding this one
281     ("//%20/" "%20"))
282    ("ipv6-host?" ,uri-ipv6-host?
283     ("http://[::1]/bla" #t)
284     ("http://127.0.0.1/bla" #f)
285     ("http://localhost/1234" #f))
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    ("port" ,uri-port
291     ("//host:123" 123))
292    ("username" ,uri-username
293     ("//foo" #f)
294     ("//@" "")
295     ("//foo@" "foo")
296     ("//foo:bar@" "foo")
297     ("//foo:bar:qux@" "foo")
298     ("//foo%20bar@" "foo%20bar")
299     ("//foo%3Abar:qux@" "foo%3Abar") ;; %3A = ':'
300     ("//foo%2Ebar@" "foo.bar" "//foo.bar@"))
301    ("password ",uri-password
302     ("//foo" #f)
303     ("//@" #f)
304     ("//foo@" #f)
305     ("//foo:bar@" "bar")
306     ("//foo:bar:qux@" "bar:qux")
307     ("//foo:bar%20qux@" "bar%20qux")
308     ("//foo:bar%2Equx@" "bar.qux" "//foo:bar.qux@"))
309    ("path" ,uri-path
310     ("//foo" ())   ; Can path ever be #f?
311     ("foo%20bar" ("foo%20bar"))
312     ("foo%2Fbar" ("foo/bar"))
313     ("foo%2ebar" ("foo.bar") "foo.bar")
314     ("foo/bar%2Fqux" ("foo" "bar/qux"))
315     ("foo/" ("foo" ""))
316     
317     ;; Empty path components preserved?  [http://bugs.call-cc.org/ticket/396]
318     ("//foo//bar" (/ "" "bar"))
319     ("//foo///bar" (/ "" "" "bar"))
320     ("/foo//bar" (/ "foo" "" "bar"))
321     ("/foo///bar" (/ "foo" "" "" "bar"))
322     ("foo//bar" ("foo" "" "bar"))
323     ("foo///bar" ("foo" "" "" "bar"))
324     ("foo//" ("foo" "" ""))
325     ("foo///" ("foo" "" "" ""))
326     
327     ("foo/bar:qux" ("foo" "bar:qux"))
328     ("/foo%2Fbar" (/ "foo/bar"))
329     ("/foo/" (/ "foo" ""))
330     ("/" (/ ""))
331     ("/?foo" (/ ""))
332     ("/#foo" (/ ""))
333     ("/foo:bar" (/ "foo:bar"))
334
335     ;; UTF-8 breakage, reported by Adrien Ramos
336     ("/D&D%20-%20Cr%C3%A9ation%20persos.html"
337      (/ "D&D%20-%20Cr%C3%A9ation%20persos.html")))
338    ("query ",uri-query
339     ("//" #f)
340     ("/?foo" "foo")
341     ("?foo" "foo")
342     ("?foo?bar" "foo?bar")
343     ("?foo/bar" "foo/bar")
344     ("?foo%3Fbar" "foo%3Fbar")
345     ("?foo%2Ebar" "foo.bar" "?foo.bar"))
346    ("fragment" ,uri-fragment
347     ("?foo" #f)
348     ("#bar" "bar")
349     ("/#bar" "bar")
350     ("?foo#bar" "bar")
351     ("/?foo#bar" "bar")
352     ("#foo?bar" "foo?bar")
353     ("#foo/bar" "foo/bar")
354     ("#foo%3Fbar" "foo%3Fbar")
355     ("#foo%2Ebar" "foo.bar" "#foo.bar"))))
356
357(test-group "internal representations"
358  (for-each (lambda (p)
359              (test-group (car p)
360               (for-each (lambda (u)
361                           (let ((in (first u))
362                                 (internal (second u))
363                                 (out (if (null? (cddr u))
364                                          (first u)
365                                          (third u)))
366                                 (uri (uri-reference (first u))))
367                             (test (sprintf "~S decoded as ~S" in internal)
368                                   internal ((cadr p) uri))
369                             (test (sprintf "~S encoded to ~S" internal out)
370                                   out (uri->string uri
371                                                    (lambda (u p)
372                                                      (if p (conc u ":" p) u))))))
373                         (cddr p))))
374            internal-representation-cases))
375
376;; I wonder if there's a term for this :)
377(define non-relative-non-absolute-uri-references
378  '("http://foo#frag"
379    "http://foo?a=b#frag"
380    "http://foo/bar#frag"
381    "http://foo/bar?a=b#frag"))
382
383(define absolute-uris
384  '("http://foo"
385    "http://foo?a=b"
386    "http://foo/bar"
387    "http://foo/bar?a=b"))
388
389(define relative-refs
390  `(""
391    "bar"
392    "bar?a=b"
393    "bar#frag"
394    "bar?a=b#frag"
395    "/"
396    "/bar"
397    "/bar?a=b"
398    "/bar#frag"
399    "/bar?a=b#frag"
400    "//foo"
401    "//foo?a=b"
402    "//foo#frag"
403    "//foo?a=b#frag"
404    "//foo/bar"
405    "//foo/bar?a=b"
406    "//foo/bar#frag"
407    "//foo/bar?a=b#frag"))
408
409(test-group "absolute/relative distinction"
410  (for-each (lambda (s)
411              (test-assert (sprintf "~S is a relative ref" s)
412                           (relative-ref? (uri-reference s)))
413              (test-assert (sprintf "~S is not an URI" s)
414                           (not (uri? (uri-reference s))))
415              (test-assert (sprintf "~S is not an absolute URI" s)
416                           (not (absolute-uri? (uri-reference s))))
417              (test-error (absolute-uri s)))
418            relative-refs)
419  (for-each (lambda (s)
420              (test-assert (sprintf "~S is not a relative ref" s)
421                           (not (relative-ref? (uri-reference s))))
422              (test-assert (sprintf "~S is an URI" s)
423                           (uri? (uri-reference s)))
424              (test-assert (sprintf "~S is an absolute URI" s)
425                           (absolute-uri? (uri-reference s)))
426              (test (uri-reference s) (absolute-uri s)))
427            absolute-uris)
428  (for-each (lambda (s)
429              (test-assert (sprintf "~S is not a relative ref" s)
430                           (not (relative-ref? (uri-reference s))))
431              (test-assert (sprintf "~S is an URI" s)
432                           (uri? (uri-reference s)))
433              (test-assert (sprintf "~S is not an absolute URI" s)
434                           (not (absolute-uri? (uri-reference s))))
435              ;; Should this give an error in the fragment case?
436              (test-error (absolute-uri s)))
437            non-relative-non-absolute-uri-references))
438
439(define absolute-paths
440  '("/"
441    "/foo"
442    "//foo/"
443    "http://foo/bar"
444    "http://foo/"
445    "http://foo/#qux"
446    "http://foo/?bar=qux"))
447
448(define relative-paths
449  '(""
450    "http://foo"
451    "//foo"
452    "http://foo#bar"
453    "http://foo?bar=qux"))
454
455(test-group "absolute/relative path distinction"
456  (for-each (lambda (s)
457              (test-assert (sprintf "~S is not a relative path" s)
458                           (not (uri-path-relative? (uri-reference s))))
459              (test-assert (sprintf "~S is an absolute path" s)
460                           (uri-path-absolute? (uri-reference s))))
461            absolute-paths)
462  (for-each (lambda (s)
463              (test-assert (sprintf "~S is a relative path" s)
464                           (uri-path-relative? (uri-reference s)))
465              (test-assert (sprintf "~S is not an absolute path" s)
466                           (not (uri-path-absolute? (uri-reference s)))))
467            relative-paths))
468
469;; Uri-references not allowed by the BNF
470(define invalid-refs
471  `(":" ;; This should be encoded to %3a, since an empty scheme is not allowed
472    "1:" ;; scheme starts with ALPHA
473    "//host:abc"  ;; port must be a number
474    " " ;; make sure that any URIs with space < > " are rejected
475    "foo " 
476    " foo " 
477    "<foo" 
478    "foo>" 
479    "<foo>" 
480    "\"foo\"" 
481    "%" ;; % must be followed by two hex digits
482    "abc%xyz" 
483    "http://foo.com/bar?a=b|c" ;; | must be encoded as %7C
484    ))
485
486(test-group "Invalid URI-references"
487  (for-each (lambda (s)
488              (test (sprintf "~S is not a valid uri-reference" s)
489                    #f
490                    (uri-reference s)))
491            invalid-refs))
492
493(test-group "miscellaneous"
494  ;; Special case, see section 4.2
495  (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar")))))
496
497
498;; Examples URIs from RFC 4151 The 'tag' URI scheme
499;;
500;; Tag URIs always contain a colon, so uri->string will prefix their
501;; paths by ./ as per section 4.2 in RFC 3986
502(define rfc4151-refs
503  `(
504    ("tag:timothy@hpl.hp.com,2001:web/externalHome"
505     "tag:./timothy@hpl.hp.com,2001:web/externalHome")
506    ("tag:sandro@w3.org,2004-05:Sandro"
507     "tag:./sandro@w3.org,2004-05:Sandro"
508     )
509    ("tag:my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19"
510     "tag:./my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19"
511     )
512    ("tag:blogger.com,1999:blog-555" 
513     "tag:./blogger.com,1999:blog-555"
514     )
515    ("tag:yaml.org,2002:int" 
516     "tag:./yaml.org,2002:int"
517     )
518    ))
519
520(test-group "Example URIs from RFC 4151"
521  (for-each (lambda (s) 
522              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
523            rfc4151-refs))
524
525;; Examples URIs from RFC 4452 The 'info' URI scheme
526;;
527(define rfc4452-refs
528  `(
529    ("info:ddc/22/eng//004.678"
530     "info:ddc/22/eng//004.678")
531    ("info:lccn/2002022641"
532     "info:lccn/2002022641"
533     )
534    ("info:sici/0363-0277(19950315)120:5%3C%3E1.0.TX;2-V"
535     "info:sici/0363-0277(19950315)120:5%3C%3E1.0.TX;2-V")
536    ("info:bibcode/2003Icar..163..263Z"
537     "info:bibcode/2003Icar..163..263Z")
538    ))
539
540(test-group "Example URIs from RFC 4452"
541  (for-each (lambda (s) 
542              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
543            rfc4452-refs))
544
545;; Examples URIs from RFC 5724 URI scheme for global system for mobile communication
546;;
547(define rfc5724-refs
548  `(
549    ("sms:+15105550101"
550     "sms:+15105550101")
551    ("sms:+15105550101,+15105550102"
552     "sms:+15105550101,+15105550102")
553    ("sms:+15105550101?body=hello%20there"
554     "sms:+15105550101?body=hello%20there"
555     )
556    ))
557
558(test-group "Example URIs from RFC 4452"
559  (for-each (lambda (s) 
560              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
561            rfc5724-refs))
562
563
564;; Examples URIs from RFC 4501 DNS URIs
565;;
566(define rfc4501-refs
567  `(
568    ("dns:www.example.org.?clAsS=IN;tYpE=A"
569     "dns:www.example.org.?clAsS=IN;tYpE=A")
570    ("dns://192.168.1.1/ftp.example.org?type=A"
571     "dns://192.168.1.1/ftp.example.org?type=A")
572    ("dns:world%20wide%20web.example%5c.domain.org?TYPE=TXT"
573     "dns:world%20wide%20web.example%5c.domain.org?TYPE=TXT")
574    ("dns://fw.example.org/*.%20%00.example?type=TXT"
575     "dns://fw.example.org/*.%20%00.example?type=TXT")
576    ))
577
578(test-group "Example URIs from RFC 4501"
579  (for-each (lambda (s) 
580              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
581            rfc4501-refs))
582
583;; Examples URIs from RFC 5122
584;;
585(define rfc5122-refs
586  `(("xmpp:nasty!%23$%25()*+,-.;=%3F%5B%5C%5D%5E_%60%7B%7C%7D~node@example.com"
587     ("nasty!#$%()*+,-.;=?[\\]^_`{|}~node@example.com")) ;; the decoded path component
588    ("xmpp:node@example.com/repulsive%20!%23%22$%25&'()*+,-.%2F:;%3C=%3E%3F%40%5B%5C%5D%5E_%60%7B%7C%7D~resource"
589     ("node@example.com" "repulsive !#\"$%&'()*+,-./:;<=>?@[\\]^_`{|}~resource")) ;; the decoded path component
590    ))
591   
592
593(test-group "Example URIs from RFC 5122"
594  (for-each (lambda (s) 
595              (test (car s) (cadr s) (map uri-decode-string (uri-path (uri-reference (car s))))))
596            rfc5122-refs))
597
598(define make-cases
599  `(("http://example.com:123/foo/bar?a=b;c=d#location"
600     scheme: http host: "example.com" port: 123 path: (/ "foo" "bar")
601     query: "a=b;c=d" fragment: "location")
602    ("//example.com:123/foo/bar?a=b;c=d#location"
603     host: "example.com" port: 123 path: (/ "foo" "bar")
604     query: "a=b;c=d" fragment: "location")
605    ("/foo/bar?a=b;c=d#location"
606     port: 123 path: (/ "foo" "bar") query: "a=b;c=d" fragment: "location")
607    ("foo/bar?a=b;c=d#location"
608     path: ("foo" "bar") query: "a=b;c=d" fragment: "location")
609    ("/?a=b;c=d#location"
610     path: (/ "") query: "a=b;c=d" fragment: "location")
611    ("?a=b;c=d#location"
612     query: "a=b;c=d" fragment: "location")
613    ("#location"
614     fragment: "location")
615    ("//example.com?a=b;c=d"
616     host: "example.com" query: "a=b;c=d")
617    ("//example.com#location"
618     host: "example.com" fragment: "location")
619    ("/"
620     path: (/ ""))
621    ("/"
622     path: (/))                         ; Not sure if this works by accident
623    (""
624     path: ())
625    ("")))
626
627(test-group "manual constructor"
628  (for-each (lambda (u)
629              (let* ((input (cdr u))
630                     (oexp (first u))
631                     (oact (apply make-uri input)))
632                (test (sprintf "~S -> ~S" input oexp)
633                      oexp (uri->string oact))))
634            make-cases))
635
636(test-end "uri-generic")
637
638(unless (zero? (test-failure-count)) (exit 1))
Note: See TracBrowser for help on using the repository browser.