source: project/release/4/uri-generic/trunk/alternatives/uri-generic.prcc.scm @ 33654

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

Same

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