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

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

Merge changes from release 4

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