source: project/release/4/uri-generic/branches/utf8/uri-generic.scm @ 28086

Last change on this file since 28086 was 28086, checked in by Ivan Raikov, 8 years ago

uri-generic: created a branch for experimentation with utf8

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