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

Last change on this file since 36551 was 36551, checked in by sjamaan, 3 months ago

uri-generic: Drop unnecessary dependency on srfi-13

We used only three procedures: string-index, string-upcase and string-downcase.
string-index can be replaced relatively easily using substring-index, which is
implemented as memcmp so it might be even faster. string-upcase and
string-downcase are trivially re-implemented and for percent encoded characters
we even did this on a string which we know has only one character (in hex-digit),
so it's pointless to convert back and forth between a list, which is what these
procedures do. Instead, just take the one char and upcase it.

This should provide a (minor) performance benefit, besides dropping the useless
dependency.

File size: 33.5 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-14))
46;;    (else (use 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) (substring-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* ((downcase (lambda (s)
404                     (list->string (map char-downcase (string->list s)))))
405         (normalized-uri (uri-reference 
406                          (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
407         (scheme         (string->symbol (downcase (->string (uri-scheme uri)))))
408         (host           (normalize-pct-encoding (downcase (uri-host uri)))))
409    (update-uri* normalized-uri 'scheme scheme 'host host)))
410
411;; RFC3986, section 2.2
412;;
413;; Percent encoding
414;;
415
416(define pct-encoded (concatenation (char #\%) hexadecimal hexadecimal))
417
418;; RFC 3986, section 2.1
419;;
420;; Returns a 'pct-encoded' sequence of octets.
421;;
422(define (uri-encode-string str #!optional (char-set (char-set-complement
423                                                     char-set:uri-unreserved)))
424  (define (hex-digit i)
425    (and (>= i 0) (< i 16)
426         (char-upcase (string-ref (number->string i 16) 0))))
427  (define (pct-encode c)
428    (let ((i (char->integer c)))
429     `(#\% ,(hex-digit (quotient i 16)) ,(hex-digit (remainder i 16)))))
430  (list->string
431   (string-fold-right (lambda (c res)
432                        (if (char-set-contains? char-set c)
433                            (append (pct-encode c) res)
434                            (cons c res)))
435                      '() str)))
436
437(define normalize-pct-encoding
438  (let* ((any-char (set (char-set->list char-set:full)))
439         (decode
440          (lambda (contents)
441            (let* ((encoded (car (consumed-chars->string contents)))
442                   (decoded (integer->char (string->number (string-drop encoded 1) 16))))
443              (if (char-set-contains? char-set:uri-unreserved decoded)
444                  (list (string decoded))
445                  (list (string-upcase encoded))))))
446         (escaped-char (bind* decode
447                              (concatenation
448                               (char #\%)
449                               (repetition-n 2 hexadecimal))))
450         (partially-encoded
451          (repetition (alternatives escaped-char
452                                    (bind* consumed-chars->string
453                                           any-char)))))
454    (lambda (str)
455      (and-let* ((res (lg:lex partially-encoded (constantly #f) str)))
456        (string-concatenate (car res))))))
457
458(define (alist->uri contents)
459  (make-URI (alist-ref 'scheme contents)
460            (let ((user (alist-ref 'username contents))
461                  (pass (alist-ref 'password contents))
462                  (host (alist-ref 'host contents))
463                  (port (alist-ref 'port contents)))
464              (and (or user pass host port)
465                   (make-URIAuth user pass host port)))
466            (alist-ref 'path contents)
467            (alist-ref 'query contents)
468            (alist-ref 'fragment contents)))
469
470;;  Reference, Relative and Absolute URI forms
471;;
472;;  RFC3986, section 4.1
473
474(define (uri-reference s)
475  (and-let* ((decoded (uri-decode-string s char-set:uri-unreserved))
476             (res (or (lg:lex uri (constantly #f) decoded)
477                      (lg:lex relative-ref (constantly #f) decoded)))
478             ((not (pair? (cadr res)))) ;; end of input?
479             (alist (car res)))
480    (alist->uri alist)))
481
482
483;; RFC3986, section 3.2.2
484;;
485;; host        = IP-literal / IPv4address / reg-name
486;;
487
488;; IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet
489;; dec-octet   = DIGIT                 ; 0-9
490;;               / %x31-39 DIGIT       ; 10-99
491;;               / "1" 2DIGIT          ; 100-199
492;;               / "2" %x30-34 DIGIT   ; 200-249
493;;               / "25" %x30-35          ; 250-255
494
495(define dec-octet
496  (alternatives
497   decimal
498   (concatenation (range (integer->char #x31) (integer->char #x39))
499                  decimal)
500   (concatenation (char #\1) decimal decimal)
501   (concatenation (char #\2)
502                  (range (integer->char #x30) (integer->char #x34))
503                  decimal)
504   (concatenation (char #\2) (char #\5)
505                  (range (integer->char #x30) (integer->char #x35)))))
506
507(define ipv4-address
508  (concatenation
509   dec-octet (char #\.) dec-octet (char #\.) dec-octet (char #\.) dec-octet))
510
511;; IPv6address =                                  6( h16 ":" ) ls32
512;;                   /                       "::" 5( h16 ":" ) ls32
513;;                   / [               h16 ] "::" 4( h16 ":" ) ls32
514;;                   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
515;;                   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
516;;                   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
517;;                   / [ *4( h16 ":" ) h16 ] "::"              ls32
518;;                   / [ *5( h16 ":" ) h16 ] "::"              h16
519;;                   / [ *6( h16 ":" ) h16 ] "::"
520
521;;       ls32        = ( h16 ":" h16 ) / IPv4address
522;;                   ; least-significant 32 bits of address
523
524;;       h16         = 1*4HEXDIG
525;;                   ; 16 bits of address represented in hexadecimal
526
527(define h16 (repetition-n 4 hexadecimal))
528(define ls32 (alternatives (concatenation h16 (char #\:) h16) ipv4-address))
529
530(define ipv6-address
531  (alternatives
532   (concatenation (repetition-n 6 (concatenation h16 (char #\:))) ls32)
533   (concatenation (lit "::") (repetition-n 5 (concatenation h16 (char #\:))) ls32)
534   (concatenation (optional-sequence h16)
535                  (lit "::")
536                  (repetition-n 4 (concatenation h16 (char #\:))) ls32)
537   (concatenation (optional-sequence
538                   (repetition-n 1 (concatenation h16 (char #\:))))
539                  (lit "::")
540                  (repetition-n 3 (concatenation h16 (char #\:))) ls32)
541   (concatenation (optional-sequence
542                   (repetition-n 2 (concatenation h16 (char #\:))))
543                  (lit "::")
544                  (repetition-n 2 (concatenation h16 (char #\:))) ls32)
545   (concatenation (optional-sequence
546                   (repetition-n 3 (concatenation h16 (char #\:))))
547                  (lit "::")
548                  (concatenation h16 (char #\:)) ls32)
549   (concatenation (optional-sequence
550                   (repetition-n 4 (concatenation h16 (char #\:))))
551                  (lit "::")
552                  ls32)
553   (concatenation (optional-sequence
554                   (repetition-n 5 (concatenation h16 (char #\:))))
555                  (lit "::")
556                  h16)
557   (concatenation (optional-sequence
558                   (repetition-n 6 (concatenation h16 (char #\:))))
559                  (lit "::"))))
560
561;; IPvFuture  = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
562(define ipv-future
563  (concatenation
564   (char #\v) (repetition1 hexadecimal) (char #\.)
565   (repetition1 (alternatives unreserved sub-delims (char #\:)))))
566
567;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
568(define ip-literal
569  (concatenation (char #\[) (alternatives ipv6-address ipv-future) (char #\])))
570
571(define reg-name (repetition (alternatives unreserved pct-encoded sub-delims)))
572
573(define host (bind* (lambda (contents)
574                      `((host . ,(car (consumed-chars->string contents)))))
575                    (alternatives ip-literal ipv4-address reg-name)))
576
577(define port (bind* (lambda (contents)
578                      `((port . ,(string->number
579                                  (car (consumed-chars->string contents))))))
580                    (repetition decimal)))
581
582;; RFC3986, section 3.2
583;;
584;; userinfo    = *( unreserved / pct-encoded / sub-delims / ":" )
585;;
586;; We split this up in the leading part without colons ("username") and
587;; everything after that ("password"), including extra colons.
588;;
589;; The RFC is not very clear, but it does mention this:
590;;   "The userinfo subcomponent may consist of a user name and,
591;;    optionally, scheme-specific information about how to gain
592;;    authorization to access the resource."
593;;
594;; The grammar allows multiple colons, and the RFC then continues:
595;;   "Applications should not render as clear text any data after
596;;    the first colon (":") character found within a userinfo
597;;    subcomponent unless the data after the colon is the empty
598;;    string (indicating no password)."
599
600(define userinfo0
601  (bind*
602   (lambda (contents)
603     `((username . ,(car (consumed-chars->string contents)))))
604   (repetition (alternatives unreserved pct-encoded sub-delims))))
605
606(define userinfo1
607  (bind*
608   (lambda (contents)
609     `((password . ,(car (consumed-chars->string contents)))))
610   (repetition (alternatives unreserved pct-encoded sub-delims (char #\:)))))
611
612(define userinfo
613  (concatenation
614   userinfo0 (optional-sequence (concatenation (drop-consumed (char #\:))
615                                               userinfo1))))
616
617;; authority   = [ userinfo "@" ] host [ ":" port ]
618
619(define authority
620  (concatenation
621   (optional-sequence (concatenation userinfo (drop-consumed (char #\@))))
622   host
623   (optional-sequence (concatenation (drop-consumed (char #\:)) port))))
624
625;; RFC3986, section 3
626;;
627(define scheme
628  (bind*
629   (lambda (contents)
630     `((scheme . ,(car (consumed-chars->symbol contents)))))
631   (concatenation alpha
632                  (repetition
633                   (alternatives alpha decimal (set-from-string "+-."))))))
634
635;;   hier-part   = "//" authority path-abempty
636;;               / path-absolute
637;;               / path-rootless
638;;               / path-empty
639;;
640;;
641;; path-abempty  = *( "/" segment )
642;; path-absolute = "/" [ segment-nz *( "/" segment ) ]
643;; path-noscheme = segment-nz-nc *( "/" segment )
644;; path-rootless = segment-nz *( "/" segment )
645;; path-empty    = 0<pchar>
646;;
647;; segment       = *pchar
648;; segment-nz    = 1*pchar
649;; segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )
650;; ; non-zero-length segment without any colon ":"
651;; pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
652
653(define pchar
654  (alternatives unreserved pct-encoded sub-delims (char #\:) (char #\@)))
655
656(define pchar-nc ;; Our own invention, not in ABNF of RFC 3986
657  (alternatives unreserved pct-encoded sub-delims (char #\@)))
658
659(define segment (bind* consumed-chars->string (repetition pchar)))
660(define segment-nz (bind* consumed-chars->string (repetition1 pchar)))
661(define segment-nz-nc (bind* consumed-chars->string (repetition1 pchar-nc)))
662
663(define slash-segments ;; Also our own invention
664  (repetition (concatenation (char #\/) segment)))
665
666(define path-empty  (bind* (lambda (contents)
667                             `((path . ())))
668                           pass)) ;; Always succeeds. "0<pchar>" in the ABNF
669
670(define path-safe-chars (char-set-union char-set:uri-unreserved (char-set #\/)))
671
672(define (slashed-strings->path contents)
673  (let loop ((strs contents)
674             (res (if (and (not (null? contents))
675                           (equal? (car contents) #\/)) '("") '())))
676    (cond
677     ((null? strs) res)
678     ((equal? (car strs) #\/)
679      (loop (cdr strs) res))
680     (else
681      (loop (cdr strs)
682            (cons (uri-decode-string (car strs) path-safe-chars) res))))))
683
684(define path-noscheme
685  (bind* (lambda (contents)
686           `((path . ,(slashed-strings->path contents))))
687         (concatenation segment-nz-nc slash-segments)))
688
689(define path-abempty
690  (bind* (lambda (contents)
691           (if (null? contents)
692               `((path . ()))
693               `((path . (/ . ,(slashed-strings->path contents))))))
694         slash-segments))
695
696(define path-rootless
697  (bind* (lambda (contents)
698           `((path . ,(slashed-strings->path contents))))
699         (concatenation segment-nz slash-segments)))
700
701(define path-absolute
702  (bind*
703   (lambda (contents)
704     `((path . (/ . ,(slashed-strings->path contents)))))
705   (concatenation (char #\/)
706                  (optional-sequence
707                   (concatenation segment-nz slash-segments)))))
708
709(define hier-part
710  (alternatives
711   (concatenation (drop-consumed (lit "//")) authority path-abempty)
712   path-absolute
713   path-rootless
714   path-empty))
715
716;; RFC3986 section 3.4
717;;
718;; query       = *( pchar / "/" / "?" )
719(define query
720  (bind* (lambda (contents)
721           `((query . ,(car (consumed-chars->string contents)))))
722         (repetition (alternatives pchar (char #\/) (char #\?)))))
723
724;; RFC3986 section 3.5
725;;
726;; fragment       = *( pchar / "/" / "?" )
727(define fragment
728  (bind* (lambda (contents)
729           `((fragment . ,(car (consumed-chars->string contents)))))
730         (repetition (alternatives pchar (char #\/) (char #\?)))))
731
732;; RFC3986 section 3
733;;
734;;   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
735;;
736(define uri
737  (concatenation scheme
738                 (drop-consumed (char #\:))
739                 hier-part
740                 (optional-sequence
741                  (concatenation (drop-consumed (char #\?)) query))
742                 (optional-sequence
743                  (concatenation (drop-consumed (char #\#)) fragment))))
744
745;;  RFC3986, section 4.2
746;;
747;;   relative-ref  = relative-part [ "?" query ] [ "#" fragment ]
748;;
749;;   relative-part = "//" authority path-abempty
750;;                 / path-absolute
751;;                 / path-noscheme
752;;                 / path-empty
753(define relative-part
754  (alternatives
755   (concatenation (drop-consumed (lit "//")) authority path-abempty)
756   path-absolute
757   path-noscheme
758   path-empty))
759
760(define relative-ref
761  (concatenation
762   relative-part
763   (optional-sequence
764    (concatenation (drop-consumed (char #\?)) query))
765   (optional-sequence
766    (concatenation (drop-consumed (char #\#)) fragment))))
767
768;; RFC3986, section 4.3
769
770;; absolute-URI  = scheme ":" hier-part [ "?" query ]
771
772(define abs-uri
773  (concatenation
774   scheme
775   (drop-consumed (char #\:))
776   hier-part
777   (optional-sequence (concatenation (drop-consumed (char #\?)) query))))
778
779(define (absolute-uri s)
780  (let ((ref (uri-reference s)))
781    (when (uri-fragment ref)
782      (error 'absolute-uri "fragments are not permitted in absolute URI"))
783    (unless (uri-scheme ref)
784      (error 'absolute-uri "no scheme found in URI string"))
785    ref))
786
787;;
788;;  Resolving a relative URI relative to a base URI
789;;
790;;  Returns a new URI which represents the value of the first URI
791;;  interpreted as relative to the second URI.
792;;
793;;  For example:
794;;
795;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
796;;         => "http://bar.org/foo"
797;;
798;;  Algorithm from RFC3986, section 5.2.2
799;;
800
801(define (uri-relative-to ref base)
802  (and (uri-reference? ref) (uri-reference? base)
803       (cond ((uri-scheme ref)      (update-URI ref
804                                                'path (just-segments ref)))
805             ((uri-authority ref)   (update-URI ref
806                                                'path (just-segments ref)
807                                                'scheme (uri-scheme base)))
808             ((let ((p (uri-path ref))) (and (not (null? p)) p)) =>
809              (lambda (ref-path)
810                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
811                    (update-URI ref
812                                'scheme (uri-scheme base)
813                                'authority (uri-auth base)
814                                'path (just-segments ref))
815                    (update-URI ref
816                                'scheme (uri-scheme base)
817                                'authority (uri-auth base)
818                                'path (merge-paths base ref-path)))))
819             ((uri-query ref) (update-URI ref
820                                          'scheme (uri-scheme base)
821                                          'authority (uri-auth base)
822                                          'path (merge-paths base (list ""))))
823             (else (update-URI ref
824                               'path (URI-path base)
825                               'scheme (URI-scheme base)
826                               'authority (URI-authority base)
827                               'query (URI-query base))))))
828
829;;
830;; Finding a URI relative to a base URI
831;;
832;; Returns a new URI which represents the relative location of the
833;; first URI with respect to the second URI.  Thus, the values
834;; supplied are expected to be absolute URIs, and the result returned
835;; may be a relative URI.
836;;
837;; Example:
838;;
839;; (uri->string
840;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
841;;                     (uri "http://example.com/Root/sub2/name2#frag")))
842;;    ==> "../sub1/name2#frag"
843;;
844
845
846(define (uri-relative-from uabs base)
847  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
848        ((ucdiff? uri-authority uabs base)   (update-URI uabs 'scheme #f))
849        ;; Special case: no relative representation for http://a/ -> http://a
850        ;; ....unless that should be a path of ("..")
851        ((null? (uri-path uabs))             (update-URI uabs 'scheme #f))
852        ((ucdiff? uri-path uabs base)
853         (update-URI uabs
854                     'scheme #f
855                     'authority #f
856                     'path (rel-path-from
857                            (remove-dot-segments (uri-path uabs))
858                            (remove-dot-segments (uri-path base)))))
859        ((ucdiff? uri-query uabs base)
860         (update-URI uabs
861                     'scheme #f
862                     'authority #f
863                     'path (list)))
864        (else
865         (update-URI uabs
866                     'scheme #f
867                     'authority #f
868                     'query #f
869                     'path (list)))))
870
871(define (ucdiff? sel u1 u2)
872  (let ((s1 (sel u1))
873        (s2 (sel u2)))
874    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
875                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
876               ((and (list? s1) (list? s2))       (equal? s1 s2))
877               ((and (string? s1) (string? s2))   (string=? s1 s2))
878               (else                              (eq? s1 s2))))))
879
880(define (rel-path-from pabs base)
881  (cond
882   ((or (null? base) (null? pabs)) pabs)
883   ;; Construct a relative path segment if the paths share a
884   ;; leading segment other than a leading '/'
885   ((and (eq? (car pabs) '/) (eq? (car base) '/))
886    (make-rel-path
887     (if (string=? (cadr pabs) (cadr base))
888         (rel-path-from1 (cdr pabs) (cdr base))
889         pabs)))
890   (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))
891
892(define (make-rel-path x)
893  (if (or (eq? (car x) '/) (string=? (car x) ".") (string=? (car x) ".."))
894      x
895      (cons "." x)))
896
897;;  rel-path-from1 strips off trailing names from the supplied paths,
898
899(define (rel-path-from1 pabs base)
900  (let* ((rpabs (reverse pabs))
901         (rbase (reverse base))
902         (rp (rel-segs-from (reverse (cdr rpabs)) (reverse (cdr rbase)))))
903    (if (null? rp)
904        (if (string=? (car rpabs) (car rbase))
905            (list)
906            (list (car rpabs)))
907        (append rp (list (car rpabs))))))
908
909;;  rel-segs-from discards any common leading segments from both paths,
910;;  then invokes dif-segs-from to calculate a relative path from the end
911;;  of the base path to the end of the target path.  The final name is
912;;  handled separately, so this deals only with "directory" segments.
913
914(define (rel-segs-from sabs base)
915  (cond ((and (null? sabs) (null? base))  (list))
916        ((or (null? sabs) (null? base))   (dif-segs-from sabs base))
917        (else (if (string=? (car sabs) (car base))
918                  (rel-segs-from (cdr sabs) (cdr base))
919                  (dif-segs-from sabs base)))))
920
921;;  dif-segs-from calculates a path difference from base to target,
922;;  not including the final name at the end of the path (i.e. results
923;;  always ends with '/')
924;;
925;;  This function operates under the invariant that the supplied value
926;;  of sabs is the desired path relative to the beginning of base.
927;;  Thus, when base is empty, the desired path has been found.
928
929(define (dif-segs-from sabs base)
930  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))
931
932;;  Path segment normalization; cf. RFC3986 section 6.2.2.4
933
934(define (uri-normalize-path-segments uri)
935  (update-URI uri 'path (just-segments uri)))
936
937(define (merge0 pb pr)
938  (let* ((rpb  (reverse pb))
939         (pb1  (reverse (if (pair? rpb) ; RFC3986, section 5.2.3, second bullet
940                            (cdr rpb) rpb))))
941    (append pb1 pr))) ; It is assumed we never get here if pr is empty!
942
943(define (merge-paths b pr)  ; pr is a relative path, *not* a URI object
944  (let ((ba (uri-authority b))
945        (pb (uri-path b)))
946    (let ((mp (if (and ba (null? pb))
947                  (cons '/ pr)  ; RFC3986, section 5.2.3, first bullet
948                  (merge0 pb pr))))
949      (remove-dot-segments mp))))
950
951(define (just-segments u)
952  (remove-dot-segments (uri-path u)))
953
954;;  Remove dot segments, but protect leading '/' symbol
955(define (remove-dot-segments ps)
956  (if (and (pair? ps) (eq? (car ps) '/))
957      (cons '/ (elim-dots (cdr ps)))
958      (elim-dots ps)))
959
960(define (elim-dots ps)
961  (let loop ((ps ps) (trailing-slash? #f) (lst (list)))
962    (cond
963     ((null? ps) (reverse (if trailing-slash? (cons "" lst) lst)))
964     ((equal? (car ps) ".")
965      (loop (cdr ps) #t lst))
966     ((equal? (car ps) "..")
967      (loop (cdr ps) #t (if (pair? lst) (cdr lst) lst)))
968     (else
969      (loop (cdr ps) #f (cons (car ps) lst))))))
970
971(define (uri-path-absolute? uri)
972  (let ((path (uri-path uri)))
973   (and (pair? path) (eq? '/ (car path)))))
974
975(define (uri-path-relative? uri)
976  (not (uri-path-absolute? uri)))
977)
Note: See TracBrowser for help on using the repository browser.