source: project/release/4/uri-generic/tags/2.31/uri-generic.scm @ 15453

Last change on this file since 15453 was 15453, checked in by Ivan Raikov, 11 years ago

uri-generic release 2.31

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