source: project/release/4/uri-generic/trunk/alternatives/uri-generic.abnf.scm @ 33645

Last change on this file since 33645 was 33645, checked in by sjamaan, 2 years ago

Fix abnf alternative by adding the SRFI-14 workaround so it passes tests

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