source: project/release/5/uri-generic/trunk/uri-generic.scm @ 36544

Last change on this file since 36544 was 36544, checked in by sjamaan, 5 weeks ago

uri-generic: Fix handling of ipv-future addresses (C5)

There were two problems with this:

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