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

Last change on this file since 13229 was 13229, checked in by sjamaan, 11 years ago

Rename old uri? predicate to uri-reference? and introduce a new uri? predicate that only returns #t when the object is an uri, not when it's a relative reference

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