summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--library/http/http.tcl41
-rw-r--r--tests/http.test24
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