source: project/release/4/uri-generic/trunk/alternatives/uri-generic.comparse.scm @ 33646

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

Use ascii-letter instead of letter in "alpha"

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