Changeset 12841 in project


Ignore:
Timestamp:
12/17/08 22:08:26 (11 years ago)
Author:
sjamaan
Message:

Implement percent decoding/encoding of slashes in path segments, add more tests

Location:
release/4/uri-generic/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-generic/trunk/tests/run.scm

    r12827 r12841  
    196196            encode/decode-cases))
    197197
    198 (define update-cases
    199   '(("/foo" (path: (/ "bar")) "/bar")
    200     ("/foo" (path: ("bar")) "bar")
    201     ("/foo" (host: "localhost") "//localhost/foo")
    202     ("http://foo" (query: "a=b&c&d?=%2fe") "http://foo?a=b&c&d?=%2fe")
    203     ("http://foo" (host: #f) "http:")
    204     ("http://foo" (authority: #f) "http:")))
    205 
    206 (test-group "update-uri test"
    207   (for-each (lambda (p)
    208               (let ((expected (uri-reference (third p)))
    209                     (updated (apply update-uri (uri-reference (first p)) (second p))))
    210                   (test (sprintf "~S * ~S -> ~S" (first p) (second p) (third p)) expected updated)))
    211             update-cases))
    212 
    213198(define normalize-case-cases
    214199  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
     
    226211                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
    227212            normalize-case-cases))
     213
     214(define internal-representation-cases
     215  `((,uri-scheme
     216     ;; pct-encoding not allowed in scheme
     217     ("http.:" http.)
     218     ("http+:" http+)
     219     ("http-:" http-)
     220     ("HTTP:" HTTP)
     221     ("" #f)
     222     ("/foo" #f)
     223     (":" ||))
     224    (,uri-path
     225     ("foo%20bar" ("foo%20bar"))
     226     ("foo%2Fbar" ("foo/bar"))
     227     ("foo%2ebar" ("foo.bar") "foo.bar")
     228     ("foo/bar%2Fqux" ("foo" "bar/qux"))
     229     ("foo/" ("foo" ""))
     230     ("foo/bar:qux" ("foo" "bar:qux"))
     231     ("/foo%2Fbar" (/ "foo/bar"))
     232     ("/foo/" (/ "foo" ""))
     233     ("/foo:bar" (/ "foo:bar")))))
     234
     235(test-group "internal representations"
     236  (for-each (lambda (p)
     237              (for-each (lambda (u)
     238                          (let ((in (first u))
     239                                (internal (second u))
     240                                (out (if (null? (cddr u))
     241                                         (first u)
     242                                         (third u)))
     243                                (uri (uri-reference (first u))))
     244                            (test (sprintf "~S decoded as ~S" in internal)
     245                                  internal ((car p) uri))
     246                            (test (sprintf "~S encoded to ~S" internal out)
     247                                  out (uri->string uri))))
     248                        (cdr p)))
     249            internal-representation-cases))
     250
     251(test-group "miscellaneous"
     252  ;; Special case, see section 4.2
     253  (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar")))))
  • release/4/uri-generic/trunk/uri-generic.scm

    r12827 r12841  
    231231;; Returns a 'pct-encoded' sequence of octets.
    232232;;
    233 (define (pct-encode lst)
    234   (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
    235   (reverse (fold (lambda (x ax)
    236                    (let ((h1 (hex-digit (quotient x 16)))
    237                          (h2 (hex-digit (remainder x 16))))
    238                      (cons `(#\% ,h1 ,h2)  ax)))
    239                  (list) lst)))
     233(define (pct-encode char-list #!optional (char-set char-set:unreserved))
     234  (define (hex-digit i)
     235    (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
     236  (reverse (fold (lambda (c cl)
     237                   (if (char-set-contains? char-set c)
     238                       (let* ((x (char->integer c))
     239                              (h1 (hex-digit (quotient x 16)))
     240                              (h2 (hex-digit (remainder x 16))))
     241                         (cons `(#\% ,h1 ,h2) cl))
     242                       (cons c cl)))
     243                 (list) char-list)))
    240244
    241245 
     
    284288
    285289(define (uri-path-list->path pcl)
    286   (match pcl
    287          (('/ . rst) (cons '/ (map uri-char-list->string rst)))
    288          (else (map uri-char-list->string pcl))))
     290  (let ((cs (char-set-union char-set:unreserved (char-set #\/))))
     291    (match pcl
     292           (('/ . rst) (cons '/ (map (compose uri-char-list->string (cute pct-decode <> cs)) rst)))
     293           (else (map (compose uri-char-list->string (cute pct-decode <> cs)) pcl)))))
    289294
    290295(define (hier-part s)
     
    706711(define (path->string path)
    707712  (match path
    708          (('/ . segments) (string-join segments "/" 'prefix))
    709          (else (string-join path "/" 'infix))))
     713         (('/ . segments)     (string-append "/" (join-segments segments)))
     714         (((? protect?) . _)  (join-segments (cons "." path)))
     715         (else                (join-segments path))))
     716
     717(define (join-segments segments)
     718  (string-intersperse
     719   (map (lambda (segment)
     720          (string-translate* segment '(("/" . "%2F"))))
     721        segments) "/"))
     722
     723;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
     724(define (protect? sa) (string-index sa #\:))
    710725
    711726; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
     
    727742;;  Percent encoding and decoding
    728743
    729 (define (char-list-encode p enc str)
    730   (reverse
    731    (fold (lambda (c ax)
    732            (if (p c) (let* ((os (enc c)) 
    733                             (cs (pct-encode os)))
    734                        (append (reverse cs) ax))
    735                (cons c ax)))
    736          (list) str)))
    737 
    738744(define (integer->octets i)
    739745  (let loop ((i i) (lst (list)))
     
    746752  (let ((clst (string->list str)))
    747753    (uri-char-list->string
    748      (char-list-encode (disjoin pct? reserved-char?) (compose integer->octets char->integer) clst))))
     754     (pct-encode clst (char-set-union (char-set #\%) char-set:reserved)))))
    749755
    750756
     
    754760        (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
    755761
    756 (define (pct-decode c)
    757   (match c
    758          ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
    759          (else c)))
     762(define (pct-decode char-list #!optional (char-set char-set:unreserved))
     763  (map (lambda (c)
     764        (match c
     765               ((#\% h1 h2) (let ((dc (integer->char (octet-decode h1 h2))))
     766                              (if (char-set-contains? char-set dc) dc c)))
     767               (else c)))
     768       char-list))
    760769
    761770(define (octet-decode h1 h2)
     
    777786(define (uri-string->normalized-char-list str)
    778787  (let ((clst (uri-string->char-list str)))
    779     (map (lambda (c) (if (pct-encoded? c)
    780                          (let ((e (pct-decode c)))
    781                            (if (unreserved-char? e) e c)) c))
    782          clst)))
    783                          
     788    (pct-decode clst)))
    784789
    785790
Note: See TracChangeset for help on using the changeset viewer.