Changeset 12842 in project


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

Merge latest changes of uri-generic release 4

Location:
release/3/uri-generic/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/uri-generic/trunk

  • release/3/uri-generic/trunk/tests/run.scm

    r12828 r12842  
    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/3/uri-generic/trunk/uri-generic.scm

    r12828 r12842  
    243243;; Returns a 'pct-encoded' sequence of octets.
    244244;;
    245 (define (pct-encode lst)
    246   (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
    247   (reverse (fold (lambda (x ax)
    248                    (let ((h1 (hex-digit (quotient x 16)))
    249                          (h2 (hex-digit (remainder x 16))))
    250                      (cons `(#\% ,h1 ,h2)  ax)))
    251                  (list) lst)))
     245(define (pct-encode char-list #!optional (char-set char-set:unreserved))
     246  (define (hex-digit i)
     247    (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
     248  (reverse (fold (lambda (c cl)
     249                   (if (char-set-contains? char-set c)
     250                       (let* ((x (char->integer c))
     251                              (h1 (hex-digit (quotient x 16)))
     252                              (h2 (hex-digit (remainder x 16))))
     253                         (cons `(#\% ,h1 ,h2) cl))
     254                       (cons c cl)))
     255                 (list) char-list)))
    252256
    253257 
     
    296300
    297301(define (uri-path-list->path pcl)
    298   (match pcl
    299          (('/ . rst) (cons '/ (map uri-char-list->string rst)))
    300          (else (map uri-char-list->string pcl))))
     302  (let ((cs (char-set-union char-set:unreserved (char-set #\/))))
     303    (match pcl
     304           (('/ . rst) (cons '/ (map (compose uri-char-list->string (cute pct-decode <> cs)) rst)))
     305           (else (map (compose uri-char-list->string (cute pct-decode <> cs)) pcl)))))
    301306
    302307(define (hier-part s)
     
    718723(define (path->string path)
    719724  (match path
    720          (('/ . segments) (string-join segments "/" 'prefix))
    721          (else (string-join path "/" 'infix))))
     725         (('/ . segments)     (string-append "/" (join-segments segments)))
     726         (((? protect?) . _)  (join-segments (cons "." path)))
     727         (else                (join-segments path))))
     728
     729(define (join-segments segments)
     730  (string-intersperse
     731   (map (lambda (segment)
     732          (string-translate* segment '(("/" . "%2F"))))
     733        segments) "/"))
     734
     735;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
     736(define (protect? sa) (string-index sa #\:))
    722737
    723738; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
     
    739754;;  Percent encoding and decoding
    740755
    741 (define (char-list-encode p enc str)
    742   (reverse
    743    (fold (lambda (c ax)
    744            (if (p c) (let* ((os (enc c)) 
    745                             (cs (pct-encode os)))
    746                        (append (reverse cs) ax))
    747                (cons c ax)))
    748          (list) str)))
    749 
    750756(define (integer->octets i)
    751757  (let loop ((i i) (lst (list)))
     
    758764  (let ((clst (string->list str)))
    759765    (uri-char-list->string
    760      (char-list-encode (disjoin pct? reserved-char?) (compose integer->octets char->integer) clst))))
     766     (pct-encode clst (char-set-union (char-set #\%) char-set:reserved)))))
    761767
    762768
     
    766772        (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
    767773
    768 (define (pct-decode c)
    769   (match c
    770          ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
    771          (else c)))
     774(define (pct-decode char-list #!optional (char-set char-set:unreserved))
     775  (map (lambda (c)
     776        (match c
     777               ((#\% h1 h2) (let ((dc (integer->char (octet-decode h1 h2))))
     778                              (if (char-set-contains? char-set dc) dc c)))
     779               (else c)))
     780       char-list))
    772781
    773782(define (octet-decode h1 h2)
     
    789798(define (uri-string->normalized-char-list str)
    790799  (let ((clst (uri-string->char-list str)))
    791     (map (lambda (c) (if (pct-encoded? c)
    792                          (let ((e (pct-decode c)))
    793                            (if (unreserved-char? e) e c)) c))
    794          clst)))
    795                          
     800    (pct-decode clst)))
    796801
    797802
Note: See TracChangeset for help on using the changeset viewer.