Context Navigation

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

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

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

Download in other formats: