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

Last change on this file since 36564 was 36564, checked in by sjamaan, 15 months ago

uri-generic: Port packrat parser to CHICKEN 5 and fix several bugs in it

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