source: project/release/4/uri-generic/tags/1.8/uri-generic.scm @ 13108

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

Merge changes in release 3

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