source: project/release/4/uri-generic/trunk/alternatives/uri-generic.irregex.scm @ 30841

Last change on this file since 30841 was 30841, checked in by sjamaan, 5 years ago

uri-generic: Update irregex-based implementation to the latest version

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