From 436e6b5e69fc7aa7c86c30ae0eb2c19d0560fd79 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 06:44:56 +0000 Subject: Fix Proposal for [55bf73b52b]: http reuses connections after 101 Switching Protocols. To be discussed --- library/http/http.tcl | 149 +++++++++++++++++++++++++++++--------------------- 1 file 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 -- cgit v0.12 From cd11a370748a0056f5d6968020773382050d3d6e Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 15 Jun 2022 00:43:58 +0000 Subject: Minor bugfixes to library/http/http.tcl and tests/http.test --- library/http/http.tcl | 38 ++++++++++++++++++++++---------------- tests/http.test | 9 ++++++--- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index df44940..cae7e6e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -291,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)] && ("close" in $state(connection))) + && ([info exists state(connection)] && ("close" ni $state(connection))) } { KeepSocket $token } @@ -771,13 +771,18 @@ proc http::geturl {url args} { foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if { ([info exists type($flag)] && ![string is $type($flag) -strict $value]) - || ($flag eq "-headers" && [llength $value] % 2 != 0) + if { [info exists type($flag)] + && (![string is $type($flag) -strict $value]) } { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" } + if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { + unset $token + return -code error \ + "Bad value for $flag ($value), number of list elements must be even" + } set state($flag) $value } else { unset $token @@ -981,7 +986,7 @@ proc http::geturl {url args} { set upgradeValues [SplitCommaSeparatedFieldValue \ [GetFieldValue $state(-headers) Upgrade]] set state(upgradeRequest) [expr { "upgrade" in $connectionValues - && [llength $upgradeValue] >= 1}] + && [llength $upgradeValues] >= 1}] if {$isQuery || $isQueryChannel} { # It's a POST. @@ -2701,6 +2706,19 @@ proc http::Event {sock token} { set state(state) body + # According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated "Connection:" list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + # Done here to support combining duplicate header field's values. + if { [info exists state(connection)] + && ("close" ni $state(connection)) + && ("keep-alive" ni $state(connection)) + } { + lappend state(connection) "keep-alive" + } + # If doing a HEAD, then we won't get any body if {$state(-validate)} { Log ^F$tk end of response for HEAD request - token $token @@ -2795,18 +2813,6 @@ proc http::Event {sock token} { 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". - # FIXME: support combining duplicate header field's values. - if { "close" ni $state(connection) - && "keep-alive" ni $state(connection) - } { - lappend state(connection) "keep-alive" - } } upgrade { set state(upgrade) [string trim $value] diff --git a/tests/http.test b/tests/http.test index 40113dc..b0f5144 100644 --- a/tests/http.test +++ b/tests/http.test @@ -468,9 +468,12 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} -test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { - http::geturl http://test/t -headers NoDict -} -result {Bad value for -headers (NoDict), must be dict} +test http-3.34 {http::geturl -headers not a list} -returnCodes error -body { + http::geturl http://test/t -headers \" +} -result {Bad value for -headers ("), must be list} +test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body { + http::geturl http://test/t -headers {List Length 3} +} -result {Bad value for -headers (List Length 3), number of list elements must be even} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 0f72e7de19985f400051e013c40f53c98d2af9d6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 09:36:33 +0000 Subject: bump http version to 2.9.8 --- library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index cae7e6e..5a09bb8 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.7 +package provide http 2.9.8 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index e12cf84..bb742fd 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.7 [list tclPkgSetup $dir http 2.9.7 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.8 [list tclPkgSetup $dir http 2.9.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/unix/Makefile.in b/unix/Makefile.in index de7f25b..23383cd 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -950,9 +950,9 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done - @echo "Installing package http 2.9.7 as a Tcl Module"; + @echo "Installing package http 2.9.8 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.9.7.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.9.8.tm" @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ diff --git a/win/Makefile.in b/win/Makefile.in index 37d579b..08fb1b5 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -735,8 +735,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.7 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.7.tm"; + @echo "Installing package http 2.9.8 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.8.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12