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

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

Rename char-sets and export them; make uri-{encode,decode}-string accept an optional char-set argument

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