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

Last change on this file since 11817 was 11817, checked in by Ivan Raikov, 13 years ago

Fixed to uri->string and absolute-uri.

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