Context Navigation

source: project/release/3/uri-generic/trunk/uri-generic.scm @ 11562

Last change on this file since 11562 was 11562, checked in by Ivan Raikov, 13 years ago
Added uri-generic sources.
File size: 29.3 KB

Line
1
2	;;
3	;; Definitions and parsing routines for Uniform Resource Identifiers (RFC 3986).
4	;;
5	;; Based on the Haskell URI library by Graham Klyne <gk@ninebynine.org>.
6	;;
7	;; Copyright 2008 Ivan Raikov.
8	;;
9	;;
10	;; Redistribution and use in source and binary forms, with or without
11	;; modification, are permitted provided that the following conditions
12	;; are met:
13	;;
14	;; - Redistributions of source code must retain the above copyright
15	;; notice, this list of conditions and the following disclaimer.
16	;;
17	;; - Redistributions in binary form must reproduce the above
18	;; copyright notice, this list of conditions and the following
19	;; disclaimer in the documentation and/or other materials provided
20	;; with the distribution.
21	;;
22	;; - Neither name of the copyright holders nor the names of its
23	;; contributors may be used to endorse or promote products derived
24	;; from this software without specific prior written permission.
25	;;
26	;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
27	;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
28	;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
29	;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
30	;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
31	;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
32	;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
33	;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
34	;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
35	;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
36	;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
37	;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
38	;; POSSIBILITY OF SUCH DAMAGE.
39	;;
40
41	(require-extension syntax-case)
42	(require-extension matchable)
43	(require-extension srfi-1)
44	(require-extension srfi-4)
45	(require-extension srfi-13)
46	(require-extension srfi-14)
47
48	(define-extension uri-generic)
49
50	(declare
51	(usual-integrations)
52	(fixnum)
53	(inline)
54	(lambda-lift)
55	(export uri-reference
56	uri? uri-auth uri-authority uri-scheme uri-path uri-query
57	uri-fragment uri-host uri-port uri-username uri-password
58	absolute-uri uri->string uri->list uri-char-list-escape
59	uri-char-list->string uri-string->char-list
60	uri-relative-to uri-relative-from
61	uri-normalize-case uri-normalize-path-segments))
62
63
64	(define-record URI scheme authority path query fragment)
65	(define-record URIAuth username password host port)
66
67	(define-record-printer (URI x out)
68	(fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
69	(URI-scheme x)
70	(URI-authority x)
71	(URI-path x)
72	(URI-query x)
73	(URI-fragment x)))
74
75	(define-record-printer (URIAuth x out)
76	(fprintf out "#(URIAuth host=~S port=~A)"
77	(URIAuth-host x)
78	(URIAuth-port x)))
79
80	(define uri? URI?)
81
82	(define uri-auth URI-authority )
83	(define uri-authority URI-authority )
84	(define uri-scheme URI-scheme )
85	(define uri-path URI-path )
86	(define uri-query URI-query )
87	(define uri-fragment URI-fragment )
88
89	(define (uri-host x)
90	(let ((auth (URI-authority x)))
91	(and auth (URIAuth-host auth))))
92
93	(define (uri-port x)
94	(let ((auth (URI-authority x)))
95	(and auth (URIAuth-port auth))))
96
97	(define (uri-username x)
98	(let ((auth (URI-authority x)))
99	(and auth (URIAuth-username auth))))
100
101	(define (uri-password x)
102	(let ((auth (URI-authority x)))
103	(and auth (URIAuth-password auth))))
104
105	;; Character classes
106
107	(define (hexdigit-char? c) (char-set-contains? char-set:hex-digit c))
108
109	(define (reserved-char? c) (char-set-contains? char-set:reserved c))
110
111	(define (unreserved-char? c) (char-set-contains? char-set:unreserved c))
112
113	(define (scheme-char? c) (char-set-contains? char-set:scheme c))
114
115	(define (ipv-future-char? c) (char-set-contains? char-set:ipv-future c))
116
117	(define (pct-escaped? c) (match c ((#\% h1 h2) #t) (else #f)))
118
119
120	;; Helper functions for character parsing
121
122	(define (uchar extras)
123	(let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
124	(lambda (c) (or (pct-escaped? c) (unreserved-char? c)
125	(char-set-contains? char-set:sub-delims c)
126	(char-set-contains? extras-set c) ))))
127
128	;; same as uchar, but without sub-delims
129	(define (schar extras)
130	(let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
131	(lambda (c) (or (pct-escaped? c) (unreserved-char? c)
132	(char-set-contains? extras-set c) ))))
133
134	(define (many pred?)
135	(lambda (s)
136	(let loop ((lst (list)) (rst s))
137	(cond ((null? rst) (list (reverse lst) rst))
138	((pred? (car rst)) (loop (cons (car rst) lst) (cdr rst)))
139	(else (list (reverse lst) rst))))))
140
141	(define (many1 pred?)
142	(lambda (s)
143	(let ((a1 (and (not (null? s)) (pred? (car s)) (car s))))
144	(and a1 (match ((many pred?) (cdr s))
145	((as rst) (list (cons a1 as) rst))
146	(else #f))))))
147
148
149	(define (count-min-max m n pred?)
150	(lambda (s)
151	(let loop ((m m) (n n) (lst (list)) (rst s))
152	(cond ((and (pair? rst) (positive? m))
153	(if (pred? (car rst))
154	(loop (- m 1) (- n 1) (cons (car rst) lst) (cdr rst)) #f))
155	((or (<= n 0) (null? rst)) (list (reverse lst) rst))
156	(else
157	(if (pred? (car rst))
158	(loop 0 (- n 1) (cons (car rst) lst) (cdr rst))
159	(list (reverse lst) rst)))))))
160
161	;; Parser combinators
162
163	(define (consume f)
164	(lambda (s)
165	(let loop ((lst (list)) (rst s))
166	(match (f rst)
167	((a rst) (loop (cons a lst) rst))
168	(else (list (reverse lst) rst))))))
169
170
171	(define (consume-count n f)
172	(lambda (s)
173	(let loop ((n n) (lst (list)) (rst s))
174	(if (positive? n)
175	(match (or (f rst) (list #f s))
176	((x rst) (and x (loop (- n 1) (cons x lst) rst))))
177	(list (reverse lst) rst)))))
178
179
180	(define (consume-min-max m n f)
181	(lambda (s)
182	(let loop ((m m) (n n) (lst (list)) (rst s))
183	(cond ((positive? m)
184	(match (f rst)
185	((a1 rst) (loop (- m 1) (- n 1) (cons a1 lst) rst))
186	(else #f)))
187	((<= n 0) (list (reverse lst) rst))
188	(else
189	(match (f rst)
190	((a1 rst) (loop 0 (- n 1) (cons a1 lst) rst))
191	(else #f)))))))
192
193	;; Helper function for malformed ip address error messages
194
195	(define (try-ip-literal->string s)
196	(let loop ((lst (list)) (rst s))
197	(match rst ((#\] . rst) (uri-char-list->string (reverse lst)))
198	(() (uri-char-list->string (reverse lst)))
199	(else (loop (cons (car rst) lst) (cdr rst))))))
200
201	;; RFC 3986, section 2.1
202	;;
203	;; Returns a 'pct-encoded' sequence of octets.
204	;;
205	(define (pct-escape lst)
206	(define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
207	(reverse (fold (lambda (x ax)
208	(let ((h1 (hex-digit (quotient x 16)))
209	(h2 (hex-digit (remainder x 16))))
210	(cons `(#\% ,h1 ,h2) ax)))
211	(list) lst)))
212
213	;; RFC3986, section 2.2
214	;;
215	;; Reserved characters.
216	;;
217
218	(define char-set:gen-delims (string->char-set ":/?#[]@"))
219	(define char-set:sub-delims (string->char-set "!$&'()*+,;="))
220
221	(define char-set:reserved (char-set-union char-set:gen-delims char-set:sub-delims))
222
223	;; RFC3986, section 2.3
224	;;
225	;; "Unreserved" characters.
226	;;
227
228	(define char-set:unreserved
229	(char-set-union char-set:letter+digit (string->char-set "-_.~")))
230
231
232	;; RFC3986, section 3
233	;;
234	;; URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
235	;;
236	;; hier-part = "//" authority path-abempty
237	;; / path-abs
238	;; / path-rootless
239	;; / path-empty
240
241	(define (uri s)
242	(let ((s (if (string? s) (uri-string->char-list s) s)))
243	(match (scheme s)
244	((us rst)
245	(match-let* (((ua up rst) (hier-part rst))
246	((uq rst) (match rst ((#\? . rst) (query rst))
247	(else (list #f rst))))
248	((uf rst) (match rst ((#\# . rst) (fragment rst))
249	(else (list #f rst)))))
250	(make-URI (string->symbol (list->string us)) ua
251	(map uri-char-list->string up) (and uq (filter-map query->string uq))
252	(and uf (uri-char-list->string uf)))))
253	(else #f))))
254
255	(define (hier-part s)
256	(match s ((#\/ #\/ . rst)
257	(match-let* (((ua rst) (authority rst))
258	((up rst) (path-abempty rst)))
259	(list ua up rst)))
260	(else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list (list) s))))
261	(list #f up rst)))))
262
263	;; RFC3986, section 3.1
264
265	(define scheme0 (many scheme-char?))
266	(define (scheme s)
267	(match (scheme0 s)
268	((ss (#\: . rst)) (list ss rst))
269	(else #f)))
270
271	(define char-set:scheme
272	(char-set-union char-set:letter+digit (string->char-set "+-.")))
273
274
275	;; RFC3986, section 3.2
276
277	(define (authority s)
278	(match-let* (((uu uw rst) (or (userinfo s) (list #f #f s)))
279	((uh rst) (host rst))
280	((up rst) (or (port rst) (list #f rst))))
281	(list (make-URIAuth (and uu (uri-char-list->string uu)) (and uw (uri-char-list->string uw))
282	(uri-char-list->string uh)
283	(and (pair? up) (string->number (list->string up))))
284	rst)))
285
286	;; RFC3986, section 3.2.1
287
288	(define userinfo0 (many (uchar ";&=+$,")))
289
290	(define (userinfo s)
291	(match (userinfo0 s)
292	((uu ( #\: . rst)) (match (userinfo0 rst)
293	((up ( #\@ . rst) ) (list uu up rst))
294	(else #f)))
295	((uu ( #\@ . rst)) (list uu (list) rst))
296	(else #f)))
297
298
299
300	;; RFC3986, section 3.2.2
301
302	(define (host s) (or (ip-literal s) (ipv4-address s) (reg-name s)))
303
304	(define (ip-literal s)
305	(match s ((#\[ . rst)
306	(match (or (ipv6-address rst) (ipv-future rst))
307	((ua (#\] . rst)) (list ua rst))
308	(else (error 'ip-literal "malformed ip literal" (try-ip-literal->string rst)))))
309	(else #f)))
310
311	(define ipv-future0 (many ipv-future-char?))
312
313	(define (ipv-future s)
314	(match s ((#\v (? hexdigit-char?) #\. . rst) (ipv-future0 rst))
315	(else #f)))
316
317	(define char-set:ipv-future
318	(char-set-union char-set:unreserved char-set:sub-delims (char-set #\;)))
319
320
321
322	;; Pv6address = 6( h16 ":" ) ls32
323	;; / "::" 5( h16 ":" ) ls32
324	;; / [ h16 ] "::" 4( h16 ":" ) ls32
325	;; / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
326	;; / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
327	;; / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32
328	;; / [ *4( h16 ":" ) h16 ] "::" ls32
329	;; / [ *5( h16 ":" ) h16 ] "::" h16
330	;; / [ *6( h16 ":" ) h16 ] "::"
331
332	;; ls32 = ( h16 ":" h16 ) / IPv4address
333	;; ; least-significant 32 bits of address
334
335	;; h16 = 1*4HEXDIG
336	;; ; 16 bits of address represented in hexadecimal
337
338
339	(define (ipv6-address s)
340	(or (match (u6-h4c s) ;; 6( h16 ":" ) ls32
341
342	((a2 rst) (match (ls32 rst)
343	((a3 rst) (list (append (concatenate a2) a3) rst))
344	(else #f)))
345	(else #f))
346	(match s ;; "::" 5( h16 ":" ) ls32
347	((#\: #\: . rst)
348	(match (u5-h4c rst)
349	((a2 rst) (match (ls32 rst)
350	((a3 rst) (list (append (list #\: #\:) (concatenate a2) a3) rst))
351	(else #f)))))
352	(else #f))
353	(match (u_opt_n_h4c_h4 0 s)
354	((a1 rst) (match rst
355	((#\: #\: . rst)
356	(match (u4-h4c rst)
357	((a2 rst) (match (ls32 rst)
358	((a3 rst)
359	(list (append (concatenate a1) (list #\: #\:)
360	(concatenate a2) a3) rst))
361	(else #f)))
362	(else #f)
363	))
364	(else #f)))
365	(else #f))
366	(match (u_opt_n_h4c_h4 1 s)
367	((a1 rst)
368	(match rst
369	((#\: #\: . rst)
370	(match (u3-h4c rst)
371	((a2 rst) (match (ls32 rst)
372	((a3 rst)
373	(list (append (concatenate a1) (list #\: #\:)
374	(concatenate a2) a3) rst))
375	(else #f)))
376	(else #f)
377	))
378	(else #f)))
379	(else #f))
380	(match (u_opt_n_h4c_h4 2 s)
381	((a1 rst) (match rst
382	((#\: #\: . rst)
383	(match (u2-h4c rst)
384	((a2 rst) (match (ls32 rst)
385	((a3 rst) (list (append (concatenate a1) (list #\: #\:)
386	(concatenate a2) a3) rst))
387	(else #f)))
388	(else #f)
389	))
390	(else #f)))
391	(else #f))
392	(match (u_opt_n_h4c_h4 3 s)
393	((a1 rst) (match rst
394	((#\: #\: . rst)
395	(match (h4c rst)
396	((a2 rst) (match (ls32 rst)
397	((a3 rst) (list (append (concatenate a1) (list #\: #\:)
398	(concatenate a2) a3) rst))
399	(else #f)))
400	(else #f)
401	))
402	(else #f)))
403	(else #f))
404	(match (u_opt_n_h4c_h4 4 s)
405	((a1 rst) (match rst
406	((#\: #\: . rst)
407	(match (ls32 rst)
408	((a3 rst) (list (append (concatenate a1) (list #\: #\:) a3) rst))
409	(else #f)))
410	(else #f)))
411	(else #f))
412	(match (u_opt_n_h4c_h4 5 s)
413	((a1 rst) (match rst
414	((#\: #\: . rst)
415	(match (h4 rst)
416	((a3 rst) (list (append (concatenate a1) (list #\: #\:) a3) rst))
417	(else #f)))
418	(else #f)))
419	(else #f))
420	(match (u_opt_n_h4c_h4 6 s)
421	((a1 rst) (match rst
422	((#\: #\: . rst)
423	(list (append (concatenate a1) (list #\: #\:)) rst))
424	(else #f)))
425	(else #f))
426	(error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))
427
428
429
430	(define (u_opt_n_h4c_h4 n s)
431	(match ((consume-min-max 0 n h4c) s)
432	((a1 rst) (match (h4 rst)
433	((a2 rst) (list (append a1 (list a2)) rst))
434	(else #f)))
435	(else #f)))
436
437	(define (ls32 s)
438	(match (h4c s)
439	((a1 rst) (match (h4 rst)
440	((a2 rst) (list (append a1 a2) rst))
441	(else (ipv4-address s))))
442	(else (ipv4-address s))))
443
444	(define (h4c s)
445	(match (h4 s)
446	((a1 (#\: (and r1 (not #\:)) . rst))
447	(list (append a1 (list #\:)) (cons r1 rst)))
448	(else #f)))
449
450	(define u6-h4c (consume-count 6 h4c))
451	(define u5-h4c (consume-count 5 h4c))
452	(define u4-h4c (consume-count 4 h4c))
453	(define u3-h4c (consume-count 3 h4c))
454	(define u2-h4c (consume-count 2 h4c))
455
456	(define h4 (count-min-max 1 4 hexdigit-char?))
457
458	(define (ipv4-address s)
459	(match (dec-octet s)
460	((a1 (#\. rst))
461	(match (dec-octet rst)
462	((a2 (#\. rst))
463	(match (dec-octet rst)
464	((a3 (#\. rst))
465	(match (dec-octet rst)
466	((a4 rst) (list (append a1 #\. a2 #\. a3 #\. a4) rst))
467	(else #f)))
468	(else #f)))
469	(else #f)))
470	(else #f)))
471
472	(define (dec-char->num c)
473	(case c ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4) ((#\5) 5)
474	((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
475
476	(define (ipv4-octet? lst)
477	(let loop ((n (reverse (map dec-char->num lst))) (i 1) (ax 0))
478	(if (null? n) (and (>= ax 0) (<= ax 255))
479	(loop (cdr n) (* i 10) (+ ax (* i (car n)))))))
480
481	(define (dec-octet s)
482	(match ((count-min-max 1 3 char-numeric?) s)
483	(((and a1 (? ipv4-octet?)) rst) (list a1 rst))
484	(else #f)))
485
486	(define reg-name
487	(count-min-max 0 255 (lambda (c) (or (unreserved-char? c)
488	(pct-escaped? c)
489	(char-set-contains? char-set:sub-delims c) ))))
490
491	;; RFC3986, section 3.2.3
492
493	(define port0 (many char-numeric?))
494
495	(define (port s)
496	(match s ((#\: . rst) (port0 rst))
497	(else #f)))
498
499
500	;;
501	;; RFC3986, section 3.3
502	;;
503	;; path = path-abempty ; begins with "/" or is empty
504	;; / path-abs ; begins with "/" but not "//"
505	;; / path-noscheme ; begins with a non-colon segment
506	;; / path-rootless ; begins with a segment
507	;; / path-empty ; zero characters
508	;;
509	;; path-abempty = *( "/" segment )
510	;; path-abs = "/" [ segment-nz *( "/" segment ) ]
511	;; path-noscheme = segment-nzc *( "/" segment )
512	;; path-rootless = segment-nz *( "/" segment )
513	;; path-empty = 0<pchar>
514	;;
515	;; segment = *pchar
516	;; segment-nz = 1*pchar
517	;; segment-nzc = 1*( unreserved / pct-encoded / sub-delims / "@" )
518	;;
519	;; pchar = unreserved / pct-encoded / sub-delims / ":" / "@"
520
521	(define (path s)
522	(or (path-abempty s) (path-abs s) (path-noscheme s)
523	(path-rootless s) (list (list) s)))
524
525
526	(define (slash-segment s)
527	(match s
528	((#\/ . rst) (match (segment rst)
529	((ss rst) (list (cons #\/ ss) rst))
530	(else #f)))
531	(else #f)))
532
533	(define pchar (uchar ":@"))
534
535	(define segment (many pchar))
536
537	(define segment-nz (many1 pchar))
538
539	(define segment-nzc (many1 (uchar "@")))
540
541	(define path-abempty (consume slash-segment))
542
543	(define (path-abs s)
544	(match s
545	((#\/ . rst) (match (path-rootless rst)
546	((() rst) (list (list #\/) rst))
547	((lst rst) (list (cons (cons #\/ (car lst)) (cdr lst)) rst))
548	(else #f)))
549	(else #f)))
550
551	(define (path-noscheme s)
552	(match (segment-nzc s)
553	((s1 rst) (match (path-abempty rst)
554	((ss rst) (list (cons s1 ss) rst))
555	(else (list (list s1) rst))))
556	(else #f)))
557
558	(define (path-rootless s)
559	(match (segment-nz s)
560	((s1 rst) (match (path-abempty rst)
561	((ss rst) (list (cons s1 ss) rst))
562	(else #f)))
563	(else #f)))
564
565	;; RFC3986, section 3.4
566
567
568	(define query0 (many (schar ":@/?!$'()*+,;=")))
569	(define (query1 s)
570	(match s ((#\& . rst) (query0 rst))
571	(else #f)))
572
573	(define (query s)
574	(match (query0 s)
575	((q1 rst)
576	(match ((consume query1) rst)
577	((qs rst) (list (cons q1 qs) rst))
578	(else (list (list q1) rst))))
579	(else #f)))
580
581	(define query-part (many (schar ":@/?!$'()*+,;")))
582
583	(define (query->string s)
584	(match (query-part s)
585	((p1 (#\= . rst)) (match (query-part rst)
586	((p2 _) `(,(uri-char-list->string p1) . ,(uri-char-list->string p2)))
587	(else #f)))
588	((p1 ()) `(,(uri-char-list->string p1)))
589	(else #f)))
590
591
592	;; RFC3986, section 3.5
593
594
595	(define fragment0 (many (uchar ":@/?")))
596	(define (fragment s)
597	(match (fragment0 s)
598	((ss rst) (list ss rst))
599	(else #f)))
600
601	;; Reference, Relative and Absolute URI forms
602	;;
603	;; RFC3986, section 4.1
604
605	(define (uri-reference s)
606	(let ((s (if (string? s) (uri-string->char-list s) s)))
607	(or (uri s) (relative-ref s))))
608
609	;; RFC3986, section 4.2
610	;;
611	;; relative-URI = relative-part [ "?" query ] [ "#" fragment ]
612	;;
613	;; relative-part = "//" authority path-abempty
614	;; / path-abs
615	;; / path-noscheme
616	;; / path-empty
617
618	(define (relative-ref s)
619	(and (not (scheme s))
620	(match-let* (((ua up rst) (relative-part s))
621	((uq rst) (match rst ((#\? . rst) (query rst))
622	(else (list #f rst))))
623	((uf rst) (match rst ((#\# . rst) (fragment rst))
624	(else (list #f rst)))))
625	(make-URI #f ua (map uri-char-list->string up)
626	(and uq (filter-map query->string uq))
627	(and uf (uri-char-list->string uf))))))
628	(define (relative-part s)
629	(match s
630	((#\/ #\/ . rst)
631	(match-let* (((ua rst) (authority rst))
632	((up rst) (path-abempty rst)))
633	(list ua up rst)))
634	(else (match-let* (((up rst) (or (path-abs s) (path-noscheme s) (list (list) s))))
635	(list #f up rst)))))
636
637
638
639	;; RFC3986, section 4.3
640
641	(define (absolute-uri s)
642	(match (scheme s)
643	((us rst)
644	(match-let (((ua up rst) (hier-part rst))
645	((uq rst) (match rst ((#\? . rst) (query rst))
646	(else (list (list) rst)))))
647	(make-URI us ua up uq #f)))))
648
649
650	;; Turns a URI into a string.
651	;;
652	;; Uses a supplied function to map the userinfo part of the URI.
653	;;
654
655	(define (uri->string uri . rest)
656	(let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
657	(match uri
658	(($ URI scheme authority path query fragment)
659	(string-append
660	((lambda (x) (or (and x (string-append (->string x) ":")) "")) scheme)
661	(if authority (string-append (uri-auth->string authority userinfomap) "/") "")
662	(string-concatenate path)
663	(if query (string-concatenate (cons "?" (intersperse query "&"))) "")
664	(if fragment (string-append "#" fragment) "")))
665	(else #f))))
666
667	(define (uri-auth->string uri-auth userinfomap)
668	(match uri-auth
669	(($ URIAuth username password host port)
670	(string-append "//" (if (and username password)
671	((lambda (x) (or (and x (string-append x "@")) ""))
672	(userinfomap username password)) "")
673	host ((lambda (x) (or (and x (string-append ":" (->string x))) ""))
674	port)))
675	(else #f)))
676
677	; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
678
679	(define (uri->list uri . rest)
680	(let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
681	(match uri
682	(($ URI scheme authority path query fragment)
683	`(,scheme (,(uri-auth->list authority userinfomap) ,path ,query) ,fragment))
684	(else #f))))
685
686	(define (uri-auth->list uri-auth userinfomap)
687	(match uri-auth
688	(($ URIAuth username password regname port)
689	`(,(if (and username password) (userinfomap username password) #f) ,regname ,port ))
690	(else #f)))
691
692
693	;; Escape sequence handling
694
695	(define (uri-char-list-escape p enc str)
696	(reverse
697	(fold (lambda (c ax)
698	(if (not (p c)) (let* ((os (enc c)) (cs (map pct-escape os)))
699	(append (reverse cs) ax))
700	(cons c ax)))
701	(list) str)))
702
703	;; Convert a URI character list to a string
704
705	(define (uri-char-list->string s)
706	(list->string
707	(reverse
708	(fold (lambda (x ax)
709	(cond ((char? x) (cons x ax))
710	((list? x) (append (reverse x) ax)))) (list) s))))
711
712	;; Convert a string to a URI character list
713
714	(define (uri-string->char-list s)
715	(let loop ((cs (list)) (lst (string->list s)))
716	(if (null? lst) (reverse cs)
717	(match lst
718	((#\% h1 h2 . rst) (loop (cons (list #\% h1 h2) cs) rst))
719	(((and c (? char?)) . rst) (loop (cons c cs) rst))))))
720
721	;;
722	;; Resolving a relative URI relative to a base URI
723	;;
724	;; Returns a new URI which represents the value of the first URI
725	;; interpreted as relative to the second URI.
726	;;
727	;; For example:
728	;;
729	;; (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
730	;; => "http://bar.org/foo"
731	;;
732	;; (uri->string (non-strict-relative-to (uri "http:foo") (uri "http://bar.org/")) )
733	;; => "http://bar.org/foo"
734	;;
735	;; Algorithm from RFC3986, section 5.2.2
736	;;
737
738	(define (uri-relative-to ref base)
739	(and (uri? ref) (uri? base)
740	(cond ((uri-scheme ref) (just-segments ref))
741	((uri-authority ref) (let ((x (just-segments ref)))
742	(URI-scheme-set! x (uri-scheme base))
743	x))
744
745	(((lambda (p) (and (not (null? p)) p)) (uri-path ref)) =>
746	(lambda (ref-path)
747	(if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
748	(let ((x (just-segments ref)))
749	(URI-scheme-set! x (uri-scheme base))
750	(URI-authority-set! x (uri-auth base))
751	x)
752	(let ((x (udup ref)))
753	(URI-scheme-set! x (uri-scheme base))
754	(URI-authority-set! x (uri-auth base))
755	(URI-path-set! x (merge-paths base x))
756	(just-segments x)))))
757
758	((uri-query ref) (let ((x (udup ref)))
759	(URI-scheme-set! x (uri-scheme base))
760	(URI-authority-set! x (uri-auth base))
761	(URI-path-set! x (list "/"))
762	(URI-path-set! x (merge-paths base x))
763	(just-segments x)))
764
765	(else (let ((x (just-segments ref)))
766	(URI-scheme-set! x (uri-scheme base))
767	(URI-authority-set! x (uri-auth base))
768	(URI-path-set! x (uri-path base))
769	(URI-query-set! x (uri-query base))
770	x)))))
771
772	(define (just-segments u)
773	(let ((p (remove-dot-segments (uri-path u))))
774	(make-URI (uri-scheme u) (uri-auth u) p
775	(uri-query u) (uri-fragment u))))
776
777	(define (merge0 pb pr)
778	(let* ((rpb (reverse pb))
779	(pb1 (reverse (if (not (string=? (car rpb) "/")) (cdr rpb) rpb)))
780	(pr1 (or (and (pair? pr) (not (string-prefix? ".." (car pr))) (not (string-prefix? "." (car pr)))
781	(not (string-prefix? "/" (car pr)))
782	(cons (string-append "/" (car pr)) (cdr pr)))
783	pr)))
784	(append pb1 pr1)))
785
786	(define (merge-paths b r)
787	(let ((ba (uri-authority b))
788	(pb (uri-path b))
789	(pr (uri-path r)))
790	(let ((mp (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
791	mp)))
792
793	(define (uri-non-strict-relative-to ref base)
794	(let ((rs (uri-scheme ref))
795	(rb (uri-scheme base)))
796	(let ((ref1 (make-URI (if (eq? rs rb) #f (uri-scheme ref))
797	(uri-auth ref) (uri-path ref)
798	(uri-query ref) (uri-fragment ref))))
799	(uri-relative-to ref1 base))))
800
801
802	;; Remove dot segments, but protect leading '/' character
803
804	(define (remove-dot-segments ps)
805	(match ps (("/" . rst) (cons "/" (elim-dots rst)))
806	(else (elim-dots ps))))
807
808	(define (elim-dots ps)
809	(let loop ((ps ps) (lst (list)))
810	(if (null? ps) (reverse lst)
811	(match ps
812	(((or "." "/."))
813	(loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
814	(((or "." "/.") . rst)
815	(loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
816	(((or ".." "/.."))
817	(loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
818	(((or ".." "/..") . rst)
819	(loop rst (if (pair? lst) (cdr lst) lst)))
820	((x . rst) (loop rst (cons x lst)))))))
821
822	;;
823	;; Finding a URI relative to a base URI
824	;;
825	;; Returns a new URI which represents the relative location of the
826	;; first URI with respect to the second URI. Thus, the values
827	;; supplied are expected to be absolute URIs, and the result returned
828	;; may be a relative URI.
829	;;
830	;; Example:
831	;;
832	;; (uri->string
833	;; (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
834	;; (uri "http://example.com/Root/sub2/name2#frag")))
835	;; ==> "../sub1/name2#frag"
836	;;
837
838
839	(define (uri-relative-from uabs base)
840	(cond ((ucdiff? uri-scheme uabs base) (udup uabs))
841	((ucdiff? uri-authority uabs base) (let ((x (udup uabs)))
842	(URI-scheme-set! x #f)
843	x))
844	((ucdiff? uri-path uabs base)
845	(let ((x (udup uabs))
846	(path (rel-path-from (remove-body-dot-segments (uri-path uabs))
847	(remove-body-dot-segments (uri-path base)))))
848	(URI-scheme-set! x #f)
849	(URI-authority-set! x #f)
850	(URI-path-set! x path)
851	x))
852	((ucdiff? uri-query uabs base)
853	(let ((x (udup uabs)))
854	(URI-scheme-set! x #f)
855	(URI-authority-set! x #f)
856	(URI-path-set! x (list))
857	x))
858	(else
859	(let ((x (udup uabs)))
860	(URI-scheme-set! x #f)
861	(URI-authority-set! x #f)
862	(URI-query-set! x #f)
863	(URI-path-set! x (list))
864	x))))
865
866
867	(define (udup u)
868	(make-URI (uri-scheme u) (uri-auth u) (uri-path u)
869	(uri-query u) (uri-fragment u)))
870
871	(define (ucdiff? sel u1 u2)
872	(let ((s1 (sel u1))
873	(s2 (sel u2)))
874	(not (cond ((and (URIAuth? s1) (URIAuth? s2))
875	(not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
876	((and (list? s1) (list? s2)) (every string=? s1 s2))
877	((and (string? s1) (string? s2)) (string=? s1 s2))
878	(else (eq? s1 s2))))))
879
880	(define (remove-body-dot-segments p)
881	(or (and (pair? p)
882	(let ((r (reverse p)))
883	(reverse (cons (car r) (remove-dot-segments (cdr r))))))
884	p))
885
886	(define (rel-path-from pabs base)
887	(cond ((null? pabs) (list "/"))
888	((null? base) pabs)
889	;; Construct a relative path segment if the paths share a
890	;; leading segment other than a leading '/'
891	(else (match (list pabs base)
892	(((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
893	(if (string=? sa1 sb1)
894	(make-rel-path
895	(if (string=? "/" sa1)
896	(if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
897	(rel-path-from1 ra1 rb1)))
898	pabs))
899	(((sa1) (sb1 . rb1))
900	(if (string=? sa1 sb1) (rel-segs-from (list) rb1)
901	pabs))))))
902
903	(define (make-rel-path x)
904	(if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))
905
906	;; rel-path-from1 strips off trailing names from the supplied paths,
907
908	(define (rel-path-from1 pabs base)
909	(match-let* (((na . sa) (reverse pabs))
910	((nb . sb) (reverse base)))
911	(let ((rp (rel-segs-from (reverse sa) (reverse sb))))
912	(if (null? rp) (cond ((string=? na nb) (list))
913	((protect? na) (list (string-append "./" na)))
914	(else (list na)))
915	(append rp (list na))))))
916
917
918	(define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
919
920
921
922	;; rel-segs-from discards any common leading segments from both paths,
923	;; then invokes dif-segs-from to calculate a relative path from the end
924	;; of the base path to the end of the target path. The final name is
925	;; handled separately, so this deals only with "directory" segments.
926
927	(define (rel-segs-from sabs base)
928	(cond ((and (null? sabs) (null? base)) (list))
929	((or (null? sabs) (null? base)) (dif-segs-from sabs base))
930	(else (match-let (((sa1 . ra1) sabs)
931	((sb1 . rb1) base))
932	(if (string=? sa1 sb1)
933	(rel-segs-from ra1 rb1)
934	(dif-segs-from sabs base))))))
935
936	;; dif-segs-from calculates a path difference from base to target,
937	;; not including the final name at the end of the path (i.e. results
938	;; always ends with '/')
939	;;
940	;; This function operates under the invariant that the supplied value
941	;; of sabs is the desired path relative to the beginning of base.
942	;; Thus, when base is empty, the desired path has been found.
943
944	(define (dif-segs-from sabs base)
945	(if (null? base) sabs (dif-segs-from (cons ".." sabs) (cdr base))))
946
947
948
949	;; Other normalization functions
950	;;
951	;; Case normalization; cf. RFC3986 section 6.2.2.1
952	;; NOTE: authority case normalization is not performed
953
954	(define (uri-normalize-case uri)
955	(let ((u1 (udup uri))
956	(scheme (string->symbol (string-downcase (->string (uri-scheme uri)))))
957	(path (map (lambda (c) (match c (('% h1 h2) `(% ,(char-upcase h1) ,(char-upcase h2)))
958	(else c))) (uri-path uri))))
959	(URI-scheme-set! u1 scheme)
960	(URI-path-set! u1 path)
961	u1))
962
963
964	;; Path segment normalization; cf. RFC3986 section 6.2.2.4
965
966	(define (uri-normalize-path-segments uri)
967	(let ((u1 (udup uri))
968	(path (remove-dot-segments (uri-path uri))))
969	(URI-path-set! u1 path)
970	u1))

Note: See TracBrowser for help on using the repository browser.

Download in other formats: