diff options
| -rw-r--r-- | library/http/http.tcl | 41 | ||||
| -rw-r--r-- | tests/http.test | 24 |
2 files changed, 50 insertions, 15 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl index 751ca13..5a05fa0 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -566,6 +566,10 @@ proc http::geturl {url args} { # Proxy connections aren't shared among different hosts. set state(socketinfo) $host:$port + # Save the accept types at this point to prevent a race condition. [Bug + # c11a51c482] + set state(accept-types) $http(-accept) + # See if we are supposed to use a previously opened channel. if {$state(-keepalive)} { variable socketmap @@ -637,8 +641,20 @@ proc http::geturl {url args} { return $token } +# http::Connected -- +# +# Callback used when the connection to the HTTP server is actually +# established. +# +# Arguments: +# token State token. +# proto What protocol (http, https, etc.) was used to connect. +# phost Are we using keep-alive? Non-empty if yes. +# srvurl Service-local URL that we're requesting +# Results: +# None. -proc http::Connected { token proto phost srvurl} { +proc http::Connected {token proto phost srvurl} { variable http variable urlTypes @@ -691,13 +707,12 @@ proc http::Connected { token proto phost srvurl} { if {[info exists state(-handler)]} { set state(-protocol) 1.0 } + set accept_types_seen 0 if {[catch { puts $sock "$how $srvurl HTTP/$state(-protocol)" - puts $sock "Accept: $http(-accept)" - array set hdrs $state(-headers) - if {[info exists hdrs(Host)]} { + if {[dict exists $state(-headers) Host]} { # Allow Host spoofing. [Bug 928154] - puts $sock "Host: $hdrs(Host)" + puts $sock "Host: [dict get $state(-headers) Host]" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug # #504508] @@ -705,7 +720,6 @@ proc http::Connected { token proto phost srvurl} { } else { puts $sock "Host: $host:$port" } - unset hdrs puts $sock "User-Agent: $http(-useragent)" if {$state(-protocol) == 1.0 && $state(-keepalive)} { puts $sock "Connection: keep-alive" @@ -718,18 +732,21 @@ proc http::Connected { token proto phost srvurl} { } set accept_encoding_seen 0 set content_type_seen 0 - foreach {key value} $state(-headers) { + dict for {key value} $state(-headers) { + set value [string map [list \n "" \r ""] $value] + set key [string map {" " -} [string trim $key]] if {[string equal -nocase $key "host"]} { continue } if {[string equal -nocase $key "accept-encoding"]} { set accept_encoding_seen 1 } + if {[string equal -nocase $key "accept"]} { + set accept_types_seen 1 + } if {[string equal -nocase $key "content-type"]} { set content_type_seen 1 } - set value [string map [list \n "" \r ""] $value] - set key [string trim $key] if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value @@ -738,6 +755,11 @@ proc http::Connected { token proto phost srvurl} { puts $sock "$key: $value" } } + # Allow overriding the Accept header on a per-connection basis. Useful + # for working with REST services. [Bug c11a51c482] + if {!$accept_types_seen} { + puts $sock "Accept: $state(accept-types)" + } if {!$accept_encoding_seen && ![info exists state(-handler)]} { puts $sock "Accept-Encoding: gzip,deflate,compress" } @@ -795,7 +817,6 @@ proc http::Connected { token proto phost srvurl} { Finish $token $err } } - } # Data access functions: diff --git a/tests/http.test b/tests/http.test index a0a26de..41820cb 100644 --- a/tests/http.test +++ b/tests/http.test @@ -306,7 +306,6 @@ test http-3.13 {http::geturl socket leak test} { for {set i 0} {$i < 3} {incr i} { catch {http::geturl $badurl -timeout 5000} } - # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 @@ -372,11 +371,11 @@ test http-3.27 {http::geturl: -headers override -type} -body { http::data $token } -cleanup { http::cleanup $token -} -match regexp -result {(?n)Accept \*/\* -Host .* +} -match regexp -result {(?n)Host .* User-Agent .* Connection close Content-Type {text/plain;charset=utf-8} +Accept \*/\* Accept-Encoding .* Content-Length 5} test http-3.28 {http::geturl: -headers override -type default} -body { @@ -385,11 +384,11 @@ test http-3.28 {http::geturl: -headers override -type default} -body { http::data $token } -cleanup { http::cleanup $token -} -match regexp -result {(?n)Accept \*/\* -Host .* +} -match regexp -result {(?n)Host .* User-Agent .* Connection close Content-Type {text/plain;charset=utf-8} +Accept \*/\* Accept-Encoding .* Content-Length 5} test http-3.29 {http::geturl IPv6 address} -body { @@ -418,6 +417,21 @@ test http-3.31 {http::geturl fragment without path} -body { } -cleanup { catch { http::cleanup $token } } -result 200 +# Bug c11a51c482 +test http-3.32 {http::geturl: -headers override -accept default} -body { + set token [http::geturl $url/headers -query dummy \ + -headers [list "Accept" "text/plain,application/tcl-test-value"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Host .* +User-Agent .* +Connection close +Accept text/plain,application/tcl-test-value +Accept-Encoding .* +Content-Type application/x-www-form-urlencoded +Content-Length 5} + test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data |