source: project/release/4/uri-generic/tags/1.5/uri-generic.scm @ 11824

Last change on this file since 11824 was 11824, checked in by sjamaan, 13 years ago

Tag version 1.5

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