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

Last change on this file since 13105 was 13105, checked in by sjamaan, 11 years ago

Remove three more unused procedures and add a note about "path" not being used in the grammar

File size: 32.5 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(provide 'uri-generic)
41
42(module uri-generic
43  (uri-reference update-uri update-authority
44   uri? uri-auth uri-authority uri-scheme uri-path uri-query
45   uri-fragment uri-host uri-port uri-username uri-password
46   authority? authority-host authority-port
47   authority-username authority-password
48   
49   absolute-uri uri->string uri->list 
50   uri-relative-to uri-relative-from 
51   uri-decode-string uri-encode-string 
52   uri-normalize-case uri-normalize-path-segments
53
54   char-set:gen-delims char-set:sub-delims
55   char-set:uri-reserved char-set:uri-unreserved)
56
57(import chicken scheme extras data-structures)
58 
59(require-extension matchable defstruct srfi-1 srfi-4 srfi-13 srfi-14)
60
61;; What to do with these?
62#;(cond-expand
63   (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
64   (else (use srfi-13 srfi-14)))
65
66(defstruct URI      scheme authority path query fragment)
67(defstruct URIAuth  username password host port)
68
69(define-record-printer (URI x out)
70  (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
71           (URI-scheme x)
72           (URI-authority x)
73           (URI-path x)
74           (URI-query x)
75           (URI-fragment x)))
76
77(define-record-printer (URIAuth x out)
78  (fprintf out "#(URIAuth host=~S port=~A)"
79           (URIAuth-host x)
80           (URIAuth-port x)))
81
82(define uri? URI?)
83
84(define uri-auth       URI-authority )
85(define uri-authority  URI-authority )
86(define uri-scheme     URI-scheme )
87(define uri-path       URI-path )
88(define uri-query      URI-query )
89(define uri-fragment   URI-fragment )
90
91(define (uri-host x)
92  (let ((auth (URI-authority x)))
93    (and auth (URIAuth-host auth))))
94
95(define (uri-port x)
96  (let ((auth (URI-authority x)))
97    (and auth (URIAuth-port auth))))
98
99(define (uri-username x)
100  (let ((auth (URI-authority x)))
101    (and auth (URIAuth-username auth))))
102
103(define (uri-password x)
104  (let ((auth (URI-authority x)))
105    (and auth (URIAuth-password auth))))
106
107(define authority? URIAuth?)
108(define authority-host URIAuth-host)
109(define authority-port URIAuth-port)
110(define authority-username URIAuth-username)
111(define authority-password URIAuth-password)
112
113(define update-authority update-URIAuth)
114
115(define update-uri
116  (let ((unset (list 'unset)))
117   (lambda (uri . key/values)
118     (apply
119      (lambda (#!key
120               (scheme (URI-scheme uri)) (path (URI-path uri))
121               (query (URI-query uri)) (fragment (URI-fragment uri))
122               (auth unset) (authority unset))
123        (let* ((base-auth (or
124                           (cond
125                            ((not (eq? unset auth)) auth)
126                            ((not (eq? unset authority)) authority)
127                            (else (URI-authority uri)))
128                           (make-URIAuth)))
129               (updated-auth (apply update-authority base-auth key/values))
130               (final-auth (if (equal? (make-URIAuth) updated-auth)
131                               #f
132                               updated-auth)))
133          (make-URI scheme: scheme path: path query: query fragment: fragment
134                    authority: final-auth))) key/values))))
135
136;; Character classes
137 
138(define (hexdigit-char? c)    (and (char? c) (char-set-contains? char-set:hex-digit c)))
139
140(define (unreserved-char? c)  (and (char? c) (char-set-contains? char-set:uri-unreserved c)))
141
142(define (scheme-char? c)      (and (char? c) (char-set-contains? char-set:scheme c)))
143
144(define (ipv-future-char? c)  (and (char? c) (char-set-contains? char-set:ipv-future c)))
145
146(define (pct-encoded? c)      (match c ((#\% h1 h2) #t) (else #f)))
147
148
149;; Helper functions for character parsing
150 
151(define (uchar extras)
152  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
153    (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 
154                    (char-set-contains? char-set:sub-delims c) 
155                    (char-set-contains? extras-set c) ))))
156 
157(define (many pred?)
158  (lambda (s)
159    (let loop ((lst (list)) (rst s))
160      (cond ((null? rst)        (list (reverse lst) rst))
161            ((pred? (car rst))  (loop (cons (car rst) lst) (cdr rst)))
162            (else               (list (reverse lst) rst))))))
163
164(define (many1 pred?)
165  (lambda (s)
166    (let ((a1 (and (not (null? s)) (pred? (car s)) (car s))))
167      (and a1 (match ((many pred?) (cdr s))
168                     ((as rst)  (list (cons a1 as) rst))
169                     (else #f))))))
170
171
172(define (count-min-max m n pred?)
173  (lambda (s) 
174    (let loop ((m m) (n n) (lst (list)) (rst s))
175      (cond ((and (pair? rst) (positive? m))
176             (if (pred? (car rst))
177                 (loop (- m 1) (- n 1) (cons (car rst) lst) (cdr rst)) #f))
178            ((or (<= n 0) (null? rst))   (list (reverse lst) rst))
179            (else
180             (if (pred? (car rst))
181                 (loop 0 (- n 1) (cons (car rst) lst) (cdr rst))
182                 (list (reverse lst) rst)))))))
183
184;; Parser combinators
185
186(define (consume f) 
187  (lambda (s)
188    (let loop ((lst (list)) (rst s))
189      (match (f rst)
190             ((a rst)  (loop (cons a lst) rst))
191             (else  (list (reverse lst) rst))))))
192
193
194(define (consume-count n f)
195  (lambda (s)
196    (let loop ((n n) (lst (list)) (rst s))
197      (if (positive? n)
198          (match (or (f rst) (list #f s))
199                 ((x rst)  (and x (loop (- n 1) (cons x lst) rst))))
200          (list (reverse lst) rst)))))
201
202
203(define (consume-min-max m n f)
204  (lambda (s) 
205    (let loop ((m m) (n n) (lst (list)) (rst s))
206      (cond ((positive? m)
207             (match (f rst)
208                    ((a1 rst) (loop (- m 1) (- n 1) (cons a1 lst) rst))
209                    (else #f)))
210            ((<= n 0)   (list (reverse lst) rst))
211            (else
212             (match (f rst)
213                    ((a1 rst) (loop 0 (- n 1) (cons a1 lst) rst))
214                    (else #f)))))))
215
216;; Helper function for malformed ip address error messages
217
218(define (try-ip-literal->string s)
219  (let loop ((lst (list))  (rst s))
220    (match rst ((#\] . rst)  (uri-char-list->string (reverse lst)))
221           (()  (uri-char-list->string (reverse lst)))
222           (else (loop (cons (car rst) lst) (cdr rst))))))
223
224;; RFC 3986, section 2.1
225;;
226;; Returns a 'pct-encoded' sequence of octets.
227;;
228(define (pct-encode char-list char-set)
229  (define (hex-digit i)
230    (and (>= i 0) (< i 16)
231         (car (string->list (string-upcase (number->string i 16))))))
232  (reverse (fold (lambda (c cl)
233                   (if (char-set-contains? char-set c)
234                       (let* ((x (char->integer c))
235                              (h1 (hex-digit (quotient x 16)))
236                              (h2 (hex-digit (remainder x 16))))
237                         (cons `(#\% ,h1 ,h2) cl))
238                       (cons c cl)))
239                 (list) char-list)))
240
241;; Inverse operation: 'pct-decode' a sequence of octets.
242
243(define (pct-decode char-list char-set)
244  (define (octet-decode h1 h2)
245    (string->number (list->string (list h1 h2)) 16))
246  (map (lambda (c)
247        (match c
248               ((#\% h1 h2) (let ((dc (integer->char (octet-decode h1 h2))))
249                              (if (char-set-contains? char-set dc) dc c)))
250               (else c)))
251       char-list))
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:uri-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:uri-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: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
294                                  fragment: (and uf (uri-char-list->string uf)))))
295         (else #f))))
296
297(define (uri-path-list->path pcl)
298  (let ((cs (char-set-union char-set:uri-unreserved (char-set #\/))))
299    (match pcl
300           (('/ . rst) (cons '/ (map (lambda (c)
301                                       (uri-char-list->string (pct-decode c cs)))
302                                     rst)))
303           (else (map (lambda (c)
304                        (uri-char-list->string (pct-decode c cs)))
305                      pcl)))))
306
307(define (hier-part s)
308  (match s ((#\/ #\/ . rst) 
309            (match-let* (((ua rst)  (authority rst))
310                         ((up rst)  (path-abempty rst)))
311                        (list ua up rst)))
312         (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list '() s))))
313                          (list #f up rst)))))
314
315;;  RFC3986, section 3.1
316
317(define scheme0 (many scheme-char?))
318(define (scheme s)
319  (match (scheme0 s)
320         ((ss (#\: . rst))  (list ss rst))
321         (else #f)))
322
323(define char-set:scheme
324  (char-set-union char-set:letter+digit (string->char-set "+-.")))
325
326
327;;  RFC3986, section 3.2
328;;
329;;     authority     = [ userinfo "@" ] host [ ":" port ]
330
331(define (authority s)
332  (match-let* (((uu uw rst)   (or (userinfo s) (list #f #f s)))
333               ((uh rst)      (host rst))
334               ((up rst)      (or (port rst) (list #f rst))))
335              (list (make-URIAuth username: (and uu (uri-char-list->string uu)) 
336                                  password: (and uw (uri-char-list->string uw))
337                                  host: (uri-char-list->string uh) 
338                                  port: (and (pair? up) (string->number (list->string up))))
339                    rst)))
340
341;;  RFC3986, section 3.2.1
342;;
343;;     userinfo      = *( unreserved / pct-encoded / sub-delims / ":" )
344;;
345;; We split this up in the leading part without colons ("username") and
346;; everything after that ("password"), including extra colons.
347;;
348;; The RFC is not very clear, but it does mention this:
349;;   "The userinfo subcomponent may consist of a user name and,
350;;    optionally, scheme-specific information about how to gain
351;;    authorization to access the resource."
352;;
353;; The grammar allows multiple colons, and the RFC then continues:
354;;   "Applications should not render as clear text any data after
355;;    the first colon (":") character found within a userinfo
356;;    subcomponent unless the data after the colon is the empty
357;;    string (indicating no password)."
358
359(define userinfo0  (many (uchar ";&=+$,")))
360(define userinfo1  (many (uchar ";&=+$,:")))
361
362(define (userinfo s)
363  (match (userinfo0 s)
364         ((uu ( #\: . rst))   (match (userinfo1 rst)
365                                     ((up ( #\@ . rst) ) (list uu up rst))
366                                     (else #f)))
367         ((uu ( #\@ . rst)) (list uu #f rst))
368         (else #f)))
369
370
371;;  RFC3986, section 3.2.2
372;;
373;;     host          = IP-literal / IPv4address / reg-name
374;;     IP-literal    = "[" ( IPv6address / IPvFuture  ) "]"
375;;     IPvFuture     = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
376
377(define (host s)  (or (ip-literal s) (ipv4-address s) (reg-name s)))
378
379(define (ip-literal s)
380  (match s ((#\[ . rst) 
381            (match (or (ipv6-address rst) (ipv-future rst))
382                   ((ua (#\] . rst))  (list ua rst))
383                   (else (error 'ip-literal "malformed ip literal" (try-ip-literal->string rst)))))
384         (else #f)))
385
386(define ipv-future0  (many ipv-future-char?))
387
388(define (ipv-future s)
389  (match s ((#\v (? hexdigit-char?) #\. . rst)  (ipv-future0 rst))
390         (else #f)))
391
392(define char-set:ipv-future 
393  (char-set-union char-set:uri-unreserved char-set:sub-delims (char-set #\;)))
394
395
396
397;; IPv6address =                                  6( h16 ":" ) ls32
398;;                   /                       "::" 5( h16 ":" ) ls32
399;;                   / [               h16 ] "::" 4( h16 ":" ) ls32
400;;                   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
401;;                   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
402;;                   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
403;;                   / [ *4( h16 ":" ) h16 ] "::"              ls32
404;;                   / [ *5( h16 ":" ) h16 ] "::"              h16
405;;                   / [ *6( h16 ":" ) h16 ] "::"
406
407;;       ls32        = ( h16 ":" h16 ) / IPv4address
408;;                   ; least-significant 32 bits of address
409
410;;       h16         = 1*4HEXDIG
411;;                   ; 16 bits of address represented in hexadecimal
412
413
414(define (ipv6-address s)
415  (or (match (u6-h4c s) ;; 6( h16 ":" ) ls32
416
417             ((a2 rst)  (match (ls32 rst)
418                               ((a3 rst)  (list (append (concatenate a2) a3) rst))
419                               (else #f)))
420             (else #f))
421      (match s          ;; "::" 5( h16 ":" ) ls32
422             ((#\: #\: . rst) 
423              (match (u5-h4c rst)
424                     ((a2 rst)  (match (ls32 rst)
425                                       ((a3 rst)  (list (append (list #\: #\:) (concatenate a2) a3) rst))
426                                       (else #f)))))
427             (else #f))
428      (match (u_opt_n_h4c_h4 0 s)
429             ((a1 rst) (match rst
430                              ((#\: #\: . rst) 
431                               (match (u4-h4c rst)
432                                      ((a2 rst)  (match (ls32 rst)
433                                                        ((a3 rst) 
434                                                         (list (append (concatenate a1) (list #\: #\:) 
435                                                                       (concatenate a2) a3) rst))
436                                                        (else #f)))
437                                      (else #f)
438                                      ))
439                              (else #f)))
440              (else #f))
441      (match (u_opt_n_h4c_h4 1 s)
442             ((a1 rst) 
443                      (match rst       
444                              ((#\: #\: . rst) 
445                               (match (u3-h4c rst)
446                                      ((a2 rst)  (match (ls32 rst)
447                                                        ((a3 rst) 
448                                                         (list (append (concatenate a1) (list #\: #\:) 
449                                                                       (concatenate a2) a3) rst))
450                                                        (else #f)))
451                                      (else #f)
452                                      ))
453                              (else #f)))
454              (else #f))
455      (match (u_opt_n_h4c_h4 2 s)
456             ((a1 rst) (match rst       
457                              ((#\: #\: . rst) 
458                               (match (u2-h4c rst)
459                                      ((a2 rst)  (match (ls32 rst)
460                                                        ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
461                                                                                 (concatenate a2) a3) rst))
462                                                        (else #f)))
463                                      (else #f)
464                                      ))
465                              (else #f)))
466              (else #f))
467      (match (u_opt_n_h4c_h4 3 s)
468             ((a1 rst) (match rst       
469                              ((#\: #\: . rst) 
470                               (match (h4c rst)
471                                      ((a2 rst)  (match (ls32 rst)
472                                                        ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
473                                                                                 (concatenate a2) a3) rst))
474                                                        (else #f)))
475                                      (else #f)
476                                      ))
477                              (else #f)))
478              (else #f))
479      (match (u_opt_n_h4c_h4 4 s)
480             ((a1 rst) (match rst       
481                              ((#\: #\: . rst) 
482                               (match (ls32 rst)
483                                      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
484                                      (else #f)))
485                              (else #f)))
486              (else #f))
487      (match (u_opt_n_h4c_h4 5 s)
488             ((a1 rst) (match rst       
489                              ((#\: #\: . rst) 
490                               (match (h4 rst)
491                                      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
492                                      (else #f)))
493                              (else #f)))
494              (else #f))
495      (match (u_opt_n_h4c_h4 6 s)
496             ((a1 rst) (match rst       
497                              ((#\: #\: . rst) 
498                               (list (append (concatenate a1) (list #\: #\:)) rst))
499                              (else #f)))
500              (else #f))
501      (error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))
502
503
504
505(define (u_opt_n_h4c_h4 n s)
506  (match ((consume-min-max 0 n h4c) s)
507         ((a1 rst)  (match (h4 rst)
508                           ((a2 rst) (list (append a1 (list a2)) rst))
509                           (else #f)))
510         (else #f)))
511
512(define (ls32 s)
513  (match (h4c s)
514         ((a1 rst) (match (h4 rst)
515                          ((a2 rst)  (list (append a1 a2) rst))
516                          (else (ipv4-address s))))
517         (else (ipv4-address s))))
518
519(define (h4c s)
520  (match (h4 s)
521         ((a1 (#\: (and r1 (not #\:)) . rst))
522          (list (append a1 (list #\:)) (cons r1 rst)))
523         (else #f)))
524
525(define u6-h4c (consume-count 6 h4c))
526(define u5-h4c (consume-count 5 h4c))
527(define u4-h4c (consume-count 4 h4c))
528(define u3-h4c (consume-count 3 h4c))
529(define u2-h4c (consume-count 2 h4c))
530
531(define h4 (count-min-max 1 4 hexdigit-char?))
532
533(define (ipv4-address s)
534  (match (dec-octet s)
535         ((a1 (#\. rst)) 
536          (match (dec-octet rst)
537                 ((a2 (#\. rst)) 
538                  (match (dec-octet rst)
539                         ((a3 (#\. rst)) 
540                          (match (dec-octet rst)
541                                 ((a4 rst)  (list (append a1 #\. a2 #\. a3 #\. a4) rst))
542                                 (else #f)))
543                         (else #f)))
544                 (else #f)))
545         (else #f)))
546
547(define (ipv4-octet? lst)
548  (and (every (lambda (x) (char-set-contains? char-set:digit x)) lst)
549       (let ((num (string->number (list->string lst))))
550         (and num (>= num 0) (<= num 255)))))
551
552(define (dec-octet s)
553  (match ((count-min-max 1 3 char-numeric?) s)
554         (((and a1 (? ipv4-octet?)) rst)  (list a1 rst))
555         (else #f)))
556
557(define reg-name
558  (count-min-max 0 255 (lambda (c) (or (pct-encoded? c) 
559                                       (unreserved-char? c) 
560                                       (char-set-contains? char-set:sub-delims c) ))))
561
562;;  RFC3986, section 3.2.3
563;;
564;;     port          = *DIGIT
565
566(define port0 (many char-numeric?))
567
568(define (port s)
569  (match s ((#\: . rst)  (port0 rst))
570         (else #f)))
571
572
573;;
574;;  RFC3986, section 3.3
575;;
576;;   path          = path-abempty    ; begins with "/" or is empty
577;;                 / path-abs        ; begins with "/" but not "//"
578;;                 / path-noscheme   ; begins with a non-colon segment
579;;                 / path-rootless   ; begins with a segment
580;;                 / path-empty      ; zero characters
581;;
582;;  oddly, "path" is never used in the grammar. The following are used
583;;  in "hier-part" and "relative-ref", however:
584;;
585;;   path-abempty  = *( "/" segment )
586;;   path-abs      = "/" [ segment-nz *( "/" segment ) ]
587;;   path-noscheme = segment-nzc *( "/" segment )
588;;   path-rootless = segment-nz *( "/" segment )
589;;   path-empty    = 0<pchar>
590;;
591;;   segment       = *pchar
592;;   segment-nz    = 1*pchar
593;;   segment-nzc   = 1*( unreserved / pct-encoded / sub-delims / "@" )
594;;
595;;   pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
596
597(define (slash-segment s)
598  (match s
599         ((#\/ . rst)
600          (or (slash-segment rst)
601              (match (segment rst)
602                     ((ss rst)  (list ss rst))
603                     (else #f))))
604         (else  #f)))
605
606(define pchar (uchar ":@"))
607
608(define segment (many pchar))
609
610(define segment-nz (many1 pchar))
611
612(define segment-nzc (many1 (uchar "@")))
613
614(define (path-abempty s)
615  (match ((consume slash-segment) s)
616         ((() rst) (list (list) rst))
617         ((path rst) (list (cons '/ path) rst))))
618
619(define (path-abs s)
620  (match s
621         ((#\/)          (list (list '/ (list))  (list)))
622         ((#\/ . rst)    (match (path-rootless rst)
623                                ((lst rst) (list (cons '/ lst) rst))
624                                (else #f)))
625         (else #f)))
626
627(define (path-noscheme s)
628  (match (segment-nzc s)
629         ((s1 rst)  (match ((consume slash-segment) rst)
630                           ((ss rst) (list (cons s1 ss) rst))))
631         (else #f)))
632
633(define (path-rootless s)
634  (match (segment-nz s)
635         ((s1 rst)  (match ((consume slash-segment) rst)
636                           ((ss rst) (list (cons s1 ss) rst))))
637         (else #f)))
638
639;;  RFC3986, section 3.4
640;;
641;;   query         = *( pchar / "/" / "?" )
642
643(define query0  (many (uchar ":@/?")))
644(define (query s)
645  (match (query0 s)
646         ((ss rst)  (list ss rst))
647         (else #f)))
648
649;;  RFC3986, section 3.5
650;;   fragment         = *( pchar / "/" / "?" )
651
652(define fragment0  (many (uchar ":@/?")))
653(define (fragment s)
654  (match (fragment0 s)
655         ((ss rst)  (list ss rst))
656         (else #f)))
657
658;;  Reference, Relative and Absolute URI forms
659;;
660;;  RFC3986, section 4.1
661
662(define (uri-reference s)
663  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
664    (or (uri s) (relative-ref s))))
665
666;;  RFC3986, section 4.2
667;;
668;;   relative-URI  = relative-part [ "?" query ] [ "#" fragment ]
669;;
670;;   relative-part = "//" authority path-abempty
671;;                 / path-abs
672;;                 / path-noscheme
673;;                 / path-empty
674
675(define (relative-ref s)
676  (and (not (scheme s))
677       (match-let* (((ua up rst)  (relative-part s))
678                    ((uq rst)     (match rst ((#\? . rst) (query rst))
679                                         (else (list #f rst))))
680                    ((uf rst)     (match rst ((#\# . rst) (fragment rst))
681                                         (else (list #f rst)))))
682                   (make-URI scheme: #f authority: ua path: (uri-path-list->path up) 
683                             query: (and uq (uri-char-list->string uq))
684                             fragment: (and uf (uri-char-list->string uf))))))
685
686(define (relative-part s)
687  (match s
688         ((#\/ #\/ . rst)
689          (match-let* (((ua rst)  (authority rst))
690                       ((up rst)  (path-abempty rst)))
691                      (list ua up rst)))
692         (else (match-let* (((up rst)  (or (path-abs s) (path-noscheme s) (list (list) s))))
693                           (list #f up rst))))) 
694
695
696
697;;  RFC3986, section 4.3
698
699(define (absolute-uri s)
700  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
701    (match (scheme s)
702           ((us rst) 
703            (match-let* (((ua up rst)  (hier-part rst))
704                         ((uq rst)     (match rst ((#\? . rst)  (query rst))
705                                              (else (list #f rst)))))
706                        (make-URI scheme: (string->symbol (list->string us)) authority: ua 
707                                  path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
708                                  fragment: #f)))
709           (error 'absolute-uri "no scheme found in URI string"))))
710
711
712;; Turns a URI into a string.
713;;
714;; Uses a supplied function to map the userinfo part of the URI.
715;;
716
717(define (uri->string uri . rest)
718   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
719    (match uri
720           (($ URI scheme authority path query fragment)
721            (string-append
722             ((lambda (x) (or (and x (string-append (->string x) ":")) ""))  scheme)
723             (if authority
724                 (string-append (uri-auth->string authority userinfomap))
725                 "")
726             (path->string path)
727             (if query (string-append "?" query) "")
728             (if fragment (string-append  "#" fragment) "")))
729           (else #f))))
730
731(define (uri-auth->string uri-auth userinfomap)
732  (match uri-auth
733         (($ URIAuth username password host port)
734          (string-append "//" (if username
735                                  ((lambda (x) (or (and x (string-append x "@")) ""))
736                                   (userinfomap username password)) "")
737                         host ((lambda (x) (or (and x (string-append ":" (->string x))) ""))
738                               port)))
739         (else #f)))
740                         
741(define (path->string path)
742  (match path
743         (('/ . segments)     (string-append "/" (join-segments segments)))
744         (((? protect?) . _)  (join-segments (cons "." path)))
745         (else                (join-segments path))))
746
747(define (join-segments segments)
748  (string-intersperse
749   (map (lambda (segment)
750          (uri-encode-string segment (char-set #\/)))
751        segments) "/"))
752
753;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
754(define (protect? sa) (string-index sa #\:))
755
756; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
757
758(define (uri->list uri . rest)
759  (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
760    (match uri
761           (($ URI scheme authority path query fragment)
762            `(,scheme (,(uri-auth->list authority userinfomap) ,path ,query) ,fragment))
763           (else #f))))
764
765(define (uri-auth->list uri-auth userinfomap)
766  (match uri-auth
767         (($ URIAuth username password regname port)
768          `(,(if (and username password) (userinfomap username password) #f) ,regname ,port ))
769         (else #f)))
770                         
771
772;;  Percent encoding and decoding
773
774(define (uri-encode-string str #!optional (char-set (char-set-complement
775                                                     char-set:uri-unreserved)))
776  (let ((clst (string->list str)))
777    (uri-char-list->string
778     (pct-encode clst char-set))))
779
780(define (uri-decode-string str #!optional (char-set char-set:full))
781  (uri-char-list->string (pct-decode (uri-string->char-list str) char-set)))
782   
783(define (uri-string->normalized-char-list str)
784  (pct-decode (uri-string->char-list str) char-set:uri-unreserved))
785
786
787;; Convert a URI character list to a string
788
789(define (uri-char-list->string s)
790  (reverse-list->string 
791   (fold (lambda (x ax)
792           (cond ((char? x) (cons x ax))
793                 ((list? x) (append-reverse x ax)))) (list) s)))
794   
795;; Convert a string to a URI character list
796
797(define (uri-string->char-list s)
798  (let loop ((cs (list)) (lst (string->list s)))
799    (if (null? lst) (reverse cs)
800        (match lst
801               ((#\% h1 h2 . rst)  (loop (cons (list #\% h1 h2) cs) rst))
802               (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
803   
804;;
805;;  Resolving a relative URI relative to a base URI
806;;
807;;  Returns a new URI which represents the value of the first URI
808;;  interpreted as relative to the second URI.
809;;
810;;  For example:
811;;
812;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
813;;         => "http://bar.org/foo"
814;;
815;;  Algorithm from RFC3986, section 5.2.2
816;;
817
818(define (uri-relative-to ref base)
819  (and (uri? ref) (uri? base)
820       (cond ((uri-scheme ref)      (update-URI ref
821                                                path: (just-segments ref)))
822             ((uri-authority ref)   (update-URI ref
823                                                path: (just-segments ref)
824                                                scheme: (uri-scheme base)))
825             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
826              (lambda (ref-path)
827                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
828                    (update-URI ref
829                                scheme: (uri-scheme base)
830                                authority: (uri-auth base)
831                                path: (just-segments ref))
832                    (update-URI ref
833                                scheme: (uri-scheme base)
834                                authority: (uri-auth base)
835                                path: (merge-paths base (URI-path ref))))))
836             ((uri-query ref) (update-URI ref
837                                          scheme: (uri-scheme base)
838                                          authority: (uri-auth base)
839                                          path: (merge-paths base (list ""))))
840             (else (update-URI ref
841                               path: (URI-path base)
842                               scheme: (URI-scheme base)
843                               authority: (URI-authority base)
844                               query: (URI-query base))))))
845
846(define (just-segments u)
847  (remove-dot-segments (uri-path u)))
848
849(define (merge0 pb pr)
850  (let* ((rpb  (reverse pb))
851         (pb1  (reverse (if (pair? rpb) (cdr rpb) rpb))))
852    (append pb1 pr)))
853
854(define (merge-paths b pr)  ; pr is a path, *not* a URI object
855  (let ((ba (uri-authority b))
856        (pb (uri-path b)))
857    (let ((mp  (if (and ba (null? pb)) pr (merge0 pb pr))))
858      (remove-dot-segments mp))))
859
860;;  Remove dot segments, but protect leading '/' character
861
862(define (remove-dot-segments ps)
863  (match ps
864         (('/ . rst)   (cons '/ (elim-dots rst)))
865         (else         (elim-dots ps))))
866
867(define (elim-dots ps)
868  (let loop ((ps ps) (lst (list)))
869    (if (null? ps) (reverse lst)
870        (match ps
871               (("." . rst)
872                (loop rst (match lst
873                                 (("" dir . rest) lst)
874                                 ((file . rest) (cons "" lst))
875                                 (else (list "")))))
876               ((".." . rst)
877                (loop rst (match lst
878                                 (("" dir . rest) (cons "" rest))
879                                 ((file . rest) (cons "" rest))
880                                 (else (list "")))))
881               (("")
882                (loop (list) (match lst
883                                    (("" . rst2) lst)
884                                    (else (cons "" lst)))))
885               ((x . rst)
886                (loop rst (match lst
887                                 (("" . rst2) (cons x rst2))
888                                 (else (cons x lst)))))))))
889
890;;
891;; Finding a URI relative to a base URI
892;;
893;; Returns a new URI which represents the relative location of the
894;; first URI with respect to the second URI.  Thus, the values
895;; supplied are expected to be absolute URIs, and the result returned
896;; may be a relative URI.
897;;
898;; Example:
899;;
900;; (uri->string
901;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
902;;                     (uri "http://example.com/Root/sub2/name2#frag")))
903;;    ==> "../sub1/name2#frag"
904;;
905
906
907(define (uri-relative-from uabs base)
908  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
909        ((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
910        ;; Special case: no relative representation for http://a/ -> http://a
911        ;; ....unless that should be a path of ("..")
912        ((null? (uri-path uabs))             (update-URI uabs scheme: #f))
913        ((ucdiff? uri-path uabs base)
914         (update-URI uabs
915                     scheme: #f
916                     authority: #f
917                     path: (rel-path-from
918                            (remove-body-dot-segments (uri-path uabs))
919                            (remove-body-dot-segments (uri-path base)))))
920        ((ucdiff? uri-query uabs base)
921         (update-URI uabs
922                     scheme: #f
923                     authority: #f
924                     path: (list)))
925        (else
926         (update-URI uabs
927                     scheme: #f
928                     authority: #f
929                     query: #f
930                     path: (list)))))
931
932(define (ucdiff? sel u1 u2)
933  (let ((s1 (sel u1))
934        (s2 (sel u2)))
935    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
936                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
937               ((and (list? s1) (list? s2))       (every equal? s1 s2))
938               ((and (string? s1) (string? s2))   (string=? s1 s2))
939               (else                              (eq? s1 s2))))))
940
941(define (remove-body-dot-segments p)
942  (or (and (pair? p)
943           (let ((r (reverse p)))
944             (reverse (cons (car r) (remove-dot-segments (cdr r))))))
945      p))
946
947(define (rel-path-from pabs base)
948  (match (list pabs base)
949         ((pabs ()) pabs)
950         ((() base) (list))
951         ;; Construct a relative path segment if the paths share a
952         ;; leading segment other than a leading '/'
953         ((('/ . (and sa1 (ra1 . ra2))) ('/ . (and sb1 (rb1 . rb2))))
954          (make-rel-path
955           (if (string=? ra1 rb1)
956               (rel-path-from1 sa1 sb1)
957               pabs)))
958         (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))
959
960(define (make-rel-path x)
961  (match x
962         ((or ('/ . rst) ("." . rst) (".." rst)) x)
963         (else (cons "." x))))
964
965;;  rel-path-from1 strips off trailing names from the supplied paths,
966
967(define (rel-path-from1 pabs base)
968  (match-let* (((na . sa)  (reverse pabs)) 
969               ((nb . sb)  (reverse base)))
970     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
971       (if (null? rp)  (cond ((string=? na nb)  (list))
972                             (else              (list na)))
973           (append rp (list na))))))
974
975                         
976;;  rel-segs-from discards any common leading segments from both paths,
977;;  then invokes dif-segs-from to calculate a relative path from the end
978;;  of the base path to the end of the target path.  The final name is
979;;  handled separately, so this deals only with "directory" segments.
980
981(define (rel-segs-from sabs base)
982  (cond ((and (null? sabs) (null? base))  (list))
983        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
984        (else (match-let (((sa1 . ra1) sabs)
985                          ((sb1 . rb1) base))
986                         (if (string=? sa1 sb1)
987                             (rel-segs-from ra1 rb1)
988                             (dif-segs-from sabs base))))))
989
990;;  dif-segs-from calculates a path difference from base to target,
991;;  not including the final name at the end of the path (i.e. results
992;;  always ends with '/')
993;;
994;;  This function operates under the invariant that the supplied value
995;;  of sabs is the desired path relative to the beginning of base.
996;;  Thus, when base is empty, the desired path has been found.
997
998(define (dif-segs-from sabs base)
999  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
1000
1001
1002;; Other normalization functions
1003;;
1004;; Case normalization; cf. RFC3986 section 6.2.2.1
1005
1006(define (uri-normalize-case uri)
1007  (let* ((normalized-uri (uri-reference (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
1008         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
1009         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
1010    (update-uri normalized-uri scheme: scheme host: host)))
1011
1012(define (normalize-pct-encoding str)
1013  (uri-char-list->string
1014   (map (lambda (c) (match c
1015                           ((#\% h1 h2)  `(#\% ,(char-upcase h1) ,(char-upcase h2)))
1016                           (else c)))
1017        (uri-string->normalized-char-list str))))
1018
1019;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
1020
1021(define (uri-normalize-path-segments uri)
1022  (update-URI uri path: (just-segments uri)))
1023)
Note: See TracBrowser for help on using the repository browser.