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

Last change on this file since 13212 was 13212, checked in by sjamaan, 11 years ago

Merge latest changes in release 4 trunk

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