source: project/release/4/uri-generic/trunk/uri-generic.scm @ 30274

Last change on this file since 30274 was 30274, checked in by sjamaan, 7 years ago

Tag uri-generic 2.39

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