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

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