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

Last change on this file since 36542 was 36542, checked in by sjamaan, 11 months ago

uri-generic: Fix one particular ipv6 edge case where we attempted to concatenate a flat list (C5)

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 (? hexdigit-char?) #\. . rst)  (ipv-future0 rst))
616         (else #f)))
617
618(define char-set:ipv-future 
619  (char-set-union char-set:uri-unreserved char-set:sub-delims (char-set #\;)))
620
621
622
623;; IPv6address =                                  6( h16 ":" ) ls32
624;;                   /                       "::" 5( h16 ":" ) ls32
625;;                   / [               h16 ] "::" 4( h16 ":" ) ls32
626;;                   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
627;;                   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
628;;                   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
629;;                   / [ *4( h16 ":" ) h16 ] "::"              ls32
630;;                   / [ *5( h16 ":" ) h16 ] "::"              h16
631;;                   / [ *6( h16 ":" ) h16 ] "::"
632
633;;       ls32        = ( h16 ":" h16 ) / IPv4address
634;;                   ; least-significant 32 bits of address
635
636;;       h16         = 1*4HEXDIG
637;;                   ; 16 bits of address represented in hexadecimal
638
639
640(define (ipv6-address s)
641  (or (match (u6-h4c s) ;; 6( h16 ":" ) ls32
642             ((a2 rst) (match (ls32 rst)
643                              ((a3 rst)  (list (append (concatenate a2) a3) rst))
644                              (else #f)))
645             (else #f))
646      (match s          ;; "::" 5( h16 ":" ) ls32
647             ((#\: #\: . rst) 
648              (match (u5-h4c rst)
649                     ((a2 rst)  (match (ls32 rst)
650                                       ((a3 rst)  (list (append (list #\: #\:) (concatenate a2) a3) rst))
651                                       (else #f)))
652                     (else #f)))
653             (else #f))
654      (match (u_opt_n_h4c_h4 0 s)
655             ((a1 rst) (match rst
656                              ((#\: #\: . rst) 
657                               (match (u4-h4c rst)
658                                      ((a2 rst)  (match (ls32 rst)
659                                                        ((a3 rst) 
660                                                         (list (append (concatenate a1) (list #\: #\:) 
661                                                                       (concatenate a2) a3) rst))
662                                                        (else #f)))
663                                      (else #f)
664                                      ))
665                              (else #f)))
666             (else #f))
667      (match (u_opt_n_h4c_h4 1 s)
668             ((a1 rst) 
669                      (match rst       
670                              ((#\: #\: . rst) 
671                               (match (u3-h4c rst)
672                                      ((a2 rst)  (match (ls32 rst)
673                                                        ((a3 rst) 
674                                                         (list (append (concatenate a1) (list #\: #\:) 
675                                                                       (concatenate a2) a3) rst))
676                                                        (else #f)))
677                                      (else #f)
678                                      ))
679                              (else #f)))
680              (else #f))
681      (match (u_opt_n_h4c_h4 2 s)
682             ((a1 rst) (match rst       
683                              ((#\: #\: . rst) 
684                               (match (u2-h4c rst)
685                                      ((a2 rst)  (match (ls32 rst)
686                                                        ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
687                                                                                 (concatenate a2) a3) rst))
688                                                        (else #f)))
689                                      (else #f)
690                                      ))
691                              (else #f)))
692              (else #f))
693      (match (u_opt_n_h4c_h4 3 s)
694             ((a1 rst) (match rst       
695                              ((#\: #\: . rst) 
696                               (match (h4c rst)
697                                      ((a2 rst)  (match (ls32 rst)
698                                                        ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
699                                                                                 a2 a3) rst))
700                                                        (else #f)))
701                                      (else #f)
702                                      ))
703                              (else #f)))
704              (else #f))
705      (match (u_opt_n_h4c_h4 4 s)
706             ((a1 rst) (match rst       
707                              ((#\: #\: . rst) 
708                               (match (ls32 rst)
709                                      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
710                                      (else #f)))
711                              (else #f)))
712             (else #f))
713      (match (u_opt_n_h4c_h4 5 s)
714             ((a1 rst) (match rst       
715                              ((#\: #\: . rst)
716                               (match (h4 rst)
717                                      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
718                                      (else #f)))
719                              (else #f)))
720               (else #f))
721      (match (u_opt_n_h4c_h4 6 s)
722             ((a1 rst) (match rst       
723                              ((#\: #\: . rst) 
724                               (list (append (concatenate a1) (list #\: #\:)) rst))
725                              (else #f)))
726              (else #f))
727      (uri-error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))
728
729
730
731(define (u_opt_n_h4c_h4 n s)
732  (match ((consume-min-max 0 n h4c) s)
733         ((a1 rst)  (match (h4 rst)
734                           ((a2 rst) (list (append a1 (list a2)) rst))
735                           (else (list a1 rst))))
736         (else #f)))
737
738(define (ls32 s)
739  (match (h4c s)
740         ((a1 rst) (match (h4 rst)
741                          ((a2 rst)  (list (append a1 a2) rst))
742                          (else (ipv4-address s))))
743         (else (ipv4-address s))))
744
745(define (h4c s)
746  (match (h4 s)
747         ((a1 (#\: (and r1 (not #\:)) . rst))
748          (list (append a1 (list #\:)) (cons r1 rst)))
749         (else #f)))
750
751(define u6-h4c (consume-count 6 h4c))
752(define u5-h4c (consume-count 5 h4c))
753(define u4-h4c (consume-count 4 h4c))
754(define u3-h4c (consume-count 3 h4c))
755(define u2-h4c (consume-count 2 h4c))
756
757(define h4 (count-min-max 1 4 hexdigit-char?))
758
759(define (ipv4-address s)
760  (match (dec-octet s)
761         ((a1 (#\. . rst))
762          (match (dec-octet rst)
763                 ((a2 (#\. . rst))
764                  (match (dec-octet rst)
765                         ((a3 (#\. . rst))
766                          (match (dec-octet rst)
767                                 ((a4 rst)  (list (list a1 #\. a2 #\. a3 #\. a4) rst))
768                                 (else #f)))
769                         (else #f)))
770                 (else #f)))
771         (else #f)))
772
773(define (ipv4-octet? lst)
774  (and (every (lambda (x) (char-set-contains? char-set:digit x)) lst)
775       (let ((num (string->number (list->string lst))))
776         (and num (>= num 0) (<= num 255)))))
777
778(define (dec-octet s)
779  (match ((count-min-max 1 3 (lambda (c) (and (char? c) (char-numeric? c)))) s)
780         (((and a1 (? ipv4-octet?)) rst)  (list a1 rst))
781         (else #f)))
782
783(define reg-name
784  (count-min-max 0 255 (lambda (c) (or (pct-encoded? c) 
785                                       (unreserved-char? c) 
786                                       (char-set-contains? char-set:sub-delims c) ))))
787
788;;  RFC3986, section 3.2.3
789;;
790;;     port          = *DIGIT
791
792(define port0 (many char-numeric?))
793
794(define (port s)
795  (match s ((#\: . rst)  (port0 rst))
796         (else #f)))
797
798
799;;
800;;  RFC3986, section 3.3
801;;
802;;   path          = path-abempty    ; begins with "/" or is empty
803;;                 / path-abs        ; begins with "/" but not "//"
804;;                 / path-noscheme   ; begins with a non-colon segment
805;;                 / path-rootless   ; begins with a segment
806;;                 / path-empty      ; zero characters
807;;
808;;  oddly, "path" is never used in the grammar. The following are used
809;;  in "hier-part" and "relative-ref", however:
810;;
811;;   path-abempty  = *( "/" segment )
812;;   path-abs      = "/" [ segment-nz *( "/" segment ) ]
813;;   path-noscheme = segment-nzc *( "/" segment )
814;;   path-rootless = segment-nz *( "/" segment )
815;;   path-empty    = 0<pchar>
816;;
817;;   segment       = *pchar
818;;   segment-nz    = 1*pchar
819;;   segment-nzc   = 1*( unreserved / pct-encoded / sub-delims / "@" )
820;;
821;;   pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
822
823(define (slash-segment s)
824  (match s
825         ((#\/ . rst)
826          (match (segment rst)
827            ((ss rst)  (list ss rst))
828            (else #f)))
829         (else  #f)))
830
831(define pchar (uchar ":@"))
832
833(define segment (many pchar))
834
835(define segment-nz (many1 pchar))
836
837(define segment-nzc (many1 (uchar "@")))
838
839(define (path-abempty s)
840  (match ((consume slash-segment) s)
841         ((() rst)    (list (list) rst))
842         ((path rst)  (list (cons '/ path) rst))))
843
844(define (path-abs s)
845  (match s
846         ((#\/)          (list (list '/ (list))  (list)))
847         ((#\/ . rst)    (match (path-rootless rst) ; optional
848                                ((lst rst) (list (cons '/ lst) rst))
849                                (else (list (list '/ (list)) rst))))
850         (else #f)))
851
852(define (path-noscheme s)
853  (match (segment-nzc s)
854         ((s1 rst)  (match ((consume slash-segment) rst)
855                           ((ss rst) (list (cons s1 ss) rst))))
856         (else #f)))
857
858(define (path-rootless s)
859  (match (segment-nz s)
860         ((s1 rst)  (match ((consume slash-segment) rst)
861                           ((ss rst) (list (cons s1 ss) rst))))
862         (else #f)))
863
864;;  RFC3986, section 3.4
865;;
866;;   query         = *( pchar / "/" / "?" )
867
868(define query0  (many (uchar ":@/?")))
869(define (query s)
870  (match (query0 s)
871         ((ss rst)  (list ss rst))
872         (else #f)))
873
874;;  RFC3986, section 3.5
875;;   fragment         = *( pchar / "/" / "?" )
876
877(define fragment0  (many (uchar ":@/?")))
878(define (fragment s)
879  (match (fragment0 s)
880         ((ss rst)  (list ss rst))
881         (else #f)))
882
883;;  Reference, Relative and Absolute URI forms
884;;
885;;  RFC3986, section 4.1
886
887(define (uri-reference s)
888  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
889    (and s (or (uri s) (relative-ref s)))))
890
891;; (define uri-reference? URI) ; Already defined as URI? (struct predicate)
892
893;;  RFC3986, section 4.2
894;;
895;;   relative-URI  = relative-part [ "?" query ] [ "#" fragment ]
896;;
897;;   relative-part = "//" authority path-abempty
898;;                 / path-abs
899;;                 / path-noscheme
900;;                 / path-empty
901
902;; TODO: Export a modified version of this  (one that accepts a string
903;;       and throws an exception instead of returning #f)
904(define (relative-ref s)
905  (and (not (scheme s))
906       (match-let* (((ua up rst)  (relative-part s))
907                    ((uq rst)     (match rst ((#\? . rst) (query rst))
908                                         (else (list #f rst))))
909                    ((uf rst)     (match rst ((#\# . rst) (fragment rst))
910                                         (else (list #f rst)))))
911                   (and (null? rst)
912                        (make-URI #f ua
913                                  (uri-path-list->path up)
914                                  (and uq (uri-char-list->string uq))
915                                  (and uf (uri-char-list->string uf)))))))
916
917(define (relative-ref? u)
918  (and (uri-reference? u) (not (uri-scheme u))))
919
920(define (relative-part s)
921  (match s
922         ((#\/ #\/ . rst)
923          (match-let* (((ua rst)  (authority rst))
924                       ((up rst)  (path-abempty rst)))
925                      (list ua up rst)))
926         (else (match-let* (((up rst)  (or (path-abs s) (path-noscheme s) (list (list) s))))
927                           (list #f up rst))))) 
928
929
930
931;;  RFC3986, section 4.3
932
933(define (absolute-uri s)
934  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
935    (and s (match (scheme s)
936                  ((us rst) 
937                   (match-let* (((ua up rst)  (hier-part rst))
938                                ((uq rst)     (match rst ((#\? . rst)  (query rst))
939                                                     (else (list #f rst)))))
940                               (match rst
941                      ((#\# . rst) (uri-error 'absolute-uri "fragments are not permitted in absolute URI"))
942                      (else (make-URI (string->symbol (list->string us))
943                                      ua
944                                      (uri-path-list->path up)
945                                      (and uq (uri-char-list->string uq))
946                                      #f)))))
947          (else (uri-error 'absolute-uri "no scheme found in URI string"))))))
948
949(define (absolute-uri? u)
950  (and (uri-reference? u) (not (relative-ref? u)) (not (uri-fragment u))))
951
952;; Turns a URI into a string.
953;;
954;; Uses a supplied function to map the userinfo part of the URI.
955;;
956
957
958
959(define (uri->string uri . maybe-userinfomap)
960  (let ((userinfomap (if (pair? maybe-userinfomap)
961                         (car maybe-userinfomap)
962                         (lambda (u pw)
963                           (string-append u ":******" )))))
964    (cond ((URI? uri)
965            (with-output-to-string
966              (lambda ()
967               (let ((scheme (URI-scheme uri))
968                     (authority (URI-authority uri))
969                     (path (URI-path uri))
970                     (query (URI-query uri))
971                     (fragment (URI-fragment uri)))
972                (display-fragments
973                  (list
974                   (and scheme (list scheme ":"))
975                   (and (URIAuth? authority)
976                        (string? (URIAuth-host authority))
977                        (let ((username (URIAuth-username authority))
978                              (password (URIAuth-password authority))
979                              (host (URIAuth-host authority))
980                              (ipv6? (URIAuth-ipv6-host? authority))
981                              (port (URIAuth-port authority)))
982                          (list "//" (and username (list (userinfomap
983                                                          username
984                                                          password) "@"))
985                                (if ipv6? "[" "") host (if ipv6? "]" "")
986                                (and port (list ":" port)))))
987                   (path->string path)
988                   (and query (list "?" query))
989                   (and fragment (list  "#" fragment))))))))
990           (else #f))))
991
992
993
994(define (display-fragments b)
995  (let loop ((fragments b))
996    (cond
997      ((null? fragments) (begin))
998      ((not (car fragments)) 
999       (loop (cdr fragments) ))
1000      ((null? (car fragments)) 
1001       (loop (cdr fragments) ))
1002      ((pair? (car fragments))
1003       (begin (loop (car fragments))
1004              (loop (cdr fragments) )))
1005      (else
1006       (display (car fragments))
1007       (loop (cdr fragments) )))))
1008
1009                         
1010(define (path->string path)
1011  (match path
1012         (('/ . segments)     (string-append "/" (join-segments segments)))
1013         (((? protect?) . _)  (join-segments (cons "." path)))
1014         (else                (join-segments path))))
1015
1016(define (join-segments segments)
1017  (string-intersperse
1018   (map (lambda (segment)
1019          (uri-encode-string segment (char-set #\/)))
1020        segments) "/"))
1021
1022;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
1023(define (protect? sa) (string-index sa #\:))
1024
1025; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
1026
1027(define (uri->list uri . maybe-userinfomap)
1028  (let ((userinfomap (if (pair? maybe-userinfomap)
1029                         (car maybe-userinfomap)
1030                         (lambda (u pw)
1031                           (string-append u ":******" )))))
1032    (cond ((URI? uri)
1033           `(,(URI-scheme uri)
1034             (,(uri-auth->list (URI-authority uri) userinfomap)
1035              ,(URI-path uri) ,(URI-query uri))
1036             ,(URI-fragment uri)))
1037           (else #f))))
1038
1039(define (uri-auth->list uri-auth userinfomap)
1040  (cond ((URIAuth? uri-auth)
1041         `(,(and (URIAuth-username uri-auth) (URIAuth-password uri-auth)
1042                 (userinfomap (URIAuth-username uri-auth)
1043                              (URIAuth-password uri-auth)))
1044           ,(URIAuth-host uri-auth)
1045           ,(URIAuth-port uri-auth)))
1046         (else #f)))
1047                         
1048
1049;;  Percent encoding and decoding
1050
1051(define (uri-encode-string str . maybe-char-set)
1052  (let ((char-set (if (pair? maybe-char-set)
1053                      (car maybe-char-set)
1054                      (char-set-complement char-set:uri-unreserved)))
1055        (clst (string->list str)))
1056    (uri-char-list->string
1057     (pct-encode clst char-set))))
1058
1059(define (uri-decode-string str . maybe-char-set)
1060  (let ((char-set (if (pair? maybe-char-set)
1061                      (car maybe-char-set)
1062                      char-set:full))
1063        (str1 (uri-string->char-list str)))
1064    (and str1 (uri-char-list->string (pct-decode str1 char-set)))))
1065   
1066(define (uri-string->normalized-char-list str)
1067  (let ((str1 (uri-string->char-list str)))
1068    (and str1 (pct-decode str1 char-set:uri-unreserved))))
1069
1070;; Convert a URI character list to a string
1071
1072(define (uri-char-list->string s)
1073  (reverse-list->string 
1074   (fold (lambda (x ax)
1075           (cond ((char? x) (cons x ax))
1076                 ((list? x) (append-reverse x ax)))) (list) s)))
1077   
1078;; Convert a string to a URI character list
1079
1080(define (uri-string->char-list s)
1081  (let loop ((cs (list)) (lst (string->list s)))
1082    (if (null? lst) (reverse cs)
1083        (match lst
1084               ((#\% h1 h2 . rst)  (and (hexdigit-char? h1) (hexdigit-char? h2)
1085                                        (loop (cons (list #\% h1 h2) cs) rst)))
1086               (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
1087   
1088;;
1089;;  Resolving a relative URI relative to a base URI
1090;;
1091;;  Returns a new URI which represents the value of the first URI
1092;;  interpreted as relative to the second URI.
1093;;
1094;;  For example:
1095;;
1096;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
1097;;         => "http://bar.org/foo"
1098;;
1099;;  Algorithm from RFC3986, section 5.2.2
1100;;
1101
1102(define (uri-relative-to ref base)
1103  (and (uri-reference? ref) (uri-reference? base)
1104       (cond ((uri-scheme ref)
1105              (update-URI ref 'path (just-segments ref)))
1106             ((uri-authority ref)
1107              (update-URI ref
1108                          'path (just-segments ref)
1109                          'scheme (uri-scheme base)))
1110             ((let ((p (uri-path ref))) (and (not (null? p)) p)) =>
1111              (lambda (ref-path)
1112                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
1113                    (update-URI ref
1114                                'scheme (uri-scheme base)
1115                                'authority (uri-auth base)
1116                                'path (just-segments ref))
1117                    (update-URI ref
1118                                'scheme (uri-scheme base)
1119                                'authority (uri-auth base)
1120                                'path (merge-paths base ref-path)))))
1121             ((uri-query ref)
1122              (update-URI ref
1123                          'scheme (uri-scheme base)
1124                          'authority (uri-auth base)
1125                          'path (merge-paths base (list ""))))
1126             (else (update-URI ref
1127                               'path (URI-path base)
1128                               'scheme (URI-scheme base)
1129                               'authority (URI-authority base)
1130                               'query (URI-query base))))))
1131
1132(define (just-segments u)
1133  (remove-dot-segments (uri-path u)))
1134
1135(define (merge0 pb pr)
1136  (let* ((rpb  (reverse pb))
1137         (pb1  (reverse (match rpb      ; RFC3986, section 5.2.3, second bullet
1138                               ((_ . rst) rst)
1139                               (else rpb)))))
1140    (append pb1 pr))) ; It is assumed we never get here if pr is empty!
1141
1142(define (merge-paths b pr)  ; pr is a relative path, *not* a URI object
1143  (let ((ba (uri-authority b))
1144        (pb (uri-path b)))
1145    (let ((mp (if (and ba (null? pb))
1146                  (cons '/ pr)  ; RFC3986, section 5.2.3, first bullet
1147                  (merge0 pb pr))))
1148      (remove-dot-segments mp))))
1149
1150;;  Remove dot segments, but protect leading '/' symbol
1151(define (remove-dot-segments ps)
1152  (match ps
1153         (('/ . rst)   (cons '/ (elim-dots rst)))
1154         (else         (elim-dots ps))))
1155
1156(define (elim-dots ps)
1157  (let loop ((ps ps) (trailing-slash? #f) (lst (list)))
1158    (if (null? ps) (reverse (if trailing-slash? (cons "" lst) lst))
1159        (match ps
1160               (("." . rst)
1161                (loop rst #t lst))
1162               ((".." . rst)
1163                (loop rst #t (if (pair? lst) (cdr lst) lst)))
1164               ((x . rst)
1165                (loop rst #f (cons x lst)))))))
1166
1167;;
1168;; Finding a URI relative to a base URI
1169;;
1170;; Returns a new URI which represents the relative location of the
1171;; first URI with respect to the second URI.  Thus, the values
1172;; supplied are expected to be absolute URIs, and the result returned
1173;; may be a relative URI.
1174;;
1175;; Example:
1176;;
1177;; (uri->string
1178;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
1179;;                     (uri "http://example.com/Root/sub2/name2#frag")))
1180;;    ==> "../sub1/name2#frag"
1181;;
1182
1183
1184(define (uri-relative-from uabs base)
1185  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
1186        ((ucdiff? uri-authority uabs base) (update-URI uabs 'scheme #f))
1187        ;; Special case: no relative representation for http://a/ -> http://a
1188        ;; ....unless that should be a path of ("..")
1189        ((null? (uri-path uabs))
1190         (update-URI uabs 'scheme #f))
1191        ((ucdiff? uri-path uabs base)
1192         (update-URI uabs
1193                     'scheme #f
1194                     'authority #f
1195                     'path (rel-path-from
1196                            (remove-dot-segments (uri-path uabs))
1197                            (remove-dot-segments (uri-path base)))))
1198        ((ucdiff? uri-query uabs base)
1199         (update-URI uabs
1200                     'scheme #f
1201                     'authority #f
1202                     'path (list)))
1203        (else
1204         (update-URI uabs
1205                     'scheme #f
1206                     'authority #f
1207                     'query #f
1208                     'path (list)))))
1209
1210(define (ucdiff? sel u1 u2)
1211  (let ((s1 (sel u1))
1212        (s2 (sel u2)))
1213    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
1214                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
1215               ((and (list? s1) (list? s2))       (equal? s1 s2))
1216               ((and (string? s1) (string? s2))   (string=? s1 s2))
1217               (else                              (eq? s1 s2))))))
1218
1219(define (rel-path-from pabs base)
1220  (match (list pabs base)
1221         ((pabs ()) pabs)
1222         ((() base) (list))
1223         ;; Construct a relative path segment if the paths share a
1224         ;; leading segment other than a leading '/'
1225         ((('/ . (and sa1 (ra1 . ra2))) ('/ . (and sb1 (rb1 . rb2))))
1226          (make-rel-path
1227           (if (string=? ra1 rb1)
1228               (rel-path-from1 sa1 sb1)
1229               pabs)))
1230         (else (uri-error 'rel-path-from "Both URI paths must be absolute" pabs base))))
1231
1232(define (make-rel-path x)
1233  (match x
1234         ((or ('/ . rst) ("." . rst) (".." . rst)) x)
1235         (else (cons "." x))))
1236
1237;;  rel-path-from1 strips off trailing names from the supplied paths,
1238
1239(define (rel-path-from1 pabs base)
1240  (match-let* (((na . sa)  (reverse pabs)) 
1241               ((nb . sb)  (reverse base)))
1242     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
1243       (if (null? rp)  (cond ((string=? na nb)  (list))
1244                             (else              (list na)))
1245           (append rp (list na))))))
1246
1247                         
1248;;  rel-segs-from discards any common leading segments from both paths,
1249;;  then invokes dif-segs-from to calculate a relative path from the end
1250;;  of the base path to the end of the target path.  The final name is
1251;;  handled separately, so this deals only with "directory" segments.
1252
1253(define (rel-segs-from sabs base)
1254  (cond ((and (null? sabs) (null? base))  (list))
1255        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
1256        (else (match-let (((sa1 . ra1) sabs)
1257                          ((sb1 . rb1) base))
1258                         (if (string=? sa1 sb1)
1259                             (rel-segs-from ra1 rb1)
1260                             (dif-segs-from sabs base))))))
1261
1262;;  dif-segs-from calculates a path difference from base to target,
1263;;  not including the final name at the end of the path (i.e. results
1264;;  always ends with '/')
1265;;
1266;;  This function operates under the invariant that the supplied value
1267;;  of sabs is the desired path relative to the beginning of base.
1268;;  Thus, when base is empty, the desired path has been found.
1269
1270(define (dif-segs-from sabs base)
1271  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
1272
1273
1274;; Other normalization functions
1275;;
1276;; Case normalization; cf. RFC3986 section 6.2.2.1
1277
1278(define (uri-normalize-case uri)
1279  (let* ((normalized-uri (uri-reference 
1280                          (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
1281         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
1282         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
1283    (update-uri* normalized-uri 'scheme scheme 'host host)))
1284
1285(define (normalize-pct-encoding str)
1286  (let ((str1 (uri-string->normalized-char-list str)))
1287    (and str1 (uri-char-list->string
1288               (map (lambda (c) (match c
1289                                       ((#\% h1 h2)  `(#\% ,(char-upcase h1) ,(char-upcase h2)))
1290                                       (else c)))
1291                    str1)))))
1292
1293;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
1294
1295(define (uri-normalize-path-segments uri)
1296  (update-URI uri 'path (just-segments uri)))
1297
1298(define (uri-path-absolute? uri)
1299  (let ((path (uri-path uri)))
1300   (and (pair? path) (eq? '/ (car path)))))
1301
1302(define (uri-path-relative? uri)
1303  (not (uri-path-absolute? uri)))
1304)
Note: See TracBrowser for help on using the repository browser.