source: project/release/3/uri-generic/trunk/uri-generic.scm @ 11993

Last change on this file since 11993 was 11993, checked in by Ivan Raikov, 12 years ago

Added string encode/decode routines and bug fix in the path-abs.

File size: 31.7 KB
Line 
1
2;;
3;; Definitions and parsing routines for Uniform Resource Identifiers (RFC 3986).
4;;
5;; Based on the Haskell URI library by  Graham Klyne <gk@ninebynine.org>.
6;;
7;; Copyright 2008 Ivan Raikov, Peter Bex.
8;;
9;;
10;;  Redistribution and use in source and binary forms, with or without
11;;  modification, are permitted provided that the following conditions
12;;  are met:
13;;
14;;  - Redistributions of source code must retain the above copyright
15;;  notice, this list of conditions and the following disclaimer.
16;;
17;;  - Redistributions in binary form must reproduce the above
18;;  copyright notice, this list of conditions and the following
19;;  disclaimer in the documentation and/or other materials provided
20;;  with the distribution.
21;;
22;;  - Neither name of the copyright holders nor the names of its
23;;  contributors may be used to endorse or promote products derived
24;;  from this software without specific prior written permission.
25;;
26;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
27;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
28;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
29;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
30;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
31;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
32;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
33;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
34;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
35;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
36;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
37;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
38;;  POSSIBILITY OF SUCH DAMAGE.
39;;
40
41(require-extension syntax-case)
42(require-extension matchable)
43(require-extension defstruct)
44(require-extension srfi-1)
45(require-extension srfi-4)
46
47(define-extension uri-generic)
48
49(declare
50 (not usual-integrations)
51 (fixnum)
52 (inline)
53 (lambda-lift)
54 (export uri-reference
55         uri? uri-auth uri-authority uri-scheme uri-path uri-query
56         uri-fragment uri-host uri-port uri-username uri-password
57         absolute-uri uri->string uri->list 
58         uri-relative-to uri-relative-from 
59         uri-decode-string uri-encode-string 
60         uri-normalize-case uri-normalize-path-segments))
61
62(cond-expand
63   (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
64   (else (use srfi-13 srfi-14)))
65
66(defstruct URI      scheme authority path query fragment)
67(defstruct URIAuth  username password host port)
68
69(define-record-printer (URI x out)
70  (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
71           (URI-scheme x)
72           (URI-authority x)
73           (URI-path x)
74           (URI-query x)
75           (URI-fragment x)))
76
77(define-record-printer (URIAuth x out)
78  (fprintf out "#(URIAuth host=~S port=~A)"
79           (URIAuth-host x)
80           (URIAuth-port x)))
81
82(define uri? URI?)
83
84(define uri-auth       URI-authority )
85(define uri-authority  URI-authority )
86(define uri-scheme     URI-scheme )
87(define uri-path       URI-path )
88(define uri-query      URI-query )
89(define uri-fragment   URI-fragment )
90
91(define (uri-host x)
92  (let ((auth (URI-authority x)))
93    (and auth (URIAuth-host auth))))
94
95(define (uri-port x)
96  (let ((auth (URI-authority x)))
97    (and auth (URIAuth-port auth))))
98
99(define (uri-username x)
100  (let ((auth (URI-authority x)))
101    (and auth (URIAuth-username auth))))
102
103(define (uri-password x)
104  (let ((auth (URI-authority x)))
105    (and auth (URIAuth-password auth))))
106
107;; Character classes
108 
109(define (hexdigit-char? c)    (char-set-contains? char-set:hex-digit c))
110
111(define (reserved-char? c)    (char-set-contains? char-set:reserved c))
112
113(define (unreserved-char? c)  (char-set-contains? char-set:unreserved c))
114
115(define (scheme-char? c)      (char-set-contains? char-set:scheme c))
116
117(define (ipv-future-char? c)  (char-set-contains? char-set:ipv-future c))
118
119(define (pct-encoded? c)      (match c ((#\% h1 h2) #t) (else #f)))
120
121
122;; Helper functions for character parsing
123 
124(define (uchar extras)
125  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
126    (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 
127                    (char-set-contains? char-set:sub-delims c) 
128                    (char-set-contains? extras-set c) ))))
129 
130;; same as uchar, but without sub-delims
131(define (schar extras)
132  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
133    (lambda (c) (or (pct-encoded? c)  (unreserved-char? c) 
134                    (char-set-contains? extras-set c) ))))
135                 
136(define (many pred?)
137  (lambda (s)
138    (let loop ((lst (list)) (rst s))
139      (cond ((null? rst)        (list (reverse lst) rst))
140            ((pred? (car rst))  (loop (cons (car rst) lst) (cdr rst)))
141            (else               (list (reverse lst) rst))))))
142
143(define (many1 pred?)
144  (lambda (s)
145    (let ((a1 (and (not (null? s)) (pred? (car s)) (car s))))
146      (and a1 (match ((many pred?) (cdr s))
147                     ((as rst)  (list (cons a1 as) rst))
148                     (else #f))))))
149
150
151(define (count-min-max m n pred?)
152  (lambda (s) 
153    (let loop ((m m) (n n) (lst (list)) (rst s))
154      (cond ((and (pair? rst) (positive? m))
155             (if (pred? (car rst))
156                 (loop (- m 1) (- n 1) (cons (car rst) lst) (cdr rst)) #f))
157            ((or (<= n 0) (null? rst))   (list (reverse lst) rst))
158            (else
159             (if (pred? (car rst))
160                 (loop 0 (- n 1) (cons (car rst) lst) (cdr rst))
161                 (list (reverse lst) rst)))))))
162
163;; Parser combinators
164
165(define (consume f) 
166  (lambda (s)
167    (let loop ((lst (list)) (rst s))
168      (match (f rst)
169             ((a rst)  (loop (cons a lst) rst))
170             (else  (list (reverse lst) rst))))))
171
172
173(define (consume-count n f)
174  (lambda (s)
175    (let loop ((n n) (lst (list)) (rst s))
176      (if (positive? n)
177          (match (or (f rst) (list #f s))
178                 ((x rst)  (and x (loop (- n 1) (cons x lst) rst))))
179          (list (reverse lst) rst)))))
180
181
182(define (consume-min-max m n f)
183  (lambda (s) 
184    (let loop ((m m) (n n) (lst (list)) (rst s))
185      (cond ((positive? m)
186             (match (f rst)
187                    ((a1 rst) (loop (- m 1) (- n 1) (cons a1 lst) rst))
188                    (else #f)))
189            ((<= n 0)   (list (reverse lst) rst))
190            (else
191             (match (f rst)
192                    ((a1 rst) (loop 0 (- n 1) (cons a1 lst) rst))
193                    (else #f)))))))
194
195;; Helper function for malformed ip address error messages
196
197(define (try-ip-literal->string s)
198  (let loop ((lst (list))  (rst s))
199    (match rst ((#\] . rst)  (uri-char-list->string (reverse lst)))
200           (()  (uri-char-list->string (reverse lst)))
201           (else (loop (cons (car rst) lst) (cdr rst))))))
202
203;; RFC 3986, section 2.1
204;;
205;; Returns a 'pct-encoded' sequence of octets.
206;;
207(define (pct-encode lst)
208  (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
209  (reverse (fold (lambda (x ax)
210                   (let ((h1 (hex-digit (quotient x 16)))
211                         (h2 (hex-digit (remainder x 16))))
212                     (cons `(#\% ,h1 ,h2)  ax)))
213                 (list) lst)))
214
215 
216;; RFC3986, section 2.2
217;;
218;; Reserved characters.
219;;
220
221(define char-set:gen-delims (string->char-set ":/?#[]@"))
222(define char-set:sub-delims (string->char-set "!$&'()*+,;="))
223
224(define char-set:reserved (char-set-union char-set:gen-delims char-set:sub-delims))
225
226;;  RFC3986, section 2.3
227;;
228;;  "Unreserved" characters.
229;;
230
231(define char-set:unreserved 
232  (char-set-union char-set:letter+digit (string->char-set "-_.~")))
233
234
235
236;;  RFC3986, section 3
237;;
238;;   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
239;;
240;;   hier-part   = "//" authority path-abempty
241;;               / path-abs
242;;               / path-rootless
243;;               / path-empty
244
245(define (uri s)
246  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
247    (match (scheme s)
248           ((us rst)
249            (match-let* (((ua up rst)   (hier-part rst))
250                         ((uq rst)      (match rst ((#\? . rst) (query rst))
251                                               (else (list #f rst))))
252                         ((uf rst)      (match rst ((#\# . rst) (fragment rst))
253                                               (else (list #f rst)))))
254                        (make-URI scheme: (string->symbol (list->string us)) authority: ua 
255                                  path: (map uri-char-list->string up) query: (and uq (filter-map query->string uq))
256                                  fragment: (and uf (uri-char-list->string uf)))))
257         (else #f))))
258
259(define (hier-part s)
260  (match s ((#\/ #\/ . rst) 
261            (match-let* (((ua rst)  (authority rst))
262                         ((up rst)  (path-abempty rst)))
263                        (list ua up rst)))
264         (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list #f s))))
265                          (list #f up rst)))))
266
267;;  RFC3986, section 3.1
268
269(define scheme0 (many scheme-char?))
270(define (scheme s)
271  (match (scheme0 s)
272         ((ss (#\: . rst))  (list ss rst))
273         (else #f)))
274
275(define char-set:scheme
276  (char-set-union char-set:letter+digit (string->char-set "+-.")))
277
278
279;;  RFC3986, section 3.2
280
281(define (authority s)
282  (match-let* (((uu uw rst)   (or (userinfo s) (list #f #f s)))
283               ((uh rst)      (host rst))
284               ((up rst)      (or (port rst) (list #f rst))))
285              (list (make-URIAuth username: (and uu (uri-char-list->string uu)) 
286                                  password: (and uw (uri-char-list->string uw))
287                                  host: (uri-char-list->string uh) 
288                                  port: (and (pair? up) (string->number (list->string up))))
289                    rst)))
290
291;;  RFC3986, section 3.2.1
292
293(define userinfo0  (many (uchar ";&=+$,")))
294
295(define (userinfo s)
296  (match (userinfo0 s)
297         ((uu ( #\: . rst))   (match (userinfo0 rst)
298                                     ((up ( #\@ . rst) ) (list uu up rst))
299                                     (else #f)))
300         ((uu ( #\@ . rst)) (list uu (list) rst))
301         (else #f)))
302
303
304
305;;  RFC3986, section 3.2.2
306
307(define (host s)  (or (ip-literal s) (ipv4-address s) (reg-name s)))
308
309(define (ip-literal s)
310  (match s ((#\[ . rst) 
311            (match (or (ipv6-address rst) (ipv-future rst))
312                   ((ua (#\] . rst))  (list ua rst))
313                   (else (error 'ip-literal "malformed ip literal" (try-ip-literal->string rst)))))
314         (else #f)))
315
316(define ipv-future0  (many ipv-future-char?))
317
318(define (ipv-future s)
319  (match s ((#\v (? hexdigit-char?) #\. . rst)  (ipv-future0 rst))
320         (else #f)))
321
322(define char-set:ipv-future 
323  (char-set-union char-set:unreserved char-set:sub-delims (char-set #\;)))
324
325
326
327;; Pv6address =                            6( h16 ":" ) ls32
328;;                   /                       "::" 5( h16 ":" ) ls32
329;;                   / [               h16 ] "::" 4( h16 ":" ) ls32
330;;                   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
331;;                   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
332;;                   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
333;;                   / [ *4( h16 ":" ) h16 ] "::"              ls32
334;;                   / [ *5( h16 ":" ) h16 ] "::"              h16
335;;                   / [ *6( h16 ":" ) h16 ] "::"
336
337;;       ls32        = ( h16 ":" h16 ) / IPv4address
338;;                   ; least-significant 32 bits of address
339
340;;       h16         = 1*4HEXDIG
341;;                   ; 16 bits of address represented in hexadecimal
342
343
344(define (ipv6-address s)
345  (or (match (u6-h4c s) ;; 6( h16 ":" ) ls32
346
347             ((a2 rst)  (match (ls32 rst)
348                               ((a3 rst)  (list (append (concatenate a2) a3) rst))
349                               (else #f)))
350             (else #f))
351      (match s          ;; "::" 5( h16 ":" ) ls32
352             ((#\: #\: . rst) 
353              (match (u5-h4c rst)
354                     ((a2 rst)  (match (ls32 rst)
355                                       ((a3 rst)  (list (append (list #\: #\:) (concatenate a2) a3) rst))
356                                       (else #f)))))
357             (else #f))
358      (match (u_opt_n_h4c_h4 0 s)
359             ((a1 rst) (match rst
360                              ((#\: #\: . rst) 
361                               (match (u4-h4c rst)
362                                      ((a2 rst)  (match (ls32 rst)
363                                                        ((a3 rst) 
364                                                         (list (append (concatenate a1) (list #\: #\:) 
365                                                                       (concatenate a2) a3) rst))
366                                                        (else #f)))
367                                      (else #f)
368                                      ))
369                              (else #f)))
370              (else #f))
371      (match (u_opt_n_h4c_h4 1 s)
372             ((a1 rst) 
373                      (match rst       
374                              ((#\: #\: . rst) 
375                               (match (u3-h4c rst)
376                                      ((a2 rst)  (match (ls32 rst)
377                                                        ((a3 rst) 
378                                                         (list (append (concatenate a1) (list #\: #\:) 
379                                                                       (concatenate a2) a3) rst))
380                                                        (else #f)))
381                                      (else #f)
382                                      ))
383                              (else #f)))
384              (else #f))
385      (match (u_opt_n_h4c_h4 2 s)
386             ((a1 rst) (match rst       
387                              ((#\: #\: . rst) 
388                               (match (u2-h4c rst)
389                                      ((a2 rst)  (match (ls32 rst)
390                                                        ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
391                                                                                 (concatenate a2) a3) rst))
392                                                        (else #f)))
393                                      (else #f)
394                                      ))
395                              (else #f)))
396              (else #f))
397      (match (u_opt_n_h4c_h4 3 s)
398             ((a1 rst) (match rst       
399                              ((#\: #\: . rst) 
400                               (match (h4c rst)
401                                      ((a2 rst)  (match (ls32 rst)
402                                                        ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
403                                                                                 (concatenate a2) a3) rst))
404                                                        (else #f)))
405                                      (else #f)
406                                      ))
407                              (else #f)))
408              (else #f))
409      (match (u_opt_n_h4c_h4 4 s)
410             ((a1 rst) (match rst       
411                              ((#\: #\: . rst) 
412                               (match (ls32 rst)
413                                      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
414                                      (else #f)))
415                              (else #f)))
416              (else #f))
417      (match (u_opt_n_h4c_h4 5 s)
418             ((a1 rst) (match rst       
419                              ((#\: #\: . rst) 
420                               (match (h4 rst)
421                                      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
422                                      (else #f)))
423                              (else #f)))
424              (else #f))
425      (match (u_opt_n_h4c_h4 6 s)
426             ((a1 rst) (match rst       
427                              ((#\: #\: . rst) 
428                               (list (append (concatenate a1) (list #\: #\:)) rst))
429                              (else #f)))
430              (else #f))
431      (error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))
432
433
434
435(define (u_opt_n_h4c_h4 n s)
436  (match ((consume-min-max 0 n h4c) s)
437         ((a1 rst)  (match (h4 rst)
438                           ((a2 rst) (list (append a1 (list a2)) rst))
439                           (else #f)))
440         (else #f)))
441
442(define (ls32 s)
443  (match (h4c s)
444         ((a1 rst) (match (h4 rst)
445                          ((a2 rst)  (list (append a1 a2) rst))
446                          (else (ipv4-address s))))
447         (else (ipv4-address s))))
448
449(define (h4c s)
450  (match (h4 s)
451         ((a1 (#\: (and r1 (not #\:)) . rst))
452          (list (append a1 (list #\:)) (cons r1 rst)))
453         (else #f)))
454
455(define u6-h4c (consume-count 6 h4c))
456(define u5-h4c (consume-count 5 h4c))
457(define u4-h4c (consume-count 4 h4c))
458(define u3-h4c (consume-count 3 h4c))
459(define u2-h4c (consume-count 2 h4c))
460
461(define h4 (count-min-max 1 4 hexdigit-char?))
462
463(define (ipv4-address s)
464  (match (dec-octet s)
465         ((a1 (#\. rst)) 
466          (match (dec-octet rst)
467                 ((a2 (#\. rst)) 
468                  (match (dec-octet rst)
469                         ((a3 (#\. rst)) 
470                          (match (dec-octet rst)
471                                 ((a4 rst)  (list (append a1 #\. a2 #\. a3 #\. a4) rst))
472                                 (else #f)))
473                         (else #f)))
474                 (else #f)))
475         (else #f)))
476
477(define (dec-char->num c)
478  (case c ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4) ((#\5) 5) 
479         ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
480                 
481(define (ipv4-octet? lst)
482  (let loop ((n (reverse (map dec-char->num lst))) (i 1) (ax 0))
483    (if (null? n) (and (>= ax 0) (<= ax 255))
484        (loop (cdr n) (* i 10) (+ ax (* i (car n)))))))
485
486(define (dec-octet s)
487  (match ((count-min-max 1 3 char-numeric?) s)
488         (((and a1 (? ipv4-octet?)) rst)  (list a1 rst))
489         (else #f)))
490
491(define reg-name
492  (count-min-max 0 255 (lambda (c) (or (unreserved-char? c) 
493                                       (pct-encoded? c) 
494                                       (char-set-contains? char-set:sub-delims c) ))))
495
496;;  RFC3986, section 3.2.3
497
498(define port0 (many char-numeric?))
499
500(define (port s)
501  (match s ((#\: . rst)  (port0 rst))
502         (else #f)))
503
504
505;;
506;;  RFC3986, section 3.3
507;;
508;;   path          = path-abempty    ; begins with "/" or is empty
509;;                 / path-abs        ; begins with "/" but not "//"
510;;                 / path-noscheme   ; begins with a non-colon segment
511;;                 / path-rootless   ; begins with a segment
512;;                 / path-empty      ; zero characters
513;;
514;;   path-abempty  = *( "/" segment )
515;;   path-abs      = "/" [ segment-nz *( "/" segment ) ]
516;;   path-noscheme = segment-nzc *( "/" segment )
517;;   path-rootless = segment-nz *( "/" segment )
518;;   path-empty    = 0<pchar>
519;;
520;;   segment       = *pchar
521;;   segment-nz    = 1*pchar
522;;   segment-nzc   = 1*( unreserved / pct-encoded / sub-delims / "@" )
523;;
524;;   pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
525
526(define (path s)
527  (or (path-abempty s)  (path-abs s) (path-noscheme s) 
528      (path-rootless s) (list (list) s)))
529
530 
531(define (slash-segment s)
532  (match s
533         ((#\/ . rst)  (match (segment rst)
534                              ((ss rst)  (list (cons #\/ ss) rst))
535                              (else #f)))
536         (else  #f)))
537
538(define pchar (uchar ":@"))
539
540(define segment (many pchar))
541
542(define segment-nz (many1 pchar))
543
544(define segment-nzc (many1 (uchar "@")))
545
546(define path-abempty (consume slash-segment))
547
548(define (path-abs s)
549  (match s
550         ((#\/)          (list (list (list #\/))  (list)))
551         ((#\/ . rst)    (match (path-rootless rst)
552                                ((() rst)  (list  (list (list #\/))  rst))
553                                ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
554                                (else #f)))
555         (else #f)))
556
557(define (path-noscheme s)
558  (match (segment-nzc s)
559         ((s1 rst)  (match (path-abempty rst)
560                           ((ss rst) (list (cons s1 ss) rst))
561                           (else (list (list s1) rst))))
562         (else #f)))
563
564(define (path-rootless s)
565  (match (segment-nz s)
566         ((s1 rst)  (match (path-abempty rst)
567                           ((ss rst) (list (cons s1 ss) rst))
568                           (else #f)))
569         (else #f)))
570
571;;  RFC3986, section 3.4
572
573
574(define query0  (many (schar ":@/?!$'()*+,;=")))
575(define (query1 s)
576  (match s ((#\& . rst) (query0 rst))
577         (else #f)))
578
579(define (query s)
580  (match (query0 s)
581         ((q1 rst)   
582                     (match ((consume query1) rst)
583                            ((qs rst)  (list (cons q1 qs) rst))
584                            (else (list (list q1) rst))))
585         (else #f)))
586
587(define query-part (many (schar ":@/?!$'()*+,;")))
588
589(define (query->string s)
590  (match (query-part s)
591         ((p1 (#\= . rst))  (match (query-part rst)
592                                   ((p2 _) `(,(uri-char-list->string p1) . ,(uri-char-list->string p2)))
593                                   (else #f)))
594         ((p1 ())   `(,(uri-char-list->string p1)))
595         (else #f)))
596 
597
598;;  RFC3986, section 3.5
599
600
601(define fragment0  (many (uchar ":@/?")))
602(define (fragment s)
603  (match (fragment0 s)
604         ((ss rst)  (list ss rst))
605         (else #f)))
606
607;;  Reference, Relative and Absolute URI forms
608;;
609;;  RFC3986, section 4.1
610
611(define (uri-reference s)
612  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
613    (or (uri s) (relative-ref s))))
614
615;;  RFC3986, section 4.2
616;;
617;;   relative-URI  = relative-part [ "?" query ] [ "#" fragment ]
618;;
619;;   relative-part = "//" authority path-abempty
620;;                 / path-abs
621;;                 / path-noscheme
622;;                 / path-empty
623
624(define (relative-ref s)
625  (and (not (scheme s))
626       (match-let* (((ua up rst)  (relative-part s))
627                    ((uq rst)     (match rst ((#\? . rst) (query rst))
628                                         (else (list #f rst))))
629                    ((uf rst)     (match rst ((#\# . rst) (fragment rst))
630                                         (else (list #f rst)))))
631                   (make-URI scheme: #f authority: ua path: (map uri-char-list->string up) 
632                             query: (and uq (filter-map query->string uq))
633                             fragment: (and uf (uri-char-list->string uf))))))
634
635(define (relative-part s)
636  (match s
637         ((#\/ #\/ . rst)
638          (match-let* (((ua rst)  (authority rst))
639                       ((up rst)  (path-abempty rst)))
640                      (list ua up rst)))
641         (else (match-let* (((up rst)  (or (path-abs s) (path-noscheme s) (list (list) s))))
642                           (list #f up rst))))) 
643
644
645
646;;  RFC3986, section 4.3
647
648(define (absolute-uri s)
649  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
650    (match (scheme s)
651           ((us rst) 
652            (match-let* (((ua up rst)  (hier-part rst))
653                         ((uq rst)     (match rst ((#\? . rst)  (query rst))
654                                              (else (list #f rst)))))
655                        (make-URI scheme: (string->symbol (list->string us)) authority: ua 
656                                  path: (map uri-char-list->string up) query: (and uq (filter-map query->string uq))
657                                  fragment: #f)))
658           (error 'absolute-uri "no scheme found in URI string"))))
659                     
660
661;; Turns a URI into a string.
662;;
663;; Uses a supplied function to map the userinfo part of the URI.
664;;
665
666(define (uri->string uri . rest)
667   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
668    (match uri
669           (($ URI scheme authority path query fragment)
670            (string-append
671             ((lambda (x) (or (and x (string-append (->string x) ":")) ""))  scheme)
672             (if authority (string-append (uri-auth->string authority userinfomap) 
673                                          (if (or (null? path) (not (string-prefix? "/" (car path)))) "/" ""))
674                 "")
675             (string-concatenate path)
676             (if query (string-concatenate (cons "?" (intersperse query "&"))) "")
677             (if fragment (string-append  "#" fragment) "")))
678           (else #f))))
679
680(define (uri-auth->string uri-auth userinfomap)
681  (match uri-auth
682         (($ URIAuth username password host port)
683          (string-append "//" (if (and username password)
684                                  ((lambda (x) (or (and x (string-append x "@")) ""))
685                                   (userinfomap username password)) "")
686                         host ((lambda (x) (or (and x (string-append ":" (->string x))) ""))
687                               port)))
688         (else #f)))
689                         
690; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
691
692(define (uri->list uri . rest)
693  (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
694    (match uri
695           (($ URI scheme authority path query fragment)
696            `(,scheme (,(uri-auth->list authority userinfomap) ,path ,query) ,fragment))
697           (else #f))))
698
699(define (uri-auth->list uri-auth userinfomap)
700  (match uri-auth
701         (($ URIAuth username password regname port)
702          `(,(if (and username password) (userinfomap username password) #f) ,regname ,port ))
703         (else #f)))
704                         
705
706;;  Percent encoding and decoding
707
708(define (char-list-encode p enc str)
709  (reverse
710   (fold (lambda (c ax) 
711           (if (p c) (let* ((os (enc c)) 
712                            (cs (map pct-encode os)))
713                       (append (concatenate (reverse cs)) ax))
714               (cons c ax)))
715         (list) str)))
716
717(define (integer->octets i)
718  (let loop ((i i) (lst (list)))
719    (if (zero? i) lst
720        (loop (quotient i 256) (cons (modulo i 256) lst)))))
721
722
723(define (uri-encode-string str)
724  (let ((clst (uri-string->char-list str)))
725    (uri-char-list->string 
726     (char-list-encode reserved-char? (compose integer->octets char->integer) clst))))
727
728
729(define (octets->integer lst)
730  (let loop ((i 0) (m 1) (lst (reverse lst)))
731    (if (null? lst) i
732        (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
733
734(define (pct-decode c)
735  (match c
736         ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
737         (else c)))
738
739(define (hex-digit-char->integer c)
740  (case c
741         ((#\1)  1)
742         ((#\2)  2)
743         ((#\3)  3)
744         ((#\4)  4)
745         ((#\5)  5)
746         ((#\6)  6)
747         ((#\7)  7)
748         ((#\8)  8)
749         ((#\9)  9)
750         ((#\A)  10)
751         ((#\B)  11)
752         ((#\C)  12)
753         ((#\D)  13)
754         ((#\E)  14)
755         ((#\F)  15)
756         (else  (error 'hex-digit-char->integer "invalid hex char " c))))
757
758(define (octet-decode h1 h2)
759  (+ (* 16 (hex-digit-char->integer h1)) (hex-digit-char->integer h2)))
760
761(define (uri-decode-string str)
762  (let loop ((clst (uri-string->char-list str)) (p (list))  (nlst (list)))
763    (if (null? clst)
764        (uri-char-list->string (reverse nlst))
765        (match (car clst)
766               ((and c (? char?)) 
767                (if (null? p) (loop (cdr clst) p (cons c nlst))
768                    (let ((pc (integer->char (octets->integer (reverse p)))))
769                      (loop (cdr clst) (list) (cons* c pc nlst)))))
770               ((#\% h1 h2) 
771                (loop (cdr clst) (cons (octet-decode h1 h2) p) nlst))
772               (else (error 'uri-decode-string "invalid URI string " str))))))
773   
774(define (uri-string->normalized-char-list str)
775  (let ((clst (uri-string->char-list str)))
776    (map (lambda (c) (if (pct-encoded? c) 
777                         (let ((e (pct-decode c)))
778                           (if (unreserved-char? e) e c)) c))
779         clst)))
780                         
781
782
783;; Convert a URI character list to a string
784
785(define (uri-char-list->string s)
786  (list->string
787   (reverse
788    (fold (lambda (x ax)
789                  (cond ((char? x) (cons x ax))
790                        ((list? x) (append (reverse x) ax)))) (list) s))))
791   
792;; Convert a string to a URI character list
793
794(define (uri-string->char-list s)
795  (let loop ((cs (list)) (lst (string->list s)))
796    (if (null? lst) (reverse cs)
797        (match lst
798               ((#\% h1 h2 . rst)  (loop (cons (list #\% h1 h2) cs) rst))
799               (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
800   
801;;
802;;  Resolving a relative URI relative to a base URI
803;;
804;;  Returns a new URI which represents the value of the first URI
805;;  interpreted as relative to the second URI.
806;;
807;;  For example:
808;;
809;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
810;;         => "http://bar.org/foo"
811;;
812;;  (uri->string (non-strict-relative-to (uri "http:foo") (uri "http://bar.org/")) )
813;;         => "http://bar.org/foo"
814;;
815;;  Algorithm from RFC3986, section 5.2.2
816;;
817
818(define (uri-relative-to ref base)
819  (and (uri? ref) (uri? base)
820       (cond ((uri-scheme ref)      (just-segments ref))
821             ((uri-authority ref)   (let ((x (just-segments ref)))
822                                      (URI-scheme-set! x (uri-scheme base))
823                                      x))
824
825             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
826              (lambda (ref-path)
827                (if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
828                    (let ((x (just-segments ref)))
829                      (URI-scheme-set! x (uri-scheme base))
830                      (URI-authority-set! x (uri-auth base))
831                      x)
832                    (let ((x (udup ref)))
833                      (URI-scheme-set! x (uri-scheme base))
834                      (URI-authority-set! x (uri-auth base))
835                      (URI-path-set! x (merge-paths base x))
836                      (just-segments x)))))
837
838             ((uri-query ref)       (let ((x (udup ref)))
839                                      (URI-scheme-set! x (uri-scheme base))
840                                      (URI-authority-set! x (uri-auth base))
841                                      (URI-path-set! x (list "/"))
842                                      (URI-path-set! x (merge-paths base x))
843                                      (just-segments x)))
844
845             (else                  (let ((x (just-segments ref)))
846                                      (URI-scheme-set! x (uri-scheme base))
847                                      (URI-authority-set! x (uri-auth base))
848                                      (URI-path-set! x (uri-path base))
849                                      (URI-query-set! x (uri-query base))
850                                      x)))))
851
852(define (just-segments u)
853  (let ((p (remove-dot-segments (uri-path u))))
854    (make-URI scheme: (uri-scheme u) authority: (uri-auth u) path: p
855              query: (uri-query u) fragment: (uri-fragment u))))
856
857(define (merge0 pb pr)
858  (let* ((rpb  (reverse pb))
859         (pb1  (reverse (if (not (string=? (car rpb) "/")) (cdr rpb) rpb)))
860         (pr1  (or (and (pair? pr) (not (string=? ".." (car pr))) (not (string=? "." (car pr)))
861                        (not (string-prefix? "/" (car pr))) 
862                        (cons (string-append "/" (car pr)) (cdr pr)))
863                   pr)))
864    (append pb1 pr1)))
865
866(define (merge-paths b r)
867  (let ((ba (uri-authority b))
868        (pb (uri-path b))
869        (pr (uri-path r)))
870    (let ((mp  (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
871      mp)))
872
873(define (uri-non-strict-relative-to ref base)
874  (let ((rs (uri-scheme ref))
875        (rb (uri-scheme base)))
876    (let ((ref1 (make-URI scheme: (if (eq? rs rb) #f (uri-scheme ref))
877                          authority: (uri-auth ref) path: (uri-path ref)
878                          query: (uri-query ref) fragment: (uri-fragment ref))))
879      (uri-relative-to ref1 base))))
880
881
882;;  Remove dot segments, but protect leading '/' character
883
884(define (remove-dot-segments ps)
885  (match ps (("/" . rst)   (cons "/" (elim-dots rst)))
886         (else             (elim-dots ps))))
887
888(define (elim-dots ps)
889  (let loop ((ps ps) (lst (list)))
890    (if (null? ps) (reverse lst)
891        (match ps
892               (((or "." "/."))
893                (loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
894               (((or "." "/.") . rst)
895                (loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
896               (((or ".." "/.."))         
897                (loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
898               (((or ".." "/..") . rst)
899                (loop rst (if (pair? lst) (cdr lst) lst)))
900               ((x . rst)       (loop rst (cons x lst)))))))
901
902;;
903;; Finding a URI relative to a base URI
904;;
905;; Returns a new URI which represents the relative location of the
906;; first URI with respect to the second URI.  Thus, the values
907;; supplied are expected to be absolute URIs, and the result returned
908;; may be a relative URI.
909;;
910;; Example:
911;;
912;; (uri->string
913;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
914;;                     (uri "http://example.com/Root/sub2/name2#frag")))
915;;    ==> "../sub1/name2#frag"
916;;
917
918
919(define (uri-relative-from uabs base)
920  (cond ((ucdiff? uri-scheme uabs base)      (udup uabs))
921        ((ucdiff? uri-authority uabs base)   (let ((x (udup uabs)))
922                                               (URI-scheme-set! x #f)
923                                               x))
924        ((ucdiff? uri-path uabs base)       
925         (let ((x    (udup uabs))
926               (path (rel-path-from (remove-body-dot-segments (uri-path uabs))
927                                    (remove-body-dot-segments (uri-path base)))))
928           (URI-scheme-set! x #f)
929           (URI-authority-set! x #f)
930           (URI-path-set! x path)
931           x))
932        ((ucdiff? uri-query uabs base) 
933         (let ((x (udup uabs)))
934           (URI-scheme-set! x #f)
935           (URI-authority-set! x #f)
936           (URI-path-set! x (list))
937           x))
938        (else                            
939         (let ((x (udup uabs)))
940           (URI-scheme-set! x #f)
941           (URI-authority-set! x #f)
942           (URI-query-set! x #f)
943           (URI-path-set! x (list))
944           x))))
945
946
947(define (udup u)
948  (make-URI scheme: (uri-scheme u) authority: (uri-auth u) path: (uri-path u)
949            query: (uri-query u) fragment: (uri-fragment u)))
950
951(define (ucdiff? sel u1 u2)
952  (let ((s1 (sel u1))
953        (s2 (sel u2)))
954    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
955                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
956               ((and (list? s1) (list? s2))       (every string=? s1 s2))
957               ((and (string? s1) (string? s2))   (string=? s1 s2))
958               (else                              (eq? s1 s2))))))
959
960(define (remove-body-dot-segments p)
961  (or (and (pair? p)
962           (let ((r (reverse p)))
963             (reverse (cons (car r) (remove-dot-segments (cdr r))))))
964      p))
965
966(define (rel-path-from pabs base)
967  (cond  ((null? pabs)  (list "/"))
968         ((null? base)  pabs)
969         ;; Construct a relative path segment if the paths share a
970         ;; leading segment other than a leading '/'
971         (else  (match (list pabs base)
972                       (((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
973                        (if (string=? sa1 sb1)
974                            (make-rel-path
975                             (if (string=? "/" sa1)
976                                 (if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
977                                 (rel-path-from1 ra1 rb1)))
978                            pabs))
979                       (((sa1) (sb1 . rb1))
980                        (if (string=? sa1 sb1)  (rel-segs-from (list) rb1)
981                            pabs))))))
982
983(define (make-rel-path x)
984  (if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))
985
986;;  rel-path-from1 strips off trailing names from the supplied paths,
987
988(define (rel-path-from1 pabs base)
989  (match-let* (((na . sa)  (reverse pabs)) 
990               ((nb . sb)  (reverse base)))
991     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
992       (if (null? rp)  (cond ((string=? na nb)  (list))
993                             ((protect? na)     (list (string-append "./" na)))
994                             (else              (list na)))
995           (append rp (list na))))))
996
997                         
998(define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
999             
1000
1001
1002;;  rel-segs-from discards any common leading segments from both paths,
1003;;  then invokes dif-segs-from to calculate a relative path from the end
1004;;  of the base path to the end of the target path.  The final name is
1005;;  handled separately, so this deals only with "directory" segments.
1006
1007(define (rel-segs-from sabs base)
1008  (cond ((and (null? sabs) (null? base))  (list))
1009        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
1010        (else (match-let (((sa1 . ra1) sabs)
1011                          ((sb1 . rb1) base))
1012                         (if (string=? sa1 sb1)
1013                             (rel-segs-from ra1 rb1)
1014                             (dif-segs-from sabs base))))))
1015
1016;;  dif-segs-from calculates a path difference from base to target,
1017;;  not including the final name at the end of the path (i.e. results
1018;;  always ends with '/')
1019;;
1020;;  This function operates under the invariant that the supplied value
1021;;  of sabs is the desired path relative to the beginning of base.
1022;;  Thus, when base is empty, the desired path has been found.
1023
1024(define (dif-segs-from sabs base)
1025  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
1026
1027
1028
1029;; Other normalization functions
1030;;
1031;; Case normalization; cf. RFC3986 section 6.2.2.1
1032;; NOTE:  authority case normalization is not performed
1033
1034(define (uri-normalize-case uri)
1035  (let ((u1      (udup uri))
1036        (scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
1037        (path    (map (lambda (c) (match c (('% h1 h2)  `(% ,(char-upcase h1) ,(char-upcase h2)))
1038                                         (else c))) (uri-path uri))))
1039    (URI-scheme-set! u1 scheme)
1040    (URI-path-set! u1 path)
1041    u1))
1042
1043
1044;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
1045
1046(define (uri-normalize-path-segments uri)
1047  (let ((u1      (udup uri))
1048        (path    (remove-dot-segments (uri-path uri))))
1049    (URI-path-set! u1 path)
1050    u1))
Note: See TracBrowser for help on using the repository browser.