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

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