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

Last change on this file since 30643 was 30643, checked in by Ivan Raikov, 7 years ago

uri-generic: applied portability patch from Seth Alves.

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