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

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

Merge 1.11 - 1.12 changes from uri-generic release 4 into release 3

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