[c11a51c482] Stop race condition with -accept config option, and allow overriding of it via -headers option.

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