Fix Proposal for [55bf73b52b]: http reuses connections after 101 Switching Protocols. To be discussed

1 files changed, 88 insertions, 61 deletions

diff --git a/library/http/http.tcl b/library/http/http.tcl
index ae0a538..df44940 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -257,26 +257,11 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     }
 
     # Is this an upgrade request/response?
-    set upgradeResponse 0
-    if {    [info exists state(upgradeRequest)]
-         && [info exists state(http)]
-         && $state(upgradeRequest)
-         && ([ncode $token] eq {101})
-    } {
-        # An upgrade must be requested by the client.
-        # If 101 response, test server response headers for an upgrade.
-        set connectionHd {}
-        set upgradeHd {}
-        if {[dict exists $state(meta) connection]} {
-            set connectionHd [string tolower [dict get $state(meta) connection]]
-        }
-        if {[dict exists $state(meta) upgrade]} {
-            set upgradeHd [string tolower [dict get $state(meta) upgrade]]
-        }
-        if {($connectionHd eq {upgrade}) && ($upgradeHd ne {})} {
-            set upgradeResponse 1
-        }
-    }
+    set upgradeResponse \
+	[expr {    [info exists state(upgradeRequest)] && $state(upgradeRequest)
+		&& [info exists state(http)] && [ncode $token] eq {101}
+		&& [info exists state(connection)] && "upgrade" in $state(connection)
+		&& [info exists state(upgrade)] && "" ne $state(upgrade)}]
 
     if {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
@@ -298,7 +283,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	catch {fileevent $state(sock) writable {}}
     } elseif {
           ([info exists state(-keepalive)] && !$state(-keepalive))
-       || ([info exists state(connection)] && ($state(connection) eq "close"))
+       || ([info exists state(connection)] && ("close" in $state(connection)))
     } {
 	set closeQueue 1
 	set connId $state(socketinfo)
@@ -306,7 +291,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	CloseSocket $state(sock) $token
     } elseif {
 	  ([info exists state(-keepalive)] && $state(-keepalive))
-       && ([info exists state(connection)] && ($state(connection) ne "close"))
+       && ([info exists state(connection)] && ("close" in $state(connection)))
     } {
 	KeepSocket $token
     }
@@ -337,7 +322,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 #	queued task if possible.  Otherwise leave it idle and ready for its next
 #	use.
 #
-#	If $socketClosing(*), then ($state(connection) eq "close") and therefore
+#	If $socketClosing(*), then ("close" in $state(connection)) and therefore
 #	this command will not be called by Finish.
 #
 # Arguments:
@@ -486,7 +471,7 @@ proc http::KeepSocket {token} {
 		(!$state(-pipeline))
 	     && [info exists socketWrQueue($connId)]
 	     && [llength $socketWrQueue($connId)]
-	     && ($state(connection) ne "close")
+	     && ("close" ni $state(connection))
 	} {
 	    # If not pipelined, (socketRdState eq Rready) tells us that we are
 	    # ready for the next write - there is no need to check
@@ -772,7 +757,7 @@ proc http::geturl {url args} {
 	-strict		boolean
 	-timeout	integer
 	-validate	boolean
-	-headers	dict
+	-headers	list
     }
     set state(charset)	$defaultCharset
     set options {
@@ -786,8 +771,8 @@ proc http::geturl {url args} {
     foreach {flag value} $args {
 	if {[regexp -- $pat $flag]} {
 	    # Validate numbers
-	    if {($flag eq "-headers") ? [catch {dict size $value}] :
-		([info exists type($flag)] && ![string is $type($flag) -strict $value])
+	    if {    ([info exists type($flag)] && ![string is $type($flag) -strict $value])
+		 || ($flag eq "-headers" && [llength $value] % 2 != 0)
 	    } {
 		unset $token
 		return -code error \
@@ -989,12 +974,14 @@ proc http::geturl {url args} {
     # c11a51c482]
     set state(accept-types) $http(-accept)
 
-    set state(upgradeRequest) [expr {
-           [dict exists $state(-headers) Upgrade]
-        && [dict exists $state(-headers) Connection]
-        && ([dict get $state(-headers) Connection] eq {Upgrade})
-        && ([dict get $state(-headers) Upgrade] ne {})
-    }]
+    # Check whether this is an Upgrade request.
+    set connectionValues [SplitCommaSeparatedFieldValue \
+			      [GetFieldValue $state(-headers) Connection]]
+    set connectionValues [string tolower $connectionValues]
+    set upgradeValues [SplitCommaSeparatedFieldValue \
+			   [GetFieldValue $state(-headers) Upgrade]]
+    set state(upgradeRequest) [expr {    "upgrade" in $connectionValues
+				      && [llength $upgradeValue] >= 1}]
 
     if {$isQuery || $isQueryChannel} {
 	# It's a POST.
@@ -1411,11 +1398,11 @@ proc http::Connected {token proto phost srvurl} {
     if {[catch {
 	set state(method) $how
 	puts $sock "$how $srvurl HTTP/$state(-protocol)"
-	if {[dict exists $state(-headers) Host]} {
+	set hostValue [GetFieldValue $state(-headers) Host]
+	if {$hostValue ne {}} {
 	    # Allow Host spoofing. [Bug 928154]
-	    set hostHdr [dict get $state(-headers) Host]
-	    regexp {^[^:]+} $hostHdr state(host)
-	    puts $sock "Host: $hostHdr"
+	    regexp {^[^:]+} $hostValue state(host)
+	    puts $sock "Host: $hostValue"
 	} elseif {$port == $defport} {
 	    # Don't add port in this case, to handle broken servers. [Bug
 	    # #504508]
@@ -1447,7 +1434,7 @@ proc http::Connected {token proto phost srvurl} {
 	# Proxy-Connection header field in any requests"
 	set accept_encoding_seen 0
 	set content_type_seen 0
-	dict for {key value} $state(-headers) {
+	foreach {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"]} {
@@ -2644,7 +2631,7 @@ proc http::Event {sock token} {
 
 		if {    ([info exists state(connection)])
 		     && ([info exists socketMapping($state(socketinfo))])
-		     && ($state(connection) eq "keep-alive")
+		     && ("keep-alive" in $state(connection))
 		     && ($state(-keepalive))
 		     && (!$state(reusing))
 		     && ($state(-pipeline))
@@ -2666,7 +2653,7 @@ proc http::Event {sock token} {
 
 		if {    ([info exists state(connection)])
 		     && ([info exists socketMapping($state(socketinfo))])
-		     && ($state(connection) eq "close")
+		     && ("close" in $state(connection))
 		     && ($state(-keepalive))
 		} {
 		    # The server warns that it will close the socket after this
@@ -2737,7 +2724,7 @@ proc http::Event {sock token} {
 		#      (totalsize == 0).
 
 		if {    (!(    [info exists state(connection)]
-			    && ($state(connection) eq "close")
+			    && ("close" in $state(connection))
 			  )
 			)
 		     && (![info exists state(transfer)])
@@ -2803,32 +2790,26 @@ proc http::Event {sock token} {
 			}
 			proxy-connection -
 			connection {
-			    set tmpHeader [string trim [string tolower $value]]
 			    # RFC 7230 Section 6.1 states that a comma-separated
-			    # list is an acceptable value.  According to
+			    # list is an acceptable value.
+			    foreach el [SplitCommaSeparatedFieldValue $value] {
+				lappend state(connection) [string tolower $el]
+			    }
+
+			    # According to
 			    # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
 			    # any comma-separated list implies keep-alive, but I
 			    # don't see this in the RFC so we'll play safe and
 			    # scan any list for "close".
-			    if {$tmpHeader in {close keep-alive}} {
-				# The common cases, continue.
-			    } elseif {[string first , $tmpHeader] < 0} {
-				# Not a comma-separated list, not "close",
-				# therefore "keep-alive".
-				set tmpHeader keep-alive
-			    } else {
-				set tmpResult keep-alive
-				set tmpCsl [split $tmpHeader ,]
-				# Optional whitespace either side of separator.
-				foreach el $tmpCsl {
-				    if {[string trim $el] eq {close}} {
-					set tmpResult close
-					break
-				    }
-			        }
-				set tmpHeader $tmpResult
+			    # FIXME: support combining duplicate header field's values.
+			    if {   "close" ni $state(connection)
+				&& "keep-alive" ni $state(connection)
+			    } {
+				lappend state(connection) "keep-alive"
 			    }
-			    set state(connection) $tmpHeader
+			}
+			upgrade {
+			    set state(upgrade) [string trim $value]
 			}
 		    }
 		    lappend state(meta) $key [string trim $value]
@@ -3561,6 +3542,52 @@ proc http::ReceiveChunked {chan command} {
     }
 }
 
+# http::SplitCommaSeparatedFieldValue --
+# 	Return the individual values of a comma-separated field value.
+#
+# Arguments:
+#	fieldValue	Comma-separated header field value.
+#
+# Results:
+#       List of values.
+proc http::SplitCommaSeparatedFieldValue {fieldValue} {
+    set r {}
+    foreach el [split $fieldValue ,] {
+	lappend r [string trim $el]
+    }
+    return $r
+}
+
+
+# http::GetFieldValue --
+# 	Return the value of a header field.
+#
+# Arguments:
+#	headers	Headers key-value list
+#	fieldName	Name of header field whose value to return.
+#
+# Results:
+#       The value of the fieldName header field
+#
+# Field names are matched case-insensitively (RFC 7230 Section 3.2).
+#
+# If the field is present multiple times, it is assumed that the field is
+# defined as a comma-separated list and the values are combined (by separating
+# them with commas, see RFC 7230 Section 3.2.2) and returned at once.
+proc http::GetFieldValue {headers fieldName} {
+    set r {}
+    foreach {field value} $headers {
+	if {[string equal -nocase $fieldName $field]} {
+	    if {$r eq {}} {
+		set r $value
+	    } else {
+		append r ", $value"
+	    }
+	}
+    }
+    return $r
+}
+
 proc http::make-transformation-chunked {chan command} {
     coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
     chan event $chan readable [namespace current]::dechunk$chan