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

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

Merge changes from release 4

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