From 79d5320ceb313aa0509fd80893563022e1e2093e Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 6 Sep 2022 04:06:21 +0000 Subject: Revise http::geturl to open its socket in an idletask coroutine. This is preparation for a workaround to bug 824251. Revise test http-4.15 because error message has changed. This commit passes all tests. --- library/http/http.tcl | 895 +++++++++++++++++++++++++++++++++++++------------- tests/http.test | 6 +- 2 files changed, 665 insertions(+), 236 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index ce337e6..c3679f1 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -70,8 +70,10 @@ namespace eval http { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent if {[info exists socketMapping]} { # Close open sockets on re-init. Do not permit retries. foreach {url sock} [array get socketMapping] { @@ -92,15 +94,19 @@ namespace eval http { array unset socketWrState array unset socketRdQueue array unset socketWrQueue + array unset socketPhQueue array unset socketClosing array unset socketPlayCmd + array unset socketCoEvent array set socketMapping {} array set socketRdState {} array set socketWrState {} array set socketRdQueue {} array set socketWrQueue {} + array set socketPhQueue {} array set socketClosing {} array set socketPlayCmd {} + array set socketCoEvent {} return } init @@ -141,6 +147,8 @@ namespace eval http { )? } + variable TmpSockCounter 0 + namespace export geturl config reset wait formatQuery quoteString namespace export register unregister registerError # - Useful, but not exported: data, size, status, code, cleanup, error, @@ -259,8 +267,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -273,6 +283,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } # Is this an upgrade request/response? set upgradeResponse \ @@ -292,8 +305,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } { set closeQueue 1 set connId $state(socketinfo) - set sock $state(sock) - CloseSocket $state(sock) $token + if {[info exists state(sock)]} { + set sock $state(sock) + CloseSocket $state(sock) $token + } else { + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. + } } elseif {$upgradeResponse} { # Special handling for an upgrade request/response. # - geturl ensures that this is not a "persistent" socket used for @@ -310,8 +329,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } { set closeQueue 1 set connId $state(socketinfo) - set sock $state(sock) - CloseSocket $state(sock) $token + if {[info exists state(sock)]} { + set sock $state(sock) + CloseSocket $state(sock) $token + } else { + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. + } } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) && ([info exists state(connection)] && ("close" ni $state(connection))) @@ -360,8 +385,10 @@ proc http::KeepSocket {token} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -560,8 +587,10 @@ proc http::CloseSocket {s {token {}}} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent set tk [namespace tail $token] @@ -620,8 +649,10 @@ proc http::CloseQueuedQueries {connId {token {}}} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent ##Log CloseQueuedQueries $connId if {![info exists socketMapping($connId)]} { @@ -677,8 +708,10 @@ proc http::Unset {connId} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent unset socketMapping($connId) unset socketRdState($connId) @@ -729,11 +762,74 @@ proc http::reset {token {why reset}} { # array that the caller should unset to garbage collect the state. proc http::geturl {url args} { + set token [CreateToken $url {*}$args] + variable $token + upvar 0 $token state + + AsyncTransaction $token + + # -------------------------------------------------------------------------- + # Synchronous Call to http::geturl + # -------------------------------------------------------------------------- + # - If the call to http::geturl is asynchronous, it is now complete (apart + # from delivering the return value). + # - If the call to http::geturl is synchronous, the command must now wait + # for the HTTP transaction to be completed. The call to http::wait uses + # vwait, which may be inappropriate if the caller makes other HTTP + # requests in the background. + # -------------------------------------------------------------------------- + + if {![info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. + http::wait $token + + if {![info exists state]} { + # If we timed out then Finish has been called and the users + # command callback may have cleaned up the token. If so we end up + # here with nothing left to do. + return $token + } elseif {$state(status) eq "error"} { + # Something went wrong while trying to establish the connection. + # Clean up after events and such, but DON'T call the command + # callback (if available) because we're going to throw an + # exception from here instead. + set err [lindex $state(error) 0] + cleanup $token + return -code error $err + } + } + + return $token +} + +# ------------------------------------------------------------------------------ +# Proc http::CreateToken +# ------------------------------------------------------------------------------ +# Command to convert arguments into an initialised request token. +# The return value is the variable name of the token. +# +# Other effects: +# - Sets ::http::http(uid) if not already done +# - Increments ::http::http(uid) +# - May increment ::http::TmpSockCounter +# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1 +# request is appended to the queue of a persistent socket that is already +# scheduled to close. +# This also sets state(alreadyQueued) to 1. +# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the +# queue of a persistent socket that has not yet been created (and is therefore +# represented by a placeholder). +# This also sets state(ReusingPlaceholder) to 1. +# ------------------------------------------------------------------------------ + +proc http::CreateToken {url args} { variable http variable urlTypes variable defaultCharset variable defaultKeepalive variable strict + variable TmpSockCounter # Initialize the state variable, an array. We'll return the name of this # array as the token for the transaction. @@ -993,17 +1089,6 @@ proc http::geturl {url args} { # Don't append the fragment! set state(url) $url - set sockopts [list -async] - - # If we are using the proxy, we must pass in the full URL that includes - # the server name. - - if {[info exists phost] && ($phost ne "")} { - set srvurl $url - set targetAddr [list $phost $pport] - } else { - set targetAddr [list $host $port] - } # Proxy connections aren't shared among different hosts. set state(socketinfo) $host:$port @@ -1057,6 +1142,25 @@ proc http::geturl {url args} { set state(-keepalive) 0 } + # If we are using the proxy, we must pass in the full URL that includes + # the server name. + if {$phost ne ""} { + set srvurl $url + set targetAddr [list $phost $pport] + } else { + set targetAddr [list $host $port] + } + + set sockopts [list -async] + + # Pass -myaddr directly to the socket command + if {[info exists state(-myaddr)]} { + lappend sockopts -myaddr $state(-myaddr) + } + + set state(connArgs) [list $proto $phost $srvurl] + set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr] + # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a @@ -1066,15 +1170,18 @@ proc http::geturl {url args} { # $state(socketinfo). This property simplifies the mapping of open # channels. set reusing 0 - set alreadyQueued 0 + set state(alreadyQueued) 0 + set state(ReusingPlaceholder) 0 if {$state(-keepalive)} { variable socketMapping variable socketRdState variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent if {[info exists socketMapping($state(socketinfo))]} { # - If the connection is idle, it has a "fileevent readable" binding @@ -1099,14 +1206,16 @@ proc http::geturl {url args} { set sock $socketMapping($state(socketinfo)) Log "reusing closing socket $sock for $state(socketinfo) - token $token" - set alreadyQueued 1 + set state(alreadyQueued) 1 lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3 lappend com3 $token set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3] lappend socketWrQueue($state(socketinfo)) $token ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo)) ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo)) - } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} { + } elseif { [catch {fconfigure $socketMapping($state(socketinfo))}] + && (![SockIsPlaHolder $socketMapping($state(socketinfo))]) + } { ###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)" # FIXME Is it still possible for this code to be executed? If # so, this could be another place to call TestForReplay, @@ -1125,8 +1234,14 @@ proc http::geturl {url args} { # still be still writing (in the pipelined case) or # writing/reading (in the nonpipeline case). This possibility # is handled by socketWrQueue later in this command. + # - The socket may not yet exist, and be defined with a placeholder. set reusing 1 set sock $socketMapping($state(socketinfo)) + if {[SockIsPlaHolder $sock]} { + set state(ReusingPlaceholder) 1 + lappend socketPhQueue($sock) $token + } else { + } Log "reusing open socket $sock for $state(socketinfo) - token $token" } # Do not automatically close the connection socket. @@ -1134,29 +1249,94 @@ proc http::geturl {url args} { } } - if {$reusing} { - # Define state(tmpState) and state(tmpOpenCmd) for use - # by http::ReplayIfDead if the persistent connection has died. - set state(tmpState) [array get state] + set state(reusing) $reusing + unset reusing - # Pass -myaddr directly to the socket command - if {[info exists state(-myaddr)]} { - lappend sockopts -myaddr $state(-myaddr) - } + if {![info exists sock]} { + # N.B. At this point ([info exists sock] == $state(reusing)). + # This will no longer be true after we set a value of sock here. + # Give the socket a placeholder name. + set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] + } + set state(sock) $sock - set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr] + if {$state(reusing)} { + # Define these for use (only) by http::ReplayIfDead if the persistent + # connection has died. + set state(tmpConnArgs) $state(connArgs) + set state(tmpState) [array get state] + set state(tmpOpenCmd) $state(openCmd) } + return $token +} - set state(reusing) $reusing - # Excluding ReplayIfDead and the decision whether to call it, there are four - # places outside http::geturl where state(reusing) is used: - # - Connected - if reusing and not pipelined, start the state(-timeout) - # timeout (when writing). - # - DoneRequest - if reusing and pipelined, send the next pipelined write - # - Event - if reusing and pipelined, start the state(-timeout) - # timeout (when reading). - # - Event - if (not reusing) and pipelined, send the next pipelined - # write + +# ------------------------------------------------------------------------------ +# Proc ::http::SockIsPlaHolder +# ------------------------------------------------------------------------------ +# Command to return 0 if the argument is a genuine socket handle, or 1 if is a +# placeholder value generated by geturl or ReplayCore before the real socket is +# created. +# +# Arguments: +# sock - either a valid socket handle or a placeholder value +# +# Return Value: 0 or 1 +# ------------------------------------------------------------------------------ + +proc http::SockIsPlaHolder {sock} { + expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}} +} + + +# ------------------------------------------------------------------------------ +# state(reusing) +# ------------------------------------------------------------------------------ +# - state(reusing) is set by geturl, ReplayCore +# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket, +# ConfigureNewSocket, and ScheduleRequest when creating and configuring the +# connection. +# - state(reusing) is used by Connect, Connected, Event x 2 when deciding +# whether to call TestForReplay. +# - Other places where state(reusing) is used: +# - Connected - if reusing and not pipelined, start the state(-timeout) +# timeout (when writing). +# - DoneRequest - if reusing and pipelined, send the next pipelined write +# - Event - if reusing and pipelined, start the state(-timeout) +# timeout (when reading). +# - Event - if (not reusing) and pipelined, send the next pipelined +# write. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Proc http::AsyncTransaction +# ------------------------------------------------------------------------------ +# This command is called by geturl and ReplayCore to prepare the HTTP +# transaction prescribed by a suitably prepared token. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::AsyncTransaction {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + + set sock $state(sock) # See comments above re the start of this timeout in other cases. if {(!$state(reusing)) && ($state(-timeout) > 0)} { @@ -1164,29 +1344,185 @@ proc http::geturl {url args} { [list http::reset $token timeout]] } - if {![info exists sock]} { - # Pass -myaddr directly to the socket command - if {[info exists state(-myaddr)]} { - lappend sockopts -myaddr $state(-myaddr) - } + if { $state(-keepalive) + && (![info exists socketMapping($state(socketinfo))]) + } { + # This code is executed only for the first -keepalive request on a + # socket. It makes the socket persistent. + ##Log " PreparePersistentConnection" $token -- $sock -- DO + set DoLater [PreparePersistentConnection $token] + } else { + ##Log " PreparePersistentConnection" $token -- $sock -- SKIP + set DoLater {-traceread 0 -tracewrite 0} + } + + if {$state(ReusingPlaceholder)} { + # - This request is scheduled to re-use a persistent connection; + # - But the connection has not yet been created and is a placeholder; + # - And the placeholder was created by an earlier request. + # - When that earlier request calls OpenSocket, its placeholder is + # replaced with a true socket, and it then executes the equivalent of + # OpenSocket for any subsequent requests that have + # $state(ReusingPlaceholder). + Log >J$tk after idle coro NO - ReusingPlaceholder + } else { + Log >J$tk after idle coro YES + # Called if (not reusing) || (socket is not a placeholder). + set CoroName ${token}--SocketCoroutine + set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ + $token $DoLater]] + dict set socketCoEvent($state(socketinfo)) $token $cancel + } + + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::PreparePersistentConnection +# ------------------------------------------------------------------------------ +# This command is called by AsyncTransaction to initialise a "persistent +# connection" based upon a socket placeholder. It is called the first time the +# socket is associated with a "-keepalive" request. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: - DoLater, a dictionary of boolean values listing unfinished +# tasks; to be passed to ConfigureNewSocket via OpenSocket. +# ------------------------------------------------------------------------------ + +proc http::PreparePersistentConnection {token} { + variable $token + upvar 0 $token state + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + + set DoLater {-traceread 0 -tracewrite 0} + set socketMapping($state(socketinfo)) $state(sock) + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + # set varName ::http::socketRdState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelReadPipeline + dict set DoLater -traceread 1 + } + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + # set varName ::http::socketWrState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelWritePipeline + dict set DoLater -tracewrite 1 + } + + if {$state(-pipeline)} { + #Log new, init for pipelined, GRANT write access to $token in geturl + # Also grant premature read access to the socket. This is OK. + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + # socketWrState is not used by this non-pipelined transaction. + # We cannot leave it as "Wready" because the next call to + # http::geturl with a pipelined transaction would conclude that the + # socket is available for writing. + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } + + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) {} + set socketPhQueue($state(socketinfo)) {} + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} + set socketCoEvent($state(socketinfo)) {} + + return $DoLater +} + +# ------------------------------------------------------------------------------ +# Proc ::http::OpenSocket +# ------------------------------------------------------------------------------ +# This command is called as a coroutine idletask to start the asynchronous HTTP +# transaction in most cases. For the exceptions, see the calling code in +# command AsyncTransaction. +# +# Arguments: +# token - connection token (name of an array) +# DoLater - dictionary of boolean values listing unfinished tasks +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::OpenSocket {token DoLater} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + + Log >K$tk Start OpenSocket coroutine + + if {![info exists state(-keepalive)]} { + # The request has already been cancelled by the calling script. + return + } + + set sockOld $state(sock) + + dict unset socketCoEvent($state(socketinfo)) $token + + set reusing $state(reusing) + + if {$reusing} { + # If ($reusing) is true, then we do not need to create a new socket, + # even if $sockOld is only a placeholder for a socket. + set sock $sockOld + } else { + # set sock in the [catch] below. set pre [clock milliseconds] ##Log pre socket opened, - token $token - ##Log [concat $defcmd $sockopts $targetAddr] - token $token - if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} { + ##Log $state(openCmd) - token $token + if {[catch {eval $state(openCmd)} sock errdict]} { + # ERROR CASE # Something went wrong while trying to establish the connection. - # Clean up after events and such, but DON'T call the command - # callback (if available) because we're going to throw an - # exception from here instead. + # Tidy up after events and such, but DON'T call the command + # callback (if available). + # - When this was inline code in http::geturl, it threw an exception + # from here instead. + # - Now that this code is called from geturl as an idletask and not + # as inline code, it is inappropriate to run cleanup or throw an + # exception. Instead do a normal return, and let Finish report + # the error using token/state and the -command callback. + # Finish also undoes PreparePersistentConnection. set state(sock) NONE - Finish $token $sock 1 - cleanup $token - dict unset errdict -level - return -options $errdict $sock + set ::errorInfo [dict get $errdict -errorinfo] + set ::errorCode [dict get $errdict -errorcode] + Finish $token $sock + # cleanup $token + return } else { + # Normal return from $state(openCmd) always returns a valid socket. # Initialisation of a new socket. ##Log post socket opened, - token $token ##Log socket opened, now fconfigure - token $token + set state(sock) $sock set delay [expr {[clock milliseconds] - $pre}] if {$delay > 3000} { Log socket delay $delay - token $token @@ -1196,84 +1532,220 @@ proc http::geturl {url args} { ##Log socket opened, DONE fconfigure - token $token } } - # Command [socket] is called with -async, but takes 5s to 5.1s to return, - # with probability of order 1 in 10,000. This may be a bizarre scheduling - # issue with my (KJN's) system (Fedora Linux). - # This does not cause a problem (unless the request times out when this - # command returns). - set state(sock) $sock Log "Using $sock for $state(socketinfo) - token $token" \ [expr {$state(-keepalive)?"keepalive":""}] - if { $state(-keepalive) - && (![info exists socketMapping($state(socketinfo))]) - } { - # Freshly-opened socket that we would like to become persistent. - set socketMapping($state(socketinfo)) $sock + # Code above has set state(sock) $sock + ConfigureNewSocket $token $sockOld $DoLater + + ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token + return +} + + +# ------------------------------------------------------------------------------ +# Proc ::http::ConfigureNewSocket +# ------------------------------------------------------------------------------ +# Command to initialise a newly-created socket. Called only from OpenSocket. +# +# This command is called by OpenSocket whenever a genuine socket (sockNew) has +# been opened for for use by HTTP. It does two things: +# (1) If $token uses a placeholder socket, this command replaces the placeholder +# socket with the real socket, not only in $token but in all other requests +# that use the same placeholder. +# (2) It calls ScheduleRequest to schedule each request that uses the socket. +# +# +# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder). +# sockNew is ${token}(sock) +# sockOld sockNew CASES +# sock sock (if $reusing, and sockOld is sock) +# ph sock (if (not $reusing), and sockOld is ph) +# ph ph (if $reusing, and sockOld is ph) - not called in this case +# sock ph (cannot occur unless a bug) - not called in this case +# (if (not $reusing), and sockOld is sock) - illogical +# +# Arguments: +# token - connection token (name of an array) +# sockOld - handle or placeholder used for a socket before the call to OpenSocket +# DoLater - dictionary of boolean values listing unfinished tasks +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::ConfigureNewSocket {token sockOld DoLater} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + + ##Log " ConfigureNewSocket" $token $sockOld $sock ... + + set reusing $state(reusing) + set sock $state(sock) + + if {(!$reusing) && ($sock ne $sockOld)} { + # Replace the placeholder value sockOld with sock. - if {![info exists socketRdState($state(socketinfo))]} { - set socketRdState($state(socketinfo)) {} + if { [info exists socketMapping($state(socketinfo))] + && ($socketMapping($state(socketinfo)) eq $sockOld) + } { + set socketMapping($state(socketinfo)) $sock + ##Log set socketMapping($state(socketinfo)) $sock + } + + # Now finish any tasks left over from PreparePersistentConnection on + # the connection. + # + # The "unset" traces are fired by init (clears entire arrays), and + # by http::Unset. + # Unset is called by CloseQueuedQueries and (possibly never) by geturl. + # + # CancelReadPipeline, CancelWritePipeline call http::Finish for each + # token. + # + # FIXME If Finish is placeholder-aware, these traces can be set earlier, + # in PreparePersistentConnection. + + if {[dict get $DoLater -traceread]} { set varName ::http::socketRdState($state(socketinfo)) trace add variable $varName unset ::http::CancelReadPipeline - } - if {![info exists socketWrState($state(socketinfo))]} { - set socketWrState($state(socketinfo)) {} + } + if {[dict get $DoLater -tracewrite]} { set varName ::http::socketWrState($state(socketinfo)) trace add variable $varName unset ::http::CancelWritePipeline - } + } + } - if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write access to $token in geturl - # Also grant premature read access to the socket. This is OK. - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - # socketWrState is not used by this non-pipelined transaction. - # We cannot leave it as "Wready" because the next call to - # http::geturl with a pipelined transaction would conclude that the - # socket is available for writing. - #Log new, init for nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } + # Do this in all cases. + ScheduleRequest $token - set socketRdQueue($state(socketinfo)) {} - set socketWrQueue($state(socketinfo)) {} - set socketClosing($state(socketinfo)) 0 - set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} - } + # Now look at all other tokens that use the placeholder $sockOld. + if { (!$reusing) + && ($sock ne $sockOld) + && [info exists socketPhQueue($sockOld)] + } { + foreach tok $socketPhQueue($sockOld) { + # 1. Amend the token's (sock). + ##Log set ${tok}(sock) $sock + set ${tok}(sock) $sock - if {![info exists phost]} { - set phost "" - } - set state(connArgs) [list $proto $phost $srvurl] - if {$reusing} { - # For use by http::ReplayIfDead if the persistent connection has died. - # Also used by NextPipelinedWrite. - set state(tmpConnArgs) $state(connArgs) + # 2. Schedule the token's HTTP request. + # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. + set ${tok}(reusing) 1 + set ${tok}(alreadyQueued) 0 + ScheduleRequest $tok + } + set socketPhQueue($sockOld) {} } - # The element socketWrState($connId) has a value which is either the name of - # the token that is permitted to write to the socket, or "Wready" if no - # token is permitted to write. - # - # The code that sets the value to Wready immediately calls - # http::NextPipelinedWrite, which examines socketWrQueue($connId) and - # processes the next request in the queue, if there is one. The value - # Wready is not found when the interpreter is in the event loop unless the - # socket is idle. - # - # The element socketRdState($connId) has a value which is either the name of - # the token that is permitted to read from the socket, or "Rready" if no - # token is permitted to read. - # - # The code that sets the value to Rready then examines - # socketRdQueue($connId) and processes the next request in the queue, if - # there is one. The value Rready is not found when the interpreter is in - # the event loop unless the socket is idle. + return +} + + +# ------------------------------------------------------------------------------ +# The values of array variables socketMapping etc. +# ------------------------------------------------------------------------------ +# connId "$host:$port" +# socketMapping($connId) the handle or placeholder for the socket that is used +# for "-keepalive 1" requests to $connId. +# socketRdState($connId) the token that is currently reading from the socket. +# Other values: Rready (ready for next token to read). +# socketWrState($connId) the token that is currently writing to the socket. +# Other values: Wready (ready for next token to write), +# peNding (would be ready for next write, except that +# the integrity of a non-pipelined transaction requires +# waiting until the read(s) in progress are finished). +# socketRdQueue($connId) List of tokens that are queued for reading later. +# socketWrQueue($connId) List of tokens that are queued for writing later. +# socketPhQueue($connId) List of tokens that are queued to use a placeholder +# socket, when the real socket has not yet been created. +# socketClosing($connId) (boolean) true iff a server response header indicates +# that the server will close the connection at the end of +# the current response. +# socketPlayCmd($connId) The command to execute to replay pending and +# part-completed transactions if the socket closes early. +# socketCoEvent($connId) Identifier for the "after idle" event that will launch +# an OpenSocket coroutine to open or re-use a socket. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*) +# ------------------------------------------------------------------------------ +# The element socketWrState($connId) has a value which is either the name of +# the token that is permitted to write to the socket, or "Wready" if no +# token is permitted to write. +# +# The code that sets the value to Wready immediately calls +# http::NextPipelinedWrite, which examines socketWrQueue($connId) and +# processes the next request in the queue, if there is one. The value +# Wready is not found when the interpreter is in the event loop unless the +# socket is idle. +# +# The element socketRdState($connId) has a value which is either the name of +# the token that is permitted to read from the socket, or "Rready" if no +# token is permitted to read. +# +# The code that sets the value to Rready then examines +# socketRdQueue($connId) and processes the next request in the queue, if +# there is one. The value Rready is not found when the interpreter is in +# the event loop unless the socket is idle. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Proc http::ScheduleRequest +# ------------------------------------------------------------------------------ +# Command to either begin the HTTP request, or add it to the appropriate queue. +# Called from two places in ConfigureNewSocket. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: none +# ------------------------------------------------------------------------------ - if {$alreadyQueued} { +proc http::ScheduleRequest {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + Log >L$tk ScheduleRequest + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + + set Unfinished 0 + + set reusing $state(reusing) + set sockNew $state(sock) + + # The "if" tests below: must test against the current values of + # socketWrState, socketRdState, and so the tests must be done here, + # not earlier in PreparePersistentConnection. + + if {$state(alreadyQueued)} { + # The request has been appended to the queue of a persistent socket + # (that is scheduled to close and have its queue replayed). + # # A write may or may not be in progress. There is no need to set # socketWrState to prevent another call stealing write access - all # subsequent calls on this socket will come here because the socket @@ -1306,65 +1778,56 @@ proc http::geturl {url args} { # pipelined request jumping the queue. ##Log "HTTP request for token $token is queued for nonpipeline use" #Log re-use nonpipeline, GRANT delayed write access to $token in geturl - set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { - if {$reusing && $state(-pipeline)} { - #Log re-use pipelined, GRANT write access to $token in geturl - set socketWrState($state(socketinfo)) $token - - } elseif {$reusing} { - # Cf tests above - both are ready. - #Log re-use nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } - - # All (!$reusing) cases come here, and also some $reusing cases if the - # connection is ready. + if {$reusing && $state(-pipeline)} { + #Log new, init for pipelined, GRANT write access to $token in geturl + # DO NOT grant premature read access to the socket. + # set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } elseif {$reusing} { + # socketWrState is not used by this non-pipelined transaction. + # We cannot leave it as "Wready" because the next call to + # http::geturl with a pipelined transaction would conclude that the + # socket is available for writing. + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + } + + # Process the request now. + # - Command is not called unless $state(sock) is a real socket handle + # and not a placeholder. + # - All (!$reusing) cases come here. + # - Some $reusing cases come here too if the connection is + # marked as ready. Those $reusing cases are: + # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") && + # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready") + # OR $pipeline + # #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token # Connect does its own fconfigure. - fileevent $sock writable \ - [list http::Connect $token $proto $phost $srvurl] - } - # -------------------------------------------------------------------------- - # Synchronous Call to http::geturl - # -------------------------------------------------------------------------- - # - If the call to http::geturl is asynchronous, it is now complete (apart - # from delivering the return value). - # - If the call to http::geturl is synchronous, the command must now wait - # for the HTTP transaction to be completed. The call to http::wait uses - # vwait, which may be inappropriate if the caller makes other HTTP - # requests in the background. - # -------------------------------------------------------------------------- + lassign $state(connArgs) proto phost srvurl - if {![info exists state(-command)]} { - # geturl does EVERYTHING asynchronously, so if the user - # calls it synchronously, we just do a wait here. - http::wait $token - - if {![info exists state]} { - # If we timed out then Finish has been called and the users - # command callback may have cleaned up the token. If so we end up - # here with nothing left to do. - return $token - } elseif {$state(status) eq "error"} { - # Something went wrong while trying to establish the connection. - # Clean up after events and such, but DON'T call the command - # callback (if available) because we're going to throw an - # exception from here instead. - set err [lindex $state(error) 0] - cleanup $token - return -code error $err + if {[catch { + fileevent $state(sock) writable \ + [list http::Connect $token $proto $phost $srvurl] + } res opts]} { + # The socket no longer exists. + ##Log bug -- socket gone -- $res -- $opts } + } - ##Log Leaving http::geturl - token $token - return $token + + return } + # http::Connected -- # # Callback used when the connection to the HTTP server is actually @@ -1386,8 +1849,10 @@ proc http::Connected {token proto phost srvurl} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -1679,8 +2144,10 @@ proc http::DoneRequest {token} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -2008,8 +2475,10 @@ proc http::ReplayIfDead {token doing} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -2237,13 +2706,17 @@ proc http::ReInit {token} { # Use existing tokens, but try to open a new socket. proc http::ReplayCore {newQueue} { + variable TmpSockCounter + variable socketMapping variable socketRdState variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent if {[llength $newQueue] == 0} { # Nothing to do. @@ -2275,72 +2748,20 @@ proc http::ReplayCore {newQueue} { unset state(tmpConnArgs) set state(reusing) 0 + set state(ReusingPlaceholder) 0 + set state(alreadyQueued) 0 - if {$state(-timeout) > 0} { - set resetCmd [list http::reset $token timeout] - set state(after) [after $state(-timeout) $resetCmd] - } - - set pre [clock milliseconds] - ##Log pre socket opened, - token $token - ##Log $tmpOpenCmd - token $token - # 4. Open a socket. - if {[catch {eval $tmpOpenCmd} sock]} { - # Something went wrong while trying to establish the connection. - Log FAILED - $sock - set state(sock) NONE - Finish $token $sock - return - } - ##Log post socket opened, - token $token - set delay [expr {[clock milliseconds] - $pre}] - if {$delay > 3000} { - Log socket delay $delay - token $token - } - # Command [socket] is called with -async, but takes 5s to 5.1s to return, - # with probability of order 1 in 10,000. This may be a bizarre scheduling - # issue with my (KJN's) system (Fedora Linux). - # This does not cause a problem (unless the request times out when this - # command returns). - - # 5. Configure the persistent socket data. - if {$state(-keepalive)} { - set socketMapping($state(socketinfo)) $sock - - if {![info exists socketRdState($state(socketinfo))]} { - set socketRdState($state(socketinfo)) {} - set varName ::http::socketRdState($state(socketinfo)) - trace add variable $varName unset ::http::CancelReadPipeline - } - - if {![info exists socketWrState($state(socketinfo))]} { - set socketWrState($state(socketinfo)) {} - set varName ::http::socketWrState($state(socketinfo)) - trace add variable $varName unset ::http::CancelWritePipeline - } - - if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write acc to $token ReplayCore - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } - - set socketRdQueue($state(socketinfo)) {} - set socketWrQueue($state(socketinfo)) $newQueue - set socketClosing($state(socketinfo)) 0 - set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} - } + # Give the socket a placeholder name before it is created. + set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] + set state(sock) $sock - ##Log pre newQueue ReInit, - token $token - # 6. Configure sockets in the queue. + # Move the $newQueue into the placeholder socket's socketPhQueue. + set socketPhQueue($sock) {} foreach tok $newQueue { if {[ReInit $tok]} { set ${tok}(reusing) 1 set ${tok}(sock) $sock + lappend socketPhQueue($sock) $tok } else { set ${tok}(reusing) 1 set ${tok}(sock) NONE @@ -2348,19 +2769,8 @@ proc http::ReplayCore {newQueue} { } } - # 7. Configure the socket for newToken to send a request. - set state(sock) $sock - Log "Using $sock for $state(socketinfo) - token $token" \ - [expr {$state(-keepalive)?"keepalive":""}] + AsyncTransaction $token - # Initialisation of a new socket. - ##Log socket opened, now fconfigure - token $token - fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) - ##Log socket opened, DONE fconfigure - token $token - - # Connect does its own fconfigure. - fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] - #Log ---- $sock << conn to $token for HTTP request (e) return } @@ -2432,6 +2842,9 @@ proc http::cleanup {token} { if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } if {[info exists state(after)]} { after cancel $state(after) unset state(after) @@ -2503,8 +2916,10 @@ proc http::Write {token} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -2611,8 +3026,10 @@ proc http::Event {sock token} { variable socketWrState variable socketRdQueue variable socketWrQueue + variable socketPhQueue variable socketClosing variable socketPlayCmd + variable socketCoEvent variable $token upvar 0 $token state @@ -2736,6 +3153,17 @@ proc http::Event {sock token} { # response. ##Log WARNING - socket will close after response for $token # Prepare data for a call to ReplayIfClose. + + # 1. Cancel socket-assignment coro events that have not yet + # launched, and add the tokens to the write queue. + if {[info exists socketCoEvent($state(socketinfo))]} { + foreach {tok can} $socketCoEvent($state(socketinfo)) { + lappend socketWrQueue($state(socketinfo)) $tok + after cancel $can + } + set socketCoEvent($state(socketinfo)) {} + } + if { ($socketRdQueue($state(socketinfo)) ne {}) || ($socketWrQueue($state(socketinfo)) ne {}) || ($socketWrState($state(socketinfo)) ni @@ -2748,7 +3176,6 @@ proc http::Event {sock token} { set msg "token ${InFlightW} is InFlightW" ##Log $msg - token $token } - set socketPlayCmd($state(socketinfo)) \ [list ReplayIfClose $InFlightW \ $socketRdQueue($state(socketinfo)) \ diff --git a/tests/http.test b/tests/http.test index a6f1ce6..59078f2 100644 --- a/tests/http.test +++ b/tests/http.test @@ -611,17 +611,19 @@ test http-4.14 {http::Event} -body { } -cleanup { catch {http::cleanup $token} } -result {connect failed connection refused} + # Bogus host test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#] http::wait $token - http::status $token + set result "[http::status $token] -- [lindex [http::error $token] 0]" # error codes vary among platforms. } -cleanup { catch {http::cleanup $token} -} -returnCodes 1 -match glob -result "couldn't open socket*" +} -match glob -result "error -- couldn't open socket*" + test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { proc list-difference {l1 l2} { lmap item $l2 {if {$item in $l1} continue; set item} -- cgit v0.12