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

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

Merge latest changes from uri-generic release 4

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