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

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

Make use of uri-encode-string in join-segments; make encoded characters uppercase hexchars (as per normalization rules)

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