source: project/release/4/uri-generic/trunk/alternatives/uri-generic.matchable.scm @ 33643

Last change on this file since 33643 was 33643, checked in by sjamaan, 2 years ago

Update matchable implementation by copying current base implementation back to alternatives

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