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

Last change on this file since 36522 was 36522, checked in by sjamaan, 18 months ago

Port latest uri-generic changes to C5

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