source: project/release/5/uri-generic/trunk/alternatives/uri-generic.prcc.scm

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