source: project/release/5/uri-generic/trunk/alternatives/uri-generic.packrat.scm

Last change on this file was 36564, checked in by sjamaan, 10 days ago

uri-generic: Port packrat parser to CHICKEN 5 and fix several bugs in it

File size: 36.6 KB
Line 
1;; uri-generic version based on packrat
2
3(module uri-generic
4  (uri-reference make-uri update-uri update-authority
5   uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
6   uri-fragment uri-host uri-ipv6-host? uri-port
7   uri-username uri-password
8   authority? authority-host authority-ipv6-host? authority-port
9   authority-username authority-password
10   
11   uri? absolute-uri absolute-uri? uri->string uri->list
12   relative-ref? uri-relative-to uri-relative-from 
13   uri-decode-string uri-encode-string 
14   uri-normalize-case uri-normalize-path-segments
15   uri-path-absolute? uri-path-relative?
16
17   char-set:gen-delims char-set:sub-delims
18   char-set:uri-reserved char-set:uri-unreserved)
19
20(import scheme (chicken base) (chicken string) (chicken port)
21        (chicken format) (chicken irregex) (chicken condition)
22        srfi-14 packrat)
23
24(define uri-error error)
25
26(cond-expand
27 (chicken)
28 (else
29  (define (->string obj)
30    (let ((s (open-output-string)))
31      (display obj s)
32      (let ((result (get-output-string s)))
33        (close-output-port s)
34        result)))
35  ))
36
37
38;; What to do with these?
39;; #;(cond-expand
40;;    (utf8-strings (use utf8-srfi-14))
41;;    (else (use srfi-14)))
42
43(define-record-type <URI>
44  (make-URI scheme authority path query fragment)
45  URI?
46  (scheme URI-scheme URI-scheme-set!)
47  (authority URI-authority URI-authority-set!)
48  (path URI-path URI-path-set!)
49  (query URI-query URI-query-set!)
50  (fragment URI-fragment URI-fragment-set!))
51
52(define-record-type <URIAuth>
53  (make-URIAuth username password host ipv6-host? port)
54  URIAuth?
55  (username URIAuth-username URIAuth-username-set!)
56  (password URIAuth-password URIAuth-password-set!)
57  (host URIAuth-host URIAuth-host-set!)
58  (ipv6-host? URIAuth-ipv6-host? URIAuth-ipv6-host?-set!)
59  (port URIAuth-port URIAuth-port-set!))
60
61
62(cond-expand
63 (chicken
64  (define-record-printer (<URI> x out)
65    (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
66             (URI-scheme x)
67             (URI-authority x)
68             (URI-path x)
69             (URI-query x)
70             (URI-fragment x)))
71 
72  (define-record-printer (<URIAuth> x out)
73    (fprintf out "#(URIAuth host=~S~A port=~A)"
74             (URIAuth-host x)
75             (if (URIAuth-ipv6-host? x) "(ipv6)" "")
76             (URIAuth-port x))))
77 (else))
78
79
80(define (update-URI uri . args)
81  (let loop ((args args)
82             (new-scheme (URI-scheme uri))
83             (new-authority (URI-authority uri))
84             (new-path (URI-path uri))
85             (new-query (URI-query uri))
86             (new-fragment (URI-fragment uri)))
87    (cond ((null? args)
88           (make-URI new-scheme new-authority new-path new-query new-fragment))
89          ((null? (cdr args))
90           (uri-error "malformed arguments to update-URI"))
91          (else
92           (let ((key (car args))
93                 (value (cadr args)))
94             (loop (cddr args)
95                   (if (eq? key 'scheme) value new-scheme)
96                   (if (eq? key 'authority) value new-authority)
97                   (if (eq? key 'path) value new-path)
98                   (if (eq? key 'query) value new-query)
99                   (if (eq? key 'fragment) value new-fragment)))))))
100
101
102(define (is-ipv6-host? h) (and (substring-index ":" h) #t))
103
104(define (update-URIAuth uri-auth . args)
105  (let loop ((args args)
106             (new-username (URIAuth-username uri-auth))
107             (new-password (URIAuth-password uri-auth))
108             (new-host (URIAuth-host uri-auth))
109             (new-ipv6-host? (URIAuth-ipv6-host? uri-auth))
110             (new-port (URIAuth-port uri-auth)))
111    (cond ((null? args)
112           (make-URIAuth new-username new-password
113                         new-host new-ipv6-host? new-port))
114          ((null? (cdr args))
115           (uri-error "malformed arguments to update-URIAuth"))
116          (else
117           (let ((key (car args))
118                 (value (cadr args)))
119             (loop (cddr args)
120                   (if (eq? key 'username) value new-username)
121                   (if (eq? key 'password) value new-password)
122                   (if (eq? key 'host) value new-host)
123                   (if (eq? key 'host)
124                       (and value (is-ipv6-host? value))
125                       new-ipv6-host?)
126                   (if (eq? key 'port) value new-port)))))))
127
128
129(define uri-reference? URI?)
130
131(define uri-auth       URI-authority )
132(define uri-authority  URI-authority )
133(define uri-scheme     URI-scheme )
134(define uri-path       URI-path )
135(define uri-query      URI-query )
136(define uri-fragment   URI-fragment )
137
138(define (uri-host x)
139  (let ((auth (URI-authority x)))
140    (and auth (URIAuth-host auth))))
141
142(define (uri-ipv6-host? x)
143  (let ((auth (URI-authority x)))
144    (and auth (URIAuth-ipv6-host? auth))))
145
146(define (uri-port x)
147  (let ((auth (URI-authority x)))
148    (and auth (URIAuth-port auth))))
149
150(define (uri-username x)
151  (let ((auth (URI-authority x)))
152    (and auth (URIAuth-username auth))))
153
154(define (uri-password x)
155  (let ((auth (URI-authority x)))
156    (and auth (URIAuth-password auth))))
157
158(define authority? URIAuth?)
159(define authority-host URIAuth-host)
160(define authority-ipv6-host? URIAuth-ipv6-host?)
161(define authority-port URIAuth-port)
162(define authority-username URIAuth-username)
163(define authority-password URIAuth-password)
164
165(define update-authority update-URIAuth)
166
167(define update-uri*
168  (let ((unset (list 'unset)))
169    (lambda (uri . args)
170      (let loop ((key/values args)
171                 (scheme (URI-scheme uri))
172                 (path (URI-path uri))
173                 (query (URI-query uri))
174                 (fragment (URI-fragment uri))
175                 (auth unset)
176                 (authority unset))
177        (cond
178         ((null? key/values)
179        (let* ((base-auth (or
180                           (cond
181                            ((not (eq? unset auth)) auth)
182                            ((not (eq? unset authority)) authority)
183                            (else (URI-authority uri)))
184                             (make-URIAuth #f #f #f #f #f)))
185                 (updated-auth (apply update-authority base-auth args))
186                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f #f)
187                                                  updated-auth)
188                               #f
189                               updated-auth)))
190            (make-URI scheme final-auth path query fragment)))
191         ((null? (cdr key/values))
192          (uri-error "malformed arguments to update-uri"))
193         ((not (memq (car key/values)
194                     '(scheme authority path query fragment
195                              username password host port)))
196          (uri-error "unknown argument to update-uri" (car key/values)))
197         (else
198          (let ((key (car key/values))
199                (value (cadr key/values)))
200            (loop (cddr key/values)
201                  (if (eq? key 'scheme) value scheme)
202                  (if (eq? key 'path) value path)
203                  (if (eq? key 'query) value query)
204                  (if (eq? key 'fragment) value fragment)
205                  (if (eq? key 'auth) value auth)
206                  (if (eq? key 'authority) value authority)))))))))
207
208
209(cond-expand
210
211 (chicken
212  (define update-uri
213    (let ((unset (list 'unset)))
214      (lambda (uri . key/values)
215        (apply
216         (lambda (#!key
217                  (scheme (URI-scheme uri)) (path (URI-path uri))
218                  (query (URI-query uri)) (fragment (URI-fragment uri))
219                  (auth unset) (authority unset)
220                  (username unset) (password unset)
221                  (host unset) (port unset))
222           (let* ((args (list 'scheme scheme
223                              'path path
224                              'query query
225                              'fragment fragment))
226                  (args (if (not (eq? auth unset))
227                            (append args (list 'auth auth)) args))
228                  (args (if (not (eq? authority unset))
229                            (append args (list 'authority authority)) args))
230                  (args (if (not (eq? username unset))
231                            (append args (list 'username username)) args))
232                  (args (if (not (eq? password unset))
233                            (append args (list 'password password)) args))
234                  (args (if (not (eq? host unset))
235                            (append args (list 'host host)) args))
236                  (args (if (not (eq? port unset))
237                            (append args (list 'port port)) args))
238                  )
239             (apply update-uri* uri args)))
240         key/values)))))
241
242 (else
243  (define update-uri update-uri*)))
244
245
246(define (make-uri* . key/values)
247  (apply update-uri* (make-URI #f #f '() #f #f) key/values))
248
249(cond-expand
250
251 (chicken
252  (define (make-uri . key/values)
253    (apply update-uri (make-URI #f #f '() #f #f) key/values)))
254 
255 (else
256  (define make-uri make-uri*)))
257
258
259(define (uri-equal? a b)
260  (or (and (not a) (not b))
261      (and (equal? (URI-scheme a) (URI-scheme b))
262           (uri-auth-equal? (URI-authority a) (URI-authority b))
263           (equal? (URI-path a) (URI-path b))
264           (equal? (URI-query a) (URI-query b))
265           (equal? (URI-fragment a) (URI-fragment b)))))
266
267
268(define (uri-auth-equal? a b)
269  (or (and (not a) (not b))
270      (and
271       (equal? (URIAuth-username a) (URIAuth-username b))
272       (equal? (URIAuth-password a) (URIAuth-password b))
273       (equal? (URIAuth-host a) (URIAuth-host b))
274       (equal? (URIAuth-port a) (URIAuth-port b)))))
275
276
277(define (uri? u)
278  (and (uri-reference? u) (uri-scheme u) #t))
279
280(define (relative-ref? u)
281  (and (uri-reference? u) (not (uri-scheme u))))
282
283(define (absolute-uri? u)
284  (and (uri-reference? u) (not (relative-ref? u)) (not (uri-fragment u))))
285
286;; RFC3986, section 2.2
287;;
288;; Reserved characters.
289;;
290
291(define char-set:gen-delims (string->char-set ":/?#[]@"))
292(define char-set:sub-delims (string->char-set "!$&'()*+,;="))
293(define char-set:uri-reserved (char-set-union char-set:gen-delims char-set:sub-delims))
294
295(define (char-set-parser char-set)
296  (lambda (results)
297    (let ((ch (parse-results-token-value results)))
298      (if (and ch (char-set-contains? char-set ch))
299          (make-result ch (parse-results-next results))
300          (make-expected-result (parse-results-position results) char-set)))))
301
302(define sub-delims (char-set-parser char-set:sub-delims))
303
304;;  RFC3986, section 2.3
305;;
306;;  "Unreserved" characters.
307;;
308
309;; The SRFI-14 library uses Latin1, and its definition of "letter"
310;; includes accented letters with high bit. This wreaks havoc with
311;; UTF-8 URIs.  Besides, the RFC only discusses ASCII letters anyway.
312(define char-set:ascii-letter
313  (string->char-set
314   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
315
316(define char-set:ascii-letter+digit
317  (char-set-union char-set:ascii-letter char-set:digit))
318
319(define char-set:uri-unreserved 
320  (char-set-union char-set:ascii-letter+digit (string->char-set "-_.~")))
321
322(define unreserved (char-set-parser char-set:uri-unreserved))
323
324(define alpha (char-set-parser char-set:ascii-letter))
325
326;; Turns a URI into a string.
327;;
328;; Uses a supplied function to map the userinfo part of the URI.
329;;
330
331(define (uri->string uri . rest)
332  (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
333    (with-output-to-string
334      (lambda ()
335        (display-fragments
336         `(,(and-let* ((scheme (uri-scheme uri))) (list scheme ":"))
337           ,(and-let* ((auth (URI-authority uri))
338                       (host (URIAuth-host auth)))
339              (let ((username (URIAuth-username auth))
340                    (password (URIAuth-password auth))
341                    (ipv6? (URIAuth-ipv6-host? auth))
342                    (port (URIAuth-port auth)))
343                (list "//" (and username (list (userinfomap
344                                                username
345                                                password) "@"))
346                      (if ipv6? "[" "") host (if ipv6? "]" "")
347                      (and port (list ":" port)))))
348           ,(path->string (uri-path uri))
349           ,(and-let* ((query (uri-query uri))) (list "?" query))
350           ,(and-let* ((fragment (uri-fragment uri))) (list  "#" fragment))))))))
351
352
353;; RFC3986, section 2.2
354;;
355;; Percent encoding
356;;
357
358(define uri-decode-string
359  (let ((re (irregex `(seq #\% (submatch-named num hex-digit hex-digit)))))
360    (lambda (str #!optional (char-set char-set:full))
361      (irregex-replace/all
362       re str
363       (lambda (match)
364         (let* ((encoded (irregex-match-substring match 'num))
365                (decoded (integer->char (string->number encoded 16))))
366           (if (char-set-contains? char-set decoded)
367               (string decoded)
368               (irregex-match-substring match))))))))
369
370(define (display-fragments b)
371  (let loop ((fragments b))
372    (cond
373      ((null? fragments) (begin))
374      ((not (car fragments)) 
375       (loop (cdr fragments) ))
376      ((null? (car fragments)) 
377       (loop (cdr fragments) ))
378      ((pair? (car fragments))
379       (begin (loop (car fragments))
380              (loop (cdr fragments) )))
381      (else
382       (display (car fragments))
383       (loop (cdr fragments) )))))
384
385                         
386(define (path->string path)
387  (cond
388   ((null? path) "")
389   ((eq? '/ (car path)) (string-append "/" (join-segments (cdr path))))
390   ((protect? (car path)) (join-segments (cons "." path)))
391   (else (join-segments path))))
392
393(define (join-segments segments)
394  (string-intersperse
395   (map (lambda (segment) (list)
396                (uri-encode-string segment (char-set #\/)))
397        segments) "/"))
398
399;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
400(define (protect? sa) (substring-index ":" sa))
401
402; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
403
404(define (uri->list uri . rest)
405  (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
406    `(,(URI-scheme uri) (,(uri-auth->list (URI-authority uri) userinfomap)
407                         ,(URI-path uri) ,(URI-query uri))
408      ,(URI-fragment uri))))
409
410(define (uri-auth->list uri-auth userinfomap)
411  (and uri-auth
412       `(,(and-let* ((user (URIAuth-username uri-auth))
413                     (pass (URIAuth-password uri-auth)))
414            (userinfomap user pass))
415         ,(URIAuth-host uri-auth) ,(URIAuth-port uri-auth))))
416                         
417
418(define (uri-normalize-case uri)
419  (let* ((downcase (lambda (s)
420                     (list->string (map char-downcase (string->list s)))))
421         (normalized-uri (uri-reference 
422                          (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
423         (scheme         (string->symbol (downcase (->string (uri-scheme uri)))))
424         (host           (normalize-pct-encoding (downcase (uri-host uri)))))
425    (update-uri* normalized-uri 'scheme scheme 'host host)))
426
427;; RFC 3986, section 2.1
428;;
429;; Returns a 'pct-encoded' sequence of octets.
430;;
431(define (uri-encode-string str #!optional (char-set (char-set-complement
432                                                     char-set:uri-unreserved)))
433  (define (hex-digit i)
434    (and (>= i 0) (< i 16)
435         (char-upcase (string-ref (number->string i 16) 0))))
436  (define (pct-encode c)
437    (let ((i (char->integer c)))
438     `(#\% ,(hex-digit (quotient i 16)) ,(hex-digit (remainder i 16)))))
439  (list->string
440   (foldr (lambda (c res)
441            (if (char-set-contains? char-set c)
442                (append (pct-encode c) res)
443                (cons c res)))
444          '() (string->list str))))
445
446(define normalize-pct-encoding
447  (let ((re (irregex `(seq #\% (submatch-named num hex-digit hex-digit))))
448        (char-set char-set:uri-unreserved))
449    (lambda (str)
450     (irregex-replace/all
451      re str
452      (lambda (match)
453        (let* ((encoded (irregex-match-substring match 'num))
454               (decoded (integer->char (string->number encoded 16))))
455          (if (char-set-contains? char-set:uri-unreserved decoded)
456              (string decoded)
457              (string #\%
458                      (char-upcase (string-ref encoded 0))
459                      (char-upcase (string-ref encoded 1))))))))))
460
461(define path-safe-chars (char-set-union char-set:uri-unreserved (char-set #\/ #\?)))
462
463;; RFC3986, section 3.2.2
464;;
465;; host        = IP-literal / IPv4address / reg-name
466;;
467
468;; IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet
469;; dec-octet   = DIGIT                 ; 0-9
470;;               / %x31-39 DIGIT       ; 10-99
471;;               / "1" 2DIGIT          ; 100-199
472;;               / "2" %x30-34 DIGIT   ; 200-249
473;;               / "25" %x30-35        ; 250-255
474
475(define numeric (char-set-parser char-set:digit))
476(define hex-digit (char-set-parser char-set:hex-digit))
477
478;; ucs-range->char-set is inclusive lower, exclusive upper bound!
479(define x31-39
480  (char-set-parser (ucs-range->char-set #x31 #x40)))
481(define x30-34
482  (char-set-parser (ucs-range->char-set #x30 #x35)))
483(define x30-35
484  (char-set-parser (ucs-range->char-set #x30 #x36)))
485
486(define scheme-chars (char-set-parser (char-set-union char-set:letter+digit
487                                                      (char-set #\+ #\- #\.))))
488
489(define (eof results)
490  (if (parse-results-token-value results)
491      (make-expected-result (parse-results-position results) 'EOF)
492      (make-result #t (parse-results-next results))))
493
494(define (pct-decode pct-list char-set)
495  (let ((dc (integer->char (string->number (apply string (cdr pct-list)) 16))))
496    (if (char-set-contains? char-set dc) (list dc) pct-list)))
497
498(define uri-reference-parser
499  (packrat-parser
500   uri-reference
501   
502   (pct-encoded (('#\% h1 <- hex-digit h2 <- hex-digit) `(#\% ,h1 ,h2)))
503
504  ;; Reordered from RFC's ABNF to avoid nongreedy match on single numeric
505   (dec-octet (('#\2 '#\5 n <- x30-35) `(#\2 #\5 ,n))
506              (('#\2 n1 <- x30-34 n2 <- numeric) `(#\2 ,n1 ,n2))
507              (('#\1 n1 <- numeric n2 <- numeric) `(#\1 ,n1 ,n2))
508              ((n1 <- x31-39 n2 <- numeric) `(,n1 ,n2))
509              ((n <- numeric) `(,n)))
510
511   (ipv4-address ((n1 <- dec-octet '#\. n2 <- dec-octet '#\. n3 <- dec-octet '#\. n4 <- dec-octet)
512                  (append n1 '(#\.) n2 '(#\.) n3 '(#\.) n4)))
513
514   ;; IPv6address =                                  6( h16 ":" ) ls32
515   ;;                   /                       "::" 5( h16 ":" ) ls32
516   ;;                   / [               h16 ] "::" 4( h16 ":" ) ls32
517   ;;                   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
518   ;;                   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
519   ;;                   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
520   ;;                   / [ *4( h16 ":" ) h16 ] "::"              ls32
521   ;;                   / [ *5( h16 ":" ) h16 ] "::"              h16
522   ;;                   / [ *6( h16 ":" ) h16 ] "::"
523
524   ;;       ls32        = ( h16 ":" h16 ) / IPv4address
525   ;;                   ; least-significant 32 bits of address
526
527   ;;       h16         = 1*4HEXDIG
528   ;;                   ; 16 bits of address represented in hexadecimal
529
530   (h16  ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digit n4 <- hex-digit)
531          `(,n1 ,n2 ,n3 ,n4))
532         ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digit)
533          `(,n1 ,n2 ,n3))
534         ((n1 <- hex-digit n2 <- hex-digit) `(,n1 ,n2))
535         ((n1 <- hex-digit) `(,n1)))
536
537   (ls32 ((n1 <- h16 '#\: n2 <- h16) (append n1 '(#\:) n2))
538         ((a <- ipv4-address) a))
539
540   ;; Negative-lookahead on :: to prevent greedy match
541   (h16-colon ((hex <- h16 (! '#\: '#\:)) hex))
542
543   ;; Like above, we don't want to consume ls32 at the end
544   (h16-colon-no-ls32 ((hex <- h16 '#\: (! '#\: h16)) hex))
545
546   (h16:x6 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
547             n4 <- h16 '#\: n5 <- h16 '#\: n6 <- h16-colon '#\:)
548            `(,@n1 #\: ,@n2 #\: ,@n3 #\: ,@n4 #\: ,@n5 #\: ,@n6 #\:)))
549
550   (h16:x5 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
551             n4 <- h16 '#\: n5 <- h16-colon '#\:)
552            `(,@n1 #\: ,@n2 #\: ,@n3 #\: ,@n4 #\: ,@n5 #\:)))
553
554   (h16:x4 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
555             n4 <- h16-colon '#\:)
556            `(,@n1 #\: ,@n2 #\: ,@n3 #\: ,@n4 #\:)))
557
558   (h16:x3 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16-colon '#\:)
559            `(,@n1 #\: ,@n2 #\: ,@n3 #\:)))
560
561   (h16:x2 ((n1 <- h16 '#\: n2 <- h16-colon '#\:) `(,@n1 #\: ,@n2 #\:)))
562
563   (h16:x1 ((n1 <- h16-colon '#\:) `(,@n1 #\:)))
564
565   (h16-colon? ((n <- h16-colon) n) (() '()))
566   (h16:x1-h16-colon? ((n1 <- h16:x1 n2 <- h16) (append n1 n2))
567                      ((n1 <- h16) n1)
568                      (() '()))
569   (h16:x2-h16-colon? ((n1 <- h16:x2 n2 <- h16) (append n1 n2))
570                      ((n1 <- h16:x1-h16-colon?) n1))
571   (h16:x3-h16-colon? ((n1 <- h16:x3 n2 <- h16) (append n1 n2))
572                      ((n1 <- h16:x2-h16-colon?) n1))
573   (h16:x4-h16-colon? ((n1 <- h16:x4 n2 <- h16) (append n1 n2))
574                      ((n1 <- h16:x3-h16-colon?) n1))
575   (h16:x5-h16-colon? ((n1 <- h16:x5 n2 <- h16) (append n1 n2))
576                      ((n1 <- h16:x4-h16-colon?) n1))
577   (h16:x6-h16-colon? ((n1 <- h16:x6 n2 <- h16) (append n1 n2))
578                      ((n1 <- h16:x5-h16-colon?) n1))
579
580   (ipv6-address ((n1 <- h16:x6 n2 <- ls32)
581                  (append n1 n2))
582                 (('#\: '#\: n1 <- h16:x5 n2 <- ls32)
583                  `(#\: #\: ,@n1 ,@n2))
584                 ((n1 <- h16-colon? '#\: '#\: n2 <- h16:x4 n3 <- ls32)
585                  `(,@n1 #\: #\: ,@n2 ,@n3))
586                 ((n1 <- h16:x1-h16-colon? '#\: '#\: n2 <- h16:x3 n3 <- ls32)
587                  `(,@n1 #\: #\: ,@n2 ,@n3))
588                 ((n1 <- h16:x2-h16-colon? '#\: '#\: n2 <- h16:x2 n3 <- ls32)
589                  `(,@n1 #\: #\: ,@n2 ,@n3))
590                 ((n1 <- h16:x3-h16-colon? '#\: '#\: n2 <- h16:x1 n3 <- ls32)
591                  `(,@n1 #\: #\: ,@n2 ,@n3))
592                 ((n1 <- h16:x4-h16-colon? '#\: '#\: n2 <- ls32)
593                  `(,@n1 #\: #\: ,@n2))
594                 ((n1 <- h16:x5-h16-colon? '#\: '#\: n2 <- h16)
595                  `(,@n1 #\: #\: ,@n2))
596                 ((n1 <- h16:x6-h16-colon? '#\: '#\:)
597                  `(,@n1 #\: #\:)))
598
599   ;; IPvFuture  = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
600   (ipv-future (('#\v n1 <- hex-digits '#\. n2 <- ipv-future-rest)
601                (print `(#\v ,@n1 #\. ,@n2))
602                `(#\v ,@n1 #\. ,@n2)))
603   (hex-digits ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digits)
604                (cons n1 (cons n2 n3)))
605               ((n1 <- hex-digit) `(,n1)))
606   (ipv-future-rest ((n1 <- unres-sub-colon n2 <- ipv-future-rest)
607                     (cons n1 n2))
608                    (() '()))
609   (unres-sub-colon ((n1 <- unreserved) n1)
610                    ((n2 <- sub-delims) n2)
611                    (('#\:) #\:))
612
613
614   ;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
615   (ip-literal (('#\[ a <- ipv6-address '#\]) a)
616               (('#\[ a <- ipv-future   '#\]) a))
617
618   (reg-name ((r1 <- unreserved  r2 <- reg-name) (cons r1 r2))
619             ((r1 <- pct-encoded r2 <- reg-name)
620              (append (pct-decode r1 char-set:uri-unreserved) r2))
621             ((r1 <- sub-delims  r2 <- reg-name) (cons r1 r2))
622             (() '()))
623
624   (host ((ip <- ip-literal)     (list->string ip))
625         ((ipv4 <- ipv4-address) (list->string ipv4))
626         ((rn <- reg-name)       (list->string rn)))
627
628   (port ((n <- portnum) (string->number (list->string n)))
629         (() #f))
630   (portnum ((n1 <- numeric n2 <- portnum) (cons n1 n2))
631            (() '()))
632
633   ;; RFC3986, section 3.2
634   ;;
635   ;; userinfo    = *( unreserved / pct-encoded / sub-delims / ":" )
636   ;;
637   ;; We split this up in the leading part without colons ("username") and
638   ;; everything after that ("password"), including extra colons.
639   ;;
640   ;; The RFC is not very clear, but it does mention this:
641   ;;   "The userinfo subcomponent may consist of a user name and,
642   ;;    optionally, scheme-specific information about how to gain
643   ;;    authorization to access the resource."
644   ;;
645   ;; The grammar allows multiple colons, and the RFC then continues:
646   ;;   "Applications should not render as clear text any data after
647   ;;    the first colon (":") character found within a userinfo
648   ;;    subcomponent unless the data after the colon is the empty
649   ;;    string (indicating no password)."
650
651   (userinfo0 ((u <- unreserved ur <- userinfo0)  (cons u ur))
652              ((u <- pct-encoded ur <- userinfo0)
653               (append (pct-decode u char-set:uri-unreserved) ur))
654              ((u <- sub-delims ur <- userinfo0)  (cons u ur))
655              (() '()))
656
657   (userinfo1 ((u <- unreserved ur <- userinfo1)  (cons u ur))
658              ((u <- pct-encoded ur <- userinfo1)
659               (append (pct-decode u char-set:uri-unreserved) ur))
660              ((u <- sub-delims ur <- userinfo1)  (cons u ur))
661              (('#\: ur <- userinfo1) (cons #\: ur))
662              (() '()))
663
664   (userinfo ((u0 <- userinfo0 '#\: u1 <- userinfo1)
665              (cons (list->string u0) (list->string u1)))
666             ((u0 <- userinfo0) (cons (list->string u0) #f)))
667
668   ;; authority   = [ userinfo "@" ] host [ ":" port ]
669
670   (userinfo@? ((ui <- userinfo '#\@) ui)
671                    (() '(#f . #f)))
672   (:port? (('#\: p <- port) p)
673                (() #f))
674   (authority ((ui <- userinfo@? h <- host p <- :port?)
675               (make-URIAuth (car ui) (cdr ui) h
676                             (and h (is-ipv6-host? h)) p)))
677
678   ;; RFC3986, section 3
679   ;;
680   (scheme-rest ((c <- scheme-chars r <- scheme-rest) (cons c r))
681                (() '()))
682   (scheme ((a <- alpha r <- scheme-rest)
683            (string->symbol (list->string (cons a r)))))
684
685   ;;   hier-part   = "//" authority path-abempty
686   ;;               / path-absolute
687   ;;               / path-rootless
688   ;;               / path-empty
689   ;;
690   ;;
691   ;; path-abempty  = *( "/" segment )
692   ;; path-absolute = "/" [ segment-nz *( "/" segment ) ]
693   ;; path-noscheme = segment-nz-nc *( "/" segment )
694   ;; path-rootless = segment-nz *( "/" segment )
695   ;; path-empty    = 0<pchar>
696   ;;
697   ;; segment       = *pchar
698   ;; segment-nz    = 1*pchar
699   ;; segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )
700   ;; ; non-zero-length segment without any colon ":"
701   ;; pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
702
703   (pchar ((u <- unreserved) `(,u))
704          ((p <- pct-encoded) (pct-decode p path-safe-chars))
705          ((s <- sub-delims) `(,s))
706          (('#\:) `(#\:))
707          (('#\@) `(#\@)))
708
709   ;; Our own invention, not in ABNF of RFC 3986
710   (pchar-nc ((u <- unreserved) `(,u))
711             ((p <- pct-encoded) (pct-decode p path-safe-chars))
712             ((s <- sub-delims) `(,s))
713             (('#\@) `(#\@)))
714
715   (segment ((p <- pchar s <- segment) (append p s))
716            (() '()))
717   (segment-nz ((p <- pchar s <- segment-nz) (append p s))
718               ((p <- pchar) p))
719   (segment-nz-nc ((p <- pchar-nc s <- segment-nz-nc) (append p s))
720                  ((p <- pchar-nc) p))
721
722   (path-empty (() '())) ;; Always succeeds. "0<pchar>" in the ABNF
723
724   ;; slash-segments is our own invention
725   (slash-segments (('#\/ s <- segment rest <- slash-segments)
726                    (cons (list->string s) rest))
727                   (() '()))
728   (path-noscheme ((s <- segment-nz-nc rest <- slash-segments)
729                   (cons (list->string s) rest)))
730
731   (path-abempty ((s <- slash-segments) (if (null? s) s (cons '/ s))))
732
733   (path-rootless ((s <- segment-nz rest <- slash-segments)
734                   (cons (list->string s) rest)))
735
736   (path-absolute (('#\/ s <- segment-nz rest <- slash-segments)
737                   (cons '/ (cons (list->string s) rest)))
738                  (('#\/) `(/ . (""))))
739
740   (hier-part (('#\/ '#\/ a <- authority p <- path-abempty)
741               `((auth . ,a) (path . ,p)))
742              ((p <- path-absolute) `((path . ,p)))
743              ((p <- path-rootless) `((path . ,p)))
744              ((p <- path-empty) `((path . ,p))))
745
746   ;; RFC3986 section 3.4
747   ;;
748   ;; query       = *( pchar / "/" / "?" )
749
750   ;; A qchar is identical to pchar, with different pct decoding rules
751   (qchar ((u <- unreserved) `(,u))
752          ((p <- pct-encoded) (pct-decode p char-set:uri-unreserved))
753          ((s <- sub-delims) `(,s))
754          (('#\:) `(#\:))
755          (('#\@) `(#\@)))
756   
757   (query ((c <- qchar r <- query) (append c r))
758          (('#\/ r <- query) (cons #\/ r))
759          (('#\? r <- query) (cons #\? r))
760          (() '()))
761
762   ;; RFC3986 section 3.5
763   ;;
764   ;; fragment       = *( pchar / "/" / "?" )
765   (fragment ((c <- qchar r <- fragment) (append c r))
766             (('#\/ r <- fragment) (cons #\/ r))
767             (('#\? r <- fragment) (cons #\? r))
768             (() '()))
769
770   ;; RFC3986 section 3
771   ;;
772   ;;   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
773   ;;
774   (?-query? (('#\? q <- query) (list->string q))
775            (() #f))
776   (hash-fragment? (('#\# f <- fragment) (list->string f))
777               (() #f))
778   (uri ((s <- scheme '#\: h <- hier-part q <- ?-query? f <- hash-fragment? eof)
779         (make-URI s (alist-ref 'auth h) (alist-ref 'path h) q f)))
780
781   ;;  RFC3986, section 4.2
782   ;;
783   ;;   relative-ref  = relative-part [ "?" query ] [ "#" fragment ]
784   ;;
785   ;;   relative-part = "//" authority path-abempty
786   ;;                 / path-absolute
787   ;;                 / path-noscheme
788   ;;                 / path-empty
789   (relative-part (('#\/ '#\/ a <- authority p <- path-abempty) `(,a . ,p))
790                  ((p <- path-absolute) `(#f . ,p))
791                  ((p <- path-noscheme) `(#f . ,p))
792                  ((p <- path-empty) `(#f . ,p)))
793   (relative-ref ((rp <- relative-part q <- ?-query? f <- hash-fragment? eof)
794                  (make-URI #f (car rp) (cdr rp) q f)))
795
796   (uri-reference ((u <- uri) u)
797                  ((r <- relative-ref) r))))
798
799;;  Reference, Relative and Absolute URI forms
800;;
801;;  RFC3986, section 4.1
802
803(define (generator s)
804  (let ((chars (string->list s))
805        (pos (top-parse-position #f)))
806    (lambda ()
807      (if (null? chars)
808          (values pos #f)
809          (let ((c (car chars))
810                (old-pos pos))
811            (set! chars (cdr chars))
812            (set! pos (update-parse-position pos c))
813            (values old-pos (cons c c)))))))
814
815(define (parse-string parser s)
816  (and-let* ((res (parser (base-generator->results (generator s))))
817             ((parse-result-successful? res)))
818    (parse-result-semantic-value res)))
819
820(define (uri-reference s)
821  (parse-string uri-reference-parser s))
822
823;; RFC3986, section 4.3
824
825;; absolute-URI  = scheme ":" hier-part [ "?" query ]
826
827(define (absolute-uri s)
828  (let ((ref (uri-reference s)))
829    (when (uri-fragment ref)
830      (error 'absolute-uri "fragments are not permitted in absolute URI"))
831    (unless (uri-scheme ref)
832      (error 'absolute-uri "no scheme found in URI string"))
833    ref))
834
835;;
836;;  Resolving a relative URI relative to a base URI
837;;
838;;  Returns a new URI which represents the value of the first URI
839;;  interpreted as relative to the second URI.
840;;
841;;  For example:
842;;
843;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
844;;         => "http://bar.org/foo"
845;;
846;;  Algorithm from RFC3986, section 5.2.2
847;;
848
849(define (uri-relative-to ref base)
850  (and (uri-reference? ref) (uri-reference? base)
851       (cond ((uri-scheme ref)      (update-URI ref
852                                                'path (just-segments ref)))
853             ((uri-authority ref)   (update-URI ref
854                                                'path (just-segments ref)
855                                                'scheme (uri-scheme base)))
856             ((let ((p (uri-path ref))) (and (not (null? p)) p)) =>
857              (lambda (ref-path)
858                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
859                    (update-URI ref
860                                'scheme (uri-scheme base)
861                                'authority (uri-auth base)
862                                'path (just-segments ref))
863                    (update-URI ref
864                                'scheme (uri-scheme base)
865                                'authority (uri-auth base)
866                                'path (merge-paths base ref-path)))))
867             ((uri-query ref) (update-URI ref
868                                          'scheme (uri-scheme base)
869                                          'authority (uri-auth base)
870                                          'path (merge-paths base (list ""))))
871             (else (update-URI ref
872                               'path (URI-path base)
873                               'scheme (URI-scheme base)
874                               'authority (URI-authority base)
875                               'query (URI-query base))))))
876
877;;
878;; Finding a URI relative to a base URI
879;;
880;; Returns a new URI which represents the relative location of the
881;; first URI with respect to the second URI.  Thus, the values
882;; supplied are expected to be absolute URIs, and the result returned
883;; may be a relative URI.
884;;
885;; Example:
886;;
887;; (uri->string
888;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
889;;                     (uri "http://example.com/Root/sub2/name2#frag")))
890;;    ==> "../sub1/name2#frag"
891;;
892
893
894(define (uri-relative-from uabs base)
895  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
896        ((ucdiff? uri-authority uabs base)   (update-URI uabs 'scheme #f))
897        ;; Special case: no relative representation for http://a/ -> http://a
898        ;; ....unless that should be a path of ("..")
899        ((null? (uri-path uabs))             (update-URI uabs 'scheme #f))
900        ((ucdiff? uri-path uabs base)
901         (update-URI uabs
902                     'scheme #f
903                     'authority #f
904                     'path (rel-path-from
905                            (remove-dot-segments (uri-path uabs))
906                            (remove-dot-segments (uri-path base)))))
907        ((ucdiff? uri-query uabs base)
908         (update-URI uabs
909                     'scheme #f
910                     'authority #f
911                     'path (list)))
912        (else
913         (update-URI uabs
914                     'scheme #f
915                     'authority #f
916                     'query #f
917                     'path (list)))))
918
919(define (ucdiff? sel u1 u2)
920  (let ((s1 (sel u1))
921        (s2 (sel u2)))
922    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
923                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
924               ((and (list? s1) (list? s2))       (equal? s1 s2))
925               ((and (string? s1) (string? s2))   (string=? s1 s2))
926               (else                              (eq? s1 s2))))))
927
928(define (rel-path-from pabs base)
929  (cond
930   ((or (null? base) (null? pabs)) pabs)
931   ;; Construct a relative path segment if the paths share a
932   ;; leading segment other than a leading '/'
933   ((and (eq? (car pabs) '/) (eq? (car base) '/))
934    (make-rel-path
935     (if (string=? (cadr pabs) (cadr base))
936         (rel-path-from1 (cdr pabs) (cdr base))
937         pabs)))
938   (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))
939
940(define (make-rel-path x)
941  (if (or (eq? (car x) '/) (string=? (car x) ".") (string=? (car x) ".."))
942      x
943      (cons "." x)))
944
945;;  rel-path-from1 strips off trailing names from the supplied paths,
946
947(define (rel-path-from1 pabs base)
948  (let* ((rpabs (reverse pabs))
949         (rbase (reverse base))
950         (rp (rel-segs-from (reverse (cdr rpabs)) (reverse (cdr rbase)))))
951    (if (null? rp)
952        (if (string=? (car rpabs) (car rbase))
953            (list)
954            (list (car rpabs)))
955        (append rp (list (car rpabs))))))
956
957;;  rel-segs-from discards any common leading segments from both paths,
958;;  then invokes dif-segs-from to calculate a relative path from the end
959;;  of the base path to the end of the target path.  The final name is
960;;  handled separately, so this deals only with "directory" segments.
961
962(define (rel-segs-from sabs base)
963  (cond ((and (null? sabs) (null? base))  (list))
964        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
965        (else (if (string=? (car sabs) (car base))
966                  (rel-segs-from (cdr sabs) (cdr base))
967                  (dif-segs-from sabs base)))))
968
969;;  dif-segs-from calculates a path difference from base to target,
970;;  not including the final name at the end of the path (i.e. results
971;;  always ends with '/')
972;;
973;;  This function operates under the invariant that the supplied value
974;;  of sabs is the desired path relative to the beginning of base.
975;;  Thus, when base is empty, the desired path has been found.
976
977(define (dif-segs-from sabs base)
978  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
979
980;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
981
982(define (uri-normalize-path-segments uri)
983  (update-URI uri 'path (just-segments uri)))
984
985(define (merge0 pb pr)
986  (let* ((rpb  (reverse pb))
987         (pb1  (reverse (if (pair? rpb) ; RFC3986, section 5.2.3, second bullet
988                            (cdr rpb) rpb))))
989    (append pb1 pr))) ; It is assumed we never get here if pr is empty!
990
991(define (merge-paths b pr)  ; pr is a relative path, *not* a URI object
992  (let ((ba (uri-authority b))
993        (pb (uri-path b)))
994    (let ((mp (if (and ba (null? pb))
995                  (cons '/ pr)  ; RFC3986, section 5.2.3, first bullet
996                  (merge0 pb pr))))
997      (remove-dot-segments mp))))
998
999(define (just-segments u)
1000  (remove-dot-segments (uri-path u)))
1001
1002;;  Remove dot segments, but protect leading '/' symbol
1003(define (remove-dot-segments ps)
1004  (if (and (pair? ps) (eq? (car ps) '/))
1005      (cons '/ (elim-dots (cdr ps)))
1006      (elim-dots ps)))
1007
1008(define (elim-dots ps)
1009  (let loop ((ps ps) (trailing-slash? #f) (lst (list)))
1010    (cond
1011     ((null? ps) (reverse (if trailing-slash? (cons "" lst) lst)))
1012     ((equal? (car ps) ".")
1013      (loop (cdr ps) #t lst))
1014     ((equal? (car ps) "..")
1015      (loop (cdr ps) #t (if (pair? lst) (cdr lst) lst)))
1016     (else
1017      (loop (cdr ps) #f (cons (car ps) lst))))))
1018
1019(define (uri-path-absolute? uri)
1020  (let ((path (uri-path uri)))
1021   (and (pair? path) (eq? '/ (car path)))))
1022
1023(define (uri-path-relative? uri)
1024  (not (uri-path-absolute? uri)))
1025)
Note: See TracBrowser for help on using the repository browser.