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

Last change on this file since 36558 was 36558, checked in by sjamaan, 13 months ago

uri-generic: Keep in mind sometimes host might be #f, so we can't just call substring on it!

Reported by off_world

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