suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

This fixes 10497 and potentially breaks programs that assume the query of a URL is always a list. I have fixed uses in the Web Server, which I expect is the major thing affected, but much more could be. Therefore I am skeptical this is a good idea just for the representation of ?. So, I'd like other people to review the change and let me know if they think I should revert it.

Browse Source
This commit is contained in:
Jay McCarthy 2011-11-23 10:35:27 -07:00
parent d64d620c00
commit 7f9818bb3e
7 changed files with 58 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/net/url-structs.rkt
View File

@ -13,7 +13,7 @@
[port (or/c false/c number?)] [port (or/c false/c number?)]
[path-absolute? boolean?] [path-absolute? boolean?]
[path (listof path/param?)] [path (listof path/param?)]
[query (listof (cons/c symbol? (or/c string? false/c)))] [query (or/c false/c (listof (cons/c symbol? (or/c string? false/c))))]
[fragment (or/c false/c string?)])) [fragment (or/c false/c string?)]))
(struct path/param ([path (or/c string? (symbols 'up 'same))] (struct path/param ([path (or/c string? (symbols 'up 'same))]
[param (listof string?)]))) [param (listof string?)])))

14
collects/net/url.rkt
View File

@ -76,7 +76,11 @@
"")) ""))
(combine-path-strings (url-path-absolute? url) path) (combine-path-strings (url-path-absolute? url) path)
;; (if query (sa "?" (uri-encode query)) "") ;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query))) (if query
(if (null? query)
"?"
(sa "?" (alist->form-urlencoded query)))
"")
(if fragment (sa "#" (uri-encode fragment)) "")))) (if fragment (sa "#" (uri-encode fragment)) ""))))
;; url->default-port : url -> num ;; url->default-port : url -> num
@ -259,7 +263,7 @@
;; transliteration of code in rfc 3986, section 5.2.2 ;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string) (define (combine-url/relative Base string)
(let ([R (string->url string)] (let ([R (string->url string)]
[T (make-url #f #f #f #f #f '() '() #f)]) [T (make-url #f #f #f #f #f '() #f #f)])
(if (url-scheme R) (if (url-scheme R)
(begin (begin
(set-url-scheme! T (url-scheme R)) (set-url-scheme! T (url-scheme R))
@ -283,7 +287,7 @@
(begin (begin
(set-url-path-absolute?! T (url-path-absolute? Base)) (set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (url-path Base)) (set-url-path! T (url-path Base))
(if (not (null? (url-query R))) (if (url-query R)
(set-url-query! T (url-query R)) (set-url-query! T (url-query R))
(set-url-query! T (url-query Base)))) (set-url-query! T (url-query Base))))
(begin (begin
@ -485,7 +489,7 @@
[path (if win-file? [path (if win-file?
(separate-windows-path-strings path) (separate-windows-path-strings path)
(separate-path-strings path))] (separate-path-strings path))]
[query (if query (form-urlencoded->alist query) '())] [query (if query (form-urlencoded->alist query) #f)]
[fragment (uri-decode/maybe fragment)]) [fragment (uri-decode/maybe fragment)])
(make-url scheme user host port abs? path query fragment)))) (make-url scheme user host port abs? path query fragment))))
(cdr (or (regexp-match url-rx str) (cdr (or (regexp-match url-rx str)
@ -574,7 +578,7 @@
(if (eq? base 'relative) (if (eq? base 'relative)
accum accum
(loop base accum)))])))]) (loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f))) (make-url "file" #f "" #f (absolute-path? path) url-path #f #f)))
(define (url->path url [kind (system-path-convention-type)]) (define (url->path url [kind (system-path-convention-type)])
(file://->path url kind)) (file://->path url kind))

81
collects/tests/net/url.rkt
View File

@ -1,6 +1,6 @@
#lang scheme #lang scheme
(require net/url tests/eli-tester (require net/url tests/eli-tester
(only-in net/uri-codec current-alist-separator-mode)) (only-in net/uri-codec current-alist-separator-mode uri-encode))
(define (url->vec url) (define (url->vec url)
(vector (vector
@ -50,29 +50,29 @@
(current-proxy-servers)) (current-proxy-servers))
=> '(("http" "proxy.com" 3128))) => '(("http" "proxy.com" 3128)))
(test-s->u #(#f #f #f #f #t (#("")) () #f) (test-s->u #(#f #f #f #f #t (#("")) #f #f)
"/") "/")
(test-s->u #(#f #f #f #f #f () () #f) (test-s->u #(#f #f #f #f #f () #f #f)
"") "")
(test-s->u #("http" #f #f #f #t (#("")) () #f) (test-s->u #("http" #f #f #f #t (#("")) #f #f)
"http:/") "http:/")
(test-s->u #("http" #f "" #f #t (#("")) () #f) (test-s->u #("http" #f "" #f #t (#("")) #f #f)
"http:///") "http:///")
(test-s->u #("http" #f "www.drscheme.org" #f #f () () #f) (test-s->u #("http" #f "www.drscheme.org" #f #f () #f #f)
"http://www.drscheme.org") "http://www.drscheme.org")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) #f #f)
"http://www.drscheme.org/") "http://www.drscheme.org/")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) #f #f)
"http://www.drscheme.org/a/b/c") "http://www.drscheme.org/a/b/c")
(test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) (test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) #f #f)
"http://robby@www.drscheme.org/a/b/c") "http://robby@www.drscheme.org/a/b/c")
(test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) () #f) (test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) #f #f)
"http://www.drscheme.org:8080/a/b/c") "http://www.drscheme.org:8080/a/b/c")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () "joe") (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) #f "joe")
"http://www.drscheme.org/a/b/c#joe") "http://www.drscheme.org/a/b/c#joe")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f)
"http://www.drscheme.org/a/b/c?tim=") "http://www.drscheme.org/a/b/c?tim=")
@ -90,53 +90,53 @@
(parameterize ([current-alist-separator-mode 'amp]) (parameterize ([current-alist-separator-mode 'amp])
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe")
"http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe")) "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe"))
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) #f #f)
"http://www.drscheme.org/a/b/c;b") "http://www.drscheme.org/a/b/c;b")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) #f #f)
"http://www.drscheme.org/a;x/b/c;b") "http://www.drscheme.org/a;x/b/c;b")
;; test unquoting for % ;; test unquoting for %
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e") (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e")
"http://www.drscheme.org/a/b/c?ti%23m=#jo%20e") "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) #f #f)
"http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20") "http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20")
(test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) () #f) (test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) #f #f)
"http://robb%20y@www.drscheme.org/") "http://robb%20y@www.drscheme.org/")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) #f #f)
"http://www.drscheme.org/%25a/b%2F/c") "http://www.drscheme.org/%25a/b%2F/c")
(test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) () #f) (test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) #f #f)
"http://robby:password@www.drscheme.org/") "http://robby:password@www.drscheme.org/")
(test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/") (test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/")
;; test the characters that need to be encoded in paths vs those that do not need to ;; test the characters that need to be encoded in paths vs those that do not need to
;; be encoded in paths ;; be encoded in paths
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) #f #f)
"http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/") "http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) #f #f)
"http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def") "http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) () #f) (test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) #f #f)
"http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;") "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;")
;; test other scheme identifiers ;; test other scheme identifiers
(test-s->u #("blah" #f "www.foo.com" #f #t (#("")) () #f) (test-s->u #("blah" #f "www.foo.com" #f #t (#("")) #f #f)
"blah://www.foo.com/") "blah://www.foo.com/")
(test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) () #f) (test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) #f #f)
"blah99://www.foo.com/") "blah99://www.foo.com/")
(test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) () #f) (test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) #f #f)
"blah+://www.foo.com/") "blah+://www.foo.com/")
(test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) () #f) (test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) #f #f)
"a+b-c456.d://www.foo.com/") "a+b-c456.d://www.foo.com/")
;; a colon and other junk (`sub-delims') can appear in usernames ;; a colon and other junk (`sub-delims') can appear in usernames
(test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) () #f) (test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) #f #f)
string->url/vec string->url/vec
"http://x:!$&'()*+,;=y@www.drscheme.org/a") "http://x:!$&'()*+,;=y@www.drscheme.org/a")
;; a colon and atsign can appear in absolute paths ;; a colon and atsign can appear in absolute paths
(test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) () #f) (test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) #f #f)
"/x:@y/z") "/x:@y/z")
;; and in relative paths as long as it's not in the first element ;; and in relative paths as long as it's not in the first element
(test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) () #f) (test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) #f #f)
"x/y:@z") "x/y:@z")
;; test bad schemes ;; test bad schemes
@ -148,38 +148,38 @@
(string->url "a b://www.foo.com/") =error> url-exception?) (string->url "a b://www.foo.com/") =error> url-exception?)
;; test file: urls ;; test file: urls
(test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f) (test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) #f #f)
"file:///abc/def.html") "file:///abc/def.html")
(test (url->string (string->url "file:///abc/def.html")) (test (url->string (string->url "file:///abc/def.html"))
=> "file:///abc/def.html") => "file:///abc/def.html")
(parameterize ([file-url-path-convention-type 'unix]) (parameterize ([file-url-path-convention-type 'unix])
(test (url->string (string->url "file://a/b")) (test (url->string (string->url "file://a/b"))
=> "file://a/b") => "file://a/b")
(test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f) (test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) #f #f)
"file://localhost/abc/def.html")) "file://localhost/abc/def.html"))
;; test files: urls with colons, and the different parsing on Windows ;; test files: urls with colons, and the different parsing on Windows
(test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f) (test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) #f #f)
"file://localhost:123/abc/def.html") "file://localhost:123/abc/def.html")
(parameterize ([file-url-path-convention-type 'unix]) (parameterize ([file-url-path-convention-type 'unix])
;; different parse for file://foo:/... ;; different parse for file://foo:/...
(test (string->url/vec "file://foo:/abc/def.html") (test (string->url/vec "file://foo:/abc/def.html")
=> #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f))) => #("file" #f "foo" #f #t (#("abc") #("def.html")) #f #f)))
(parameterize ([file-url-path-convention-type 'windows]) (parameterize ([file-url-path-convention-type 'windows])
(test (string->url/vec "file://foo:/abc/def.html") (test (string->url/vec "file://foo:/abc/def.html")
=> #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f) => #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) #f #f)
(string->url/vec "file://c:/abc/def.html") (string->url/vec "file://c:/abc/def.html")
=> #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) => #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) #f #f)
(string->url/vec "file:\\\\d\\c\\abc\\def.html") (string->url/vec "file:\\\\d\\c\\abc\\def.html")
=> #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f))) => #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) #f #f)))
(parameterize ([file-url-path-convention-type 'unix]) (parameterize ([file-url-path-convention-type 'unix])
;; but no effect on http://foo:/... ;; but no effect on http://foo:/...
(test (string->url/vec "http://foo:/abc/def.html") (test (string->url/vec "http://foo:/abc/def.html")
=> #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f))) => #("http" #f "foo" #f #t (#("abc") #("def.html")) #f #f)))
(parameterize ([file-url-path-convention-type 'windows]) (parameterize ([file-url-path-convention-type 'windows])
(test (string->url/vec "http://foo:/abc/def.html") (test (string->url/vec "http://foo:/abc/def.html")
=> #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f))) => #("http" #f "foo" #f #t (#("abc") #("def.html")) #f #f)))
(test (url->string (path->url (bytes->path #"c:\\a\\b" 'windows))) (test (url->string (path->url (bytes->path #"c:\\a\\b" 'windows)))
=> "file:///c:/a/b" => "file:///c:/a/b"
@ -228,7 +228,7 @@
"HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY") "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY")
=> #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY")) => #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY"))
(test-s->u #("mailto" #f #f #f #f (#("robby@racket-lang.org")) () #f) (test-s->u #("mailto" #f #f #f #f (#("robby@racket-lang.org")) #f #f)
"mailto:robby@racket-lang.org") "mailto:robby@racket-lang.org")
(test (string->url/vec "http://www.drscheme.org?bar=馨慧") (test (string->url/vec "http://www.drscheme.org?bar=馨慧")
@ -238,7 +238,7 @@
=> #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f)) => #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f))
(test-c-u/r "http://www.drscheme.org" (test-c-u/r "http://www.drscheme.org"
(make-url #f #f #f #f #f '() '() #f) (make-url #f #f #f #f #f '() #f #f)
"http://www.drscheme.org") "http://www.drscheme.org")
(test-c-u/r "http://www.drscheme.org" (test-c-u/r "http://www.drscheme.org"
@ -351,6 +351,11 @@
)) ))
;; PR 10497
(test
(url->string (url #f #f #f #f #f empty empty #f)) => "?"
(url->string (url #f #f #f #f #f empty #f #f)) => "")
) )
(provide tests) (provide tests)

2
collects/unstable/net/url.rkt
View File

@ -20,7 +20,7 @@
(url-port in-url) (url-port in-url)
(url-path-absolute? in-url) (url-path-absolute? in-url)
new-path new-path
empty #f
(url-fragment in-url)))) (url-fragment in-url))))
;; Eli: if it also removes the query, this it's a bad name, and it's ;; Eli: if it also removes the query, this it's a bad name, and it's
;; questionable whether it is general enough. Why not make it into a ;; questionable whether it is general enough. Why not make it into a

4
collects/web-server/default-web-root/htdocs/lang-servlets/add01.rkt
View File

@ -8,7 +8,7 @@
(let* ([uri (request-uri req)] (let* ([uri (request-uri req)]
[qry (url-query uri)]) [qry (url-query uri)])
(cond (cond
[(assoc 'second qry) [(and qry (assoc 'second qry))
=> (lambda (a-pair) => (lambda (a-pair)
(response/xexpr (response/xexpr
`(html (head (title "Answer Page")) `(html (head (title "Answer Page"))
@ -17,7 +17,7 @@
(p ,(format "The answer is: ~a" (p ,(format "The answer is: ~a"
(+ (string->number (cdr a-pair)) (+ (string->number (cdr a-pair))
(string->number (cdr (assoc 'first qry))))))))))] (string->number (cdr (assoc 'first qry))))))))))]
[(assoc 'first qry) [(and qry (assoc 'first qry))
=> (lambda (a-pair) => (lambda (a-pair)
(response/xexpr (response/xexpr
`(html (head (title "Second Page")) `(html (head (title "Second Page"))

2
collects/web-server/dispatch/syntax.rkt
View File

@ -16,7 +16,7 @@
(list (make-path/param "" empty)) (list (make-path/param "" empty))
(map (lambda (s) (make-path/param s empty)) (map (lambda (s) (make-path/param s empty))
strlist)) strlist))
empty #f))) #f #f)))
(define-syntax (dispatch-case stx) (define-syntax (dispatch-case stx)
(syntax-case stx (else) (syntax-case stx (else)

2
collects/web-server/http/request.rkt
View File

@ -177,7 +177,7 @@
(make-binding:form (string->bytes/utf-8 (symbol->string k)) (make-binding:form (string->bytes/utf-8 (symbol->string k))
(string->bytes/utf-8 v)) (string->bytes/utf-8 v))
#f)]) #f)])
(url-query uri)))) (or (url-query uri) empty))))
#f)] #f)]
[(bytes-ci=? #"POST" meth) [(bytes-ci=? #"POST" meth)
(local (local