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

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

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

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