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

Last change on this file was 36595, checked in by sjamaan, 2 months ago

uri-generic: Initial port of abnf alternative to CHICKEN 5

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