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

Last change on this file since 12004 was 12004, checked in by sjamaan, 12 years ago

Merge in new uri-generic changes

File size: 30.4 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 (octet-decode h1 h2)
732  (string->number (list->string (list h1 h2)) 16))
733
734(define (uri-decode-string str)
735  (let loop ((clst (uri-string->char-list str)) (p (list))  (nlst (list)))
736    (if (null? clst)
737        (uri-char-list->string (reverse nlst))
738        (match (car clst)
739               ((and c (? char?)) 
740                (if (null? p) (loop (cdr clst) p (cons c nlst))
741                    (let ((pc (integer->char (octets->integer (reverse p)))))
742                      (loop (cdr clst) (list) (cons* c pc nlst)))))
743               ((#\% h1 h2) 
744                (loop (cdr clst) (cons (octet-decode h1 h2) p) nlst))
745               (else (error 'uri-decode-string "invalid URI string " str))))))
746   
747(define (uri-string->normalized-char-list str)
748  (let ((clst (uri-string->char-list str)))
749    (map (lambda (c) (if (pct-encoded? c) 
750                         (let ((e (pct-decode c)))
751                           (if (unreserved-char? e) e c)) c))
752         clst)))
753                         
754
755
756;; Convert a URI character list to a string
757
758(define (uri-char-list->string s)
759  (list->string
760   (reverse
761    (fold (lambda (x ax)
762                  (cond ((char? x) (cons x ax))
763                        ((list? x) (append (reverse x) ax)))) (list) s))))
764   
765;; Convert a string to a URI character list
766
767(define (uri-string->char-list s)
768  (let loop ((cs (list)) (lst (string->list s)))
769    (if (null? lst) (reverse cs)
770        (match lst
771               ((#\% h1 h2 . rst)  (loop (cons (list #\% h1 h2) cs) rst))
772               (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
773   
774;;
775;;  Resolving a relative URI relative to a base URI
776;;
777;;  Returns a new URI which represents the value of the first URI
778;;  interpreted as relative to the second URI.
779;;
780;;  For example:
781;;
782;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
783;;         => "http://bar.org/foo"
784;;
785;;  (uri->string (non-strict-relative-to (uri "http:foo") (uri "http://bar.org/")) )
786;;         => "http://bar.org/foo"
787;;
788;;  Algorithm from RFC3986, section 5.2.2
789;;
790
791(define (uri-relative-to ref base)
792  (and (uri? ref) (uri? base)
793       (cond ((uri-scheme ref)      (update-URI ref
794                                                path: (just-segments ref)))
795             ((uri-authority ref)   (update-URI ref
796                                                path: (just-segments ref)
797                                                scheme: (uri-scheme base)))
798             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
799              (lambda (ref-path)
800                (if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
801                    (update-URI ref
802                                scheme: (uri-scheme base)
803                                authority: (uri-auth base)
804                                path: (just-segments ref))
805                    (update-URI ref
806                                scheme: (uri-scheme base)
807                                authority: (uri-auth base)
808                                path: (merge-paths base (URI-path ref))))))
809             ((uri-query ref) (update-URI ref
810                                          scheme: (uri-scheme base)
811                                          authority: (uri-auth base)
812                                          path: (merge-paths base (list "/"))))
813             (else (update-URI ref
814                               path: (URI-path base)
815                               scheme: (URI-scheme base)
816                               authority: (URI-authority base)
817                               query: (URI-query base))))))
818
819(define (just-segments u)
820  (remove-dot-segments (uri-path u)))
821
822(define (merge0 pb pr)
823  (let* ((rpb  (reverse pb))
824         (pb1  (reverse (if (not (string=? (car rpb) "/")) (cdr rpb) rpb)))
825         (pr1  (or (and (pair? pr) (not (string=? ".." (car pr))) (not (string=? "." (car pr)))
826                        (not (string-prefix? "/" (car pr))) 
827                        (cons (string-append "/" (car pr)) (cdr pr)))
828                   pr)))
829    (append pb1 pr1)))
830
831(define (merge-paths b pr)  ; pr is a path, *not* a URI object
832  (let ((ba (uri-authority b))
833        (pb (uri-path b)))
834    (let ((mp  (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
835      (remove-dot-segments mp))))
836
837(define (uri-non-strict-relative-to ref base)
838  (let ((rs (uri-scheme ref))
839        (rb (uri-scheme base)))
840    (let ((ref1 (update-URI ref scheme: (if (eq? rs rb) #f (uri-scheme ref)))))
841      (uri-relative-to ref1 base))))
842
843
844;;  Remove dot segments, but protect leading '/' character
845
846(define (remove-dot-segments ps)
847  (match ps (("/" . rst)   (cons "/" (elim-dots rst)))
848         (else             (elim-dots ps))))
849
850(define (elim-dots ps)
851  (let loop ((ps ps) (lst (list)))
852    (if (null? ps) (reverse lst)
853        (match ps
854               (((or "." "/."))
855                (loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
856               (((or "." "/.") . rst)
857                (loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
858               (((or ".." "/.."))         
859                (loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
860               (((or ".." "/..") . rst)
861                (loop rst (if (pair? lst) (cdr lst) lst)))
862               ((x . rst)       (loop rst (cons x lst)))))))
863
864;;
865;; Finding a URI relative to a base URI
866;;
867;; Returns a new URI which represents the relative location of the
868;; first URI with respect to the second URI.  Thus, the values
869;; supplied are expected to be absolute URIs, and the result returned
870;; may be a relative URI.
871;;
872;; Example:
873;;
874;; (uri->string
875;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
876;;                     (uri "http://example.com/Root/sub2/name2#frag")))
877;;    ==> "../sub1/name2#frag"
878;;
879
880
881(define (uri-relative-from uabs base)
882  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
883        ((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
884        ((ucdiff? uri-path uabs base)
885         (update-URI uabs
886                     scheme: #f
887                     authority: #f
888                     path: (rel-path-from
889                            (remove-body-dot-segments (uri-path uabs))
890                            (remove-body-dot-segments (uri-path base)))))
891        ((ucdiff? uri-query uabs base)
892         (update-URI uabs
893                     scheme: #f
894                     authority: #f
895                     path: (list)))
896        (else
897         (update-URI uabs
898                     scheme: #f
899                     authority: #f
900                     query: #f
901                     path: (list)))))
902
903(define (ucdiff? sel u1 u2)
904  (let ((s1 (sel u1))
905        (s2 (sel u2)))
906    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
907                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
908               ((and (list? s1) (list? s2))       (every string=? s1 s2))
909               ((and (string? s1) (string? s2))   (string=? s1 s2))
910               (else                              (eq? s1 s2))))))
911
912(define (remove-body-dot-segments p)
913  (or (and (pair? p)
914           (let ((r (reverse p)))
915             (reverse (cons (car r) (remove-dot-segments (cdr r))))))
916      p))
917
918(define (rel-path-from pabs base)
919  (cond  ((null? pabs)  (list "/"))
920         ((null? base)  pabs)
921         ;; Construct a relative path segment if the paths share a
922         ;; leading segment other than a leading '/'
923         (else  (match (list pabs base)
924                       (((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
925                        (if (string=? sa1 sb1)
926                            (make-rel-path
927                             (if (string=? "/" sa1)
928                                 (if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
929                                 (rel-path-from1 ra1 rb1)))
930                            pabs))
931                       (((sa1) (sb1 . rb1))
932                        (if (string=? sa1 sb1)  (rel-segs-from (list) rb1)
933                            pabs))))))
934
935(define (make-rel-path x)
936  (if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))
937
938;;  rel-path-from1 strips off trailing names from the supplied paths,
939
940(define (rel-path-from1 pabs base)
941  (match-let* (((na . sa)  (reverse pabs)) 
942               ((nb . sb)  (reverse base)))
943     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
944       (if (null? rp)  (cond ((string=? na nb)  (list))
945                             ((protect? na)     (list (string-append "./" na)))
946                             (else              (list na)))
947           (append rp (list na))))))
948
949                         
950(define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
951             
952
953
954;;  rel-segs-from discards any common leading segments from both paths,
955;;  then invokes dif-segs-from to calculate a relative path from the end
956;;  of the base path to the end of the target path.  The final name is
957;;  handled separately, so this deals only with "directory" segments.
958
959(define (rel-segs-from sabs base)
960  (cond ((and (null? sabs) (null? base))  (list))
961        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
962        (else (match-let (((sa1 . ra1) sabs)
963                          ((sb1 . rb1) base))
964                         (if (string=? sa1 sb1)
965                             (rel-segs-from ra1 rb1)
966                             (dif-segs-from sabs base))))))
967
968;;  dif-segs-from calculates a path difference from base to target,
969;;  not including the final name at the end of the path (i.e. results
970;;  always ends with '/')
971;;
972;;  This function operates under the invariant that the supplied value
973;;  of sabs is the desired path relative to the beginning of base.
974;;  Thus, when base is empty, the desired path has been found.
975
976(define (dif-segs-from sabs base)
977  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
978
979
980;; Other normalization functions
981;;
982;; Case normalization; cf. RFC3986 section 6.2.2.1
983;; NOTE:  authority case normalization is not performed
984
985(define (uri-normalize-case uri)
986  (let ((scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
987        (path    (map (lambda (c) (match c (('% h1 h2)  `(% ,(char-upcase h1) ,(char-upcase h2)))
988                                         (else c))) (uri-path uri))))
989    (update-URI uri scheme: scheme path: path)))
990
991
992;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
993
994(define (uri-normalize-path-segments uri)
995  (update-URI uri path: (just-segments uri)))
996)
Note: See TracBrowser for help on using the repository browser.