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

Last change on this file since 36553 was 36553, checked in by sjamaan, 3 years ago

uri-generic: Update irregex alternative to CHICKEN 5 (and port a few fixes I forgot about)

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