source: project/release/5/uri-generic/trunk/alternatives/uri-generic.abnf.scm @ 36595

Last change on this file since 36595 was 36595, checked in by sjamaan, 10 months ago

uri-generic: Initial port of abnf alternative to CHICKEN 5

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