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

Last change on this file since 25789 was 25789, checked in by sjamaan, 9 years ago

uri-generic: Add some basic testcases for make-uri and get rid of error when no path is provided

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