source: project/release/4/uri-generic/trunk/uri-generic.scm @ 11794

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

Simplify a bit by using update-URI instead of using make-URI with the values of the old URI all the time

File size: 29.2 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  (match (scheme s)
638         ((us rst) 
639          (match-let (((ua up rst)  (hier-part rst))
640                      ((uq rst)     (match rst ((#\? . rst)  (query rst))
641                                           (else (list (list) rst)))))
642                     (make-URI scheme: us authority: ua path: up query: uq fragment: #f)))))
643                     
644
645;; Turns a URI into a string.
646;;
647;; Uses a supplied function to map the userinfo part of the URI.
648;;
649
650(define (uri->string uri . rest)
651   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
652    (match uri
653           (($ URI scheme authority path query fragment)
654            (string-append
655             ((lambda (x) (or (and x (string-append (->string x) ":")) ""))  scheme)
656             (if authority (string-append (uri-auth->string authority userinfomap) "/") "")
657             (string-concatenate path)
658             (if query (string-concatenate (cons "?" (intersperse query "&"))) "")
659             (if fragment (string-append  "#" fragment) "")))
660           (else #f))))
661
662(define (uri-auth->string uri-auth userinfomap)
663  (match uri-auth
664         (($ URIAuth username password host port)
665          (string-append "//" (if (and username password)
666                                  ((lambda (x) (or (and x (string-append x "@")) ""))
667                                   (userinfomap username password)) "")
668                         host ((lambda (x) (or (and x (string-append ":" (->string x))) ""))
669                               port)))
670         (else #f)))
671                         
672; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
673
674(define (uri->list uri . rest)
675  (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
676    (match uri
677           (($ URI scheme authority path query fragment)
678            `(,scheme (,(uri-auth->list authority userinfomap) ,path ,query) ,fragment))
679           (else #f))))
680
681(define (uri-auth->list uri-auth userinfomap)
682  (match uri-auth
683         (($ URIAuth username password regname port)
684          `(,(if (and username password) (userinfomap username password) #f) ,regname ,port ))
685         (else #f)))
686                         
687
688;;  Escape sequence handling
689
690(define (uri-char-list-escape p enc str)
691  (reverse
692   (fold (lambda (c ax) 
693           (if (not (p c)) (let* ((os (enc c))  (cs (map pct-escape os)))
694                             (append (reverse cs) ax))
695               (cons c ax)))
696         (list) str)))
697
698;; Convert a URI character list to a string
699
700(define (uri-char-list->string s)
701  (list->string
702   (reverse
703    (fold (lambda (x ax)
704                  (cond ((char? x) (cons x ax))
705                        ((list? x) (append (reverse x) ax)))) (list) s))))
706   
707;; Convert a string to a URI character list
708
709(define (uri-string->char-list s)
710  (let loop ((cs (list)) (lst (string->list s)))
711    (if (null? lst) (reverse cs)
712        (match lst
713               ((#\% h1 h2 . rst)  (loop (cons (list #\% h1 h2) cs) rst))
714               (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
715   
716;;
717;;  Resolving a relative URI relative to a base URI
718;;
719;;  Returns a new URI which represents the value of the first URI
720;;  interpreted as relative to the second URI.
721;;
722;;  For example:
723;;
724;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
725;;         => "http://bar.org/foo"
726;;
727;;  (uri->string (non-strict-relative-to (uri "http:foo") (uri "http://bar.org/")) )
728;;         => "http://bar.org/foo"
729;;
730;;  Algorithm from RFC3986, section 5.2.2
731;;
732
733(define (uri-relative-to ref base)
734  (and (uri? ref) (uri? base)
735       (cond ((uri-scheme ref)      (just-segments ref))
736             ((uri-authority ref)   (let ((x (just-segments ref)))
737                                      (URI-scheme-set! x (uri-scheme base))
738                                      x))
739
740             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
741              (lambda (ref-path)
742                (if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
743                    (let ((x (just-segments ref)))
744                      (URI-scheme-set! x (uri-scheme base))
745                      (URI-authority-set! x (uri-auth base))
746                      x)
747                    (let ((x (udup ref)))
748                      (URI-scheme-set! x (uri-scheme base))
749                      (URI-authority-set! x (uri-auth base))
750                      (URI-path-set! x (merge-paths base x))
751                      (just-segments x)))))
752
753             ((uri-query ref)       (let ((x (udup ref)))
754                                      (URI-scheme-set! x (uri-scheme base))
755                                      (URI-authority-set! x (uri-auth base))
756                                      (URI-path-set! x (list "/"))
757                                      (URI-path-set! x (merge-paths base x))
758                                      (just-segments x)))
759
760             (else                  (let ((x (just-segments ref)))
761                                      (URI-scheme-set! x (uri-scheme base))
762                                      (URI-authority-set! x (uri-auth base))
763                                      (URI-path-set! x (uri-path base))
764                                      (URI-query-set! x (uri-query base))
765                                      x)))))
766
767(define (just-segments u)
768  (let ((p (remove-dot-segments (uri-path u))))
769    (update-URI u path: p)))
770
771(define (merge0 pb pr)
772  (let* ((rpb  (reverse pb))
773         (pb1  (reverse (if (not (string=? (car rpb) "/")) (cdr rpb) rpb)))
774         (pr1  (or (and (pair? pr) (not (string=? ".." (car pr))) (not (string=? "." (car pr)))
775                        (not (string-prefix? "/" (car pr))) 
776                        (cons (string-append "/" (car pr)) (cdr pr)))
777                   pr)))
778    (append pb1 pr1)))
779
780(define (merge-paths b r)
781  (let ((ba (uri-authority b))
782        (pb (uri-path b))
783        (pr (uri-path r)))
784    (let ((mp  (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
785      mp)))
786
787(define (uri-non-strict-relative-to ref base)
788  (let ((rs (uri-scheme ref))
789        (rb (uri-scheme base)))
790    (let ((ref1 (update-URI ref scheme: (if (eq? rs rb) #f (uri-scheme ref)))))
791      (uri-relative-to ref1 base))))
792
793
794;;  Remove dot segments, but protect leading '/' character
795
796(define (remove-dot-segments ps)
797  (match ps (("/" . rst)   (cons "/" (elim-dots rst)))
798         (else             (elim-dots ps))))
799
800(define (elim-dots ps)
801  (let loop ((ps ps) (lst (list)))
802    (if (null? ps) (reverse lst)
803        (match ps
804               (((or "." "/."))
805                (loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
806               (((or "." "/.") . rst)
807                (loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
808               (((or ".." "/.."))         
809                (loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
810               (((or ".." "/..") . rst)
811                (loop rst (if (pair? lst) (cdr lst) lst)))
812               ((x . rst)       (loop rst (cons x lst)))))))
813
814;;
815;; Finding a URI relative to a base URI
816;;
817;; Returns a new URI which represents the relative location of the
818;; first URI with respect to the second URI.  Thus, the values
819;; supplied are expected to be absolute URIs, and the result returned
820;; may be a relative URI.
821;;
822;; Example:
823;;
824;; (uri->string
825;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
826;;                     (uri "http://example.com/Root/sub2/name2#frag")))
827;;    ==> "../sub1/name2#frag"
828;;
829
830
831(define (uri-relative-from uabs base)
832  (cond ((ucdiff? uri-scheme uabs base)      (udup uabs))
833        ((ucdiff? uri-authority uabs base)   (let ((x (udup uabs)))
834                                               (URI-scheme-set! x #f)
835                                               x))
836        ((ucdiff? uri-path uabs base)       
837         (let ((x    (udup uabs))
838               (path (rel-path-from (remove-body-dot-segments (uri-path uabs))
839                                    (remove-body-dot-segments (uri-path base)))))
840           (URI-scheme-set! x #f)
841           (URI-authority-set! x #f)
842           (URI-path-set! x path)
843           x))
844        ((ucdiff? uri-query uabs base) 
845         (let ((x (udup uabs)))
846           (URI-scheme-set! x #f)
847           (URI-authority-set! x #f)
848           (URI-path-set! x (list))
849           x))
850        (else                            
851         (let ((x (udup uabs)))
852           (URI-scheme-set! x #f)
853           (URI-authority-set! x #f)
854           (URI-query-set! x #f)
855           (URI-path-set! x (list))
856           x))))
857
858
859(define (udup u)
860  (update-URI u))
861
862(define (ucdiff? sel u1 u2)
863  (let ((s1 (sel u1))
864        (s2 (sel u2)))
865    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
866                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
867               ((and (list? s1) (list? s2))       (every string=? s1 s2))
868               ((and (string? s1) (string? s2))   (string=? s1 s2))
869               (else                              (eq? s1 s2))))))
870
871(define (remove-body-dot-segments p)
872  (or (and (pair? p)
873           (let ((r (reverse p)))
874             (reverse (cons (car r) (remove-dot-segments (cdr r))))))
875      p))
876
877(define (rel-path-from pabs base)
878  (cond  ((null? pabs)  (list "/"))
879         ((null? base)  pabs)
880         ;; Construct a relative path segment if the paths share a
881         ;; leading segment other than a leading '/'
882         (else  (match (list pabs base)
883                       (((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
884                        (if (string=? sa1 sb1)
885                            (make-rel-path
886                             (if (string=? "/" sa1)
887                                 (if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
888                                 (rel-path-from1 ra1 rb1)))
889                            pabs))
890                       (((sa1) (sb1 . rb1))
891                        (if (string=? sa1 sb1)  (rel-segs-from (list) rb1)
892                            pabs))))))
893
894(define (make-rel-path x)
895  (if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))
896
897;;  rel-path-from1 strips off trailing names from the supplied paths,
898
899(define (rel-path-from1 pabs base)
900  (match-let* (((na . sa)  (reverse pabs)) 
901               ((nb . sb)  (reverse base)))
902     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
903       (if (null? rp)  (cond ((string=? na nb)  (list))
904                             ((protect? na)     (list (string-append "./" na)))
905                             (else              (list na)))
906           (append rp (list na))))))
907
908                         
909(define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
910             
911
912
913;;  rel-segs-from discards any common leading segments from both paths,
914;;  then invokes dif-segs-from to calculate a relative path from the end
915;;  of the base path to the end of the target path.  The final name is
916;;  handled separately, so this deals only with "directory" segments.
917
918(define (rel-segs-from sabs base)
919  (cond ((and (null? sabs) (null? base))  (list))
920        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
921        (else (match-let (((sa1 . ra1) sabs)
922                          ((sb1 . rb1) base))
923                         (if (string=? sa1 sb1)
924                             (rel-segs-from ra1 rb1)
925                             (dif-segs-from sabs base))))))
926
927;;  dif-segs-from calculates a path difference from base to target,
928;;  not including the final name at the end of the path (i.e. results
929;;  always ends with '/')
930;;
931;;  This function operates under the invariant that the supplied value
932;;  of sabs is the desired path relative to the beginning of base.
933;;  Thus, when base is empty, the desired path has been found.
934
935(define (dif-segs-from sabs base)
936  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
937
938
939
940;; Other normalization functions
941;;
942;; Case normalization; cf. RFC3986 section 6.2.2.1
943;; NOTE:  authority case normalization is not performed
944
945(define (uri-normalize-case uri)
946  (let ((u1      (udup uri))
947        (scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
948        (path    (map (lambda (c) (match c (('% h1 h2)  `(% ,(char-upcase h1) ,(char-upcase h2)))
949                                         (else c))) (uri-path uri))))
950    (URI-scheme-set! u1 scheme)
951    (URI-path-set! u1 path)
952    u1))
953
954
955;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
956
957(define (uri-normalize-path-segments uri)
958  (let ((u1      (udup uri))
959        (path    (remove-dot-segments (uri-path uri))))
960    (URI-path-set! u1 path)
961    u1))
962)
Note: See TracBrowser for help on using the repository browser.