summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
authorkjnash <k.j.nash@usa.net>2022-09-20 03:12:41 (GMT)
committerkjnash <k.j.nash@usa.net>2022-09-20 03:12:41 (GMT)
commit716fc0545e401cd7e7b733207f04cd92d476f92e (patch)
tree6c2d43115eebae4fb637c089ab07da0a143d5f56 /library
parent5f0c43664685bc2ee4df68984143d273a7d23ad6 (diff)
parentb237b6f20877470c49a9c2c82376257f6fa19fb6 (diff)
downloadtcl-716fc0545e401cd7e7b733207f04cd92d476f92e.zip
tcl-716fc0545e401cd7e7b733207f04cd92d476f92e.tar.gz
tcl-716fc0545e401cd7e7b733207f04cd92d476f92e.tar.bz2
Merge 8.7
Diffstat (limited to 'library')
-rw-r--r--library/http/http.tcl2060
1 files changed, 1669 insertions, 391 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 48e1b4b..326aede 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -27,6 +27,7 @@ namespace eval http {
-proxyport {}
-proxyfilter http::ProxyRequired
-repost 0
+ -threadlevel 0
-urlencoding utf-8
-zip 1
}
@@ -70,8 +71,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,21 +95,26 @@ 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
variable urlTypes
if {![info exists urlTypes]} {
- set urlTypes(http) [list 80 ::socket]
+ set urlTypes(http) [list 80 ::http::socket]
}
variable encodings [string tolower [encoding names]]
@@ -140,13 +148,91 @@ namespace eval http {
)?
}
- namespace export geturl config reset wait formatQuery quoteString
+ variable TmpSockCounter 0
+ variable ThreadCounter 0
+
+ variable reasonDict [dict create {*}{
+ 100 Continue
+ 101 {Switching Protocols}
+ 102 Processing
+ 103 {Early Hints}
+ 200 OK
+ 201 Created
+ 202 Accepted
+ 203 {Non-Authoritative Information}
+ 204 {No Content}
+ 205 {Reset Content}
+ 206 {Partial Content}
+ 207 Multi-Status
+ 208 {Already Reported}
+ 226 {IM Used}
+ 300 {Multiple Choices}
+ 301 {Moved Permanently}
+ 302 Found
+ 303 {See Other}
+ 304 {Not Modified}
+ 305 {Use Proxy}
+ 306 (Unused)
+ 307 {Temporary Redirect}
+ 308 {Permanent Redirect}
+ 400 {Bad Request}
+ 401 Unauthorized
+ 402 {Payment Required}
+ 403 Forbidden
+ 404 {Not Found}
+ 405 {Method Not Allowed}
+ 406 {Not Acceptable}
+ 407 {Proxy Authentication Required}
+ 408 {Request Timeout}
+ 409 Conflict
+ 410 Gone
+ 411 {Length Required}
+ 412 {Precondition Failed}
+ 413 {Content Too Large}
+ 414 {URI Too Long}
+ 415 {Unsupported Media Type}
+ 416 {Range Not Satisfiable}
+ 417 {Expectation Failed}
+ 418 (Unused)
+ 421 {Misdirected Request}
+ 422 {Unprocessable Content}
+ 423 Locked
+ 424 {Failed Dependency}
+ 425 {Too Early}
+ 426 {Upgrade Required}
+ 428 {Precondition Required}
+ 429 {Too Many Requests}
+ 431 {Request Header Fields Too Large}
+ 451 {Unavailable For Legal Reasons}
+ 500 {Internal Server Error}
+ 501 {Not Implemented}
+ 502 {Bad Gateway}
+ 503 {Service Unavailable}
+ 504 {Gateway Timeout}
+ 505 {HTTP Version Not Supported}
+ 506 {Variant Also Negotiates}
+ 507 {Insufficient Storage}
+ 508 {Loop Detected}
+ 510 {Not Extended (OBSOLETED)}
+ 511 {Network Authentication Required}
+ }]
+
+ namespace export geturl config reset wait formatQuery postError quoteString
namespace export register unregister registerError
- # - Useful, but not exported: data, size, status, code, cleanup, error,
- # meta, ncode, mapReply, init. Comments suggest that "init" can be used
- # for re-initialisation, although the command is undocumented.
- # - Not exported, probably should be upper-case initial letter as part
- # of the internals: getTextLine, make-transformation-chunked.
+ namespace export requestLine requestHeaders requestHeaderValue
+ namespace export responseLine responseHeaders responseHeaderValue
+ namespace export responseCode responseBody responseInfo reasonPhrase
+ # - Legacy aliases, were never exported:
+ # data, code, mapReply, meta, ncode
+ # - Callable from outside (e.g. from TLS) by fully-qualified name, but
+ # not exported:
+ # socket
+ # - Useful, but never exported (and likely to have naming collisions):
+ # size, status, cleanup, error, init
+ # Comments suggest that "init" can be used for re-initialisation,
+ # although the command is undocumented.
+ # - Never exported, renamed from lower-case names:
+ # GetTextLine, MakeTransformationChunked.
}
# http::Log --
@@ -223,16 +309,50 @@ proc http::config {args} {
return -code error "Unknown option $flag, must be: $usage"
}
return $http($flag)
+ } elseif {[llength $args] % 2} {
+ return -code error "If more than one argument is supplied, the\
+ number of arguments must be even"
} else {
foreach {flag value} $args {
if {![regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
}
+ if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} {
+ return -code error {Option -threadlevel must be 0, 1 or 2}
+ }
set http($flag) $value
}
+ return
}
}
+# ------------------------------------------------------------------------------
+# Proc http::reasonPhrase
+# ------------------------------------------------------------------------------
+# Command to return the IANA-recommended "reason phrase" for a HTTP Status Code.
+# Information obtained from:
+# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml
+#
+# Arguments:
+# code - A valid HTTP Status Code (integer from 100 to 599)
+#
+# Return Value: the reason phrase
+# ------------------------------------------------------------------------------
+
+proc http::reasonPhrase {code} {
+ variable reasonDict
+ if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
+ set msg {argument must be a three-digit integer from 100 to 599}
+ return -code error $msg
+ }
+ if {[dict exists $reasonDict $code]} {
+ set reason [dict get $reasonDict $code]
+ } else {
+ set reason Unassigned
+ }
+ return $reason
+}
+
# http::Finish --
#
# Clean up the socket and eval close time callbacks
@@ -254,8 +374,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
@@ -265,16 +387,29 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) "error"
}
- if {[info commands ${token}EventCoroutine] ne {}} {
- rename ${token}EventCoroutine {}
+ if {[info commands ${token}--EventCoroutine] ne {}} {
+ rename ${token}--EventCoroutine {}
+ }
+ if {[info commands ${token}--SocketCoroutine] ne {}} {
+ rename ${token}--SocketCoroutine {}
+ }
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (Finish)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
}
# Is this an upgrade request/response?
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)}]
+ [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")
@@ -282,8 +417,22 @@ 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.
+ }
+ if {$state(tid) ne {}} {
+ # When opening the socket in a thread, and calling http::reset
+ # immediately, the thread may still exist.
+ # Test http-4.11 may come here.
+ thread::release $state(tid)
+ set state(tid) {}
+ } else {
+ }
} elseif {$upgradeResponse} {
# Special handling for an upgrade request/response.
# - geturl ensures that this is not a "persistent" socket used for
@@ -300,8 +449,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)))
@@ -315,7 +470,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
if {[info exists state(-command)] && (!$skipCB)
&& (![info exists state(done-command-cb)])} {
set state(done-command-cb) yes
- if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} {
+ if {[catch {namespace eval :: $state(-command) $token} err] && $errormsg eq ""} {
set state(error) [list $err $errorInfo $errorCode]
set state(status) error
}
@@ -326,7 +481,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
&& ($socketMapping($connId) eq $sock)
} {
http::CloseQueuedQueries $connId $token
+ # This calls Unset. Other cases do not need the call.
}
+ return
}
# http::KeepSocket -
@@ -348,8 +505,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
@@ -384,9 +543,6 @@ proc http::KeepSocket {token} {
# queued, arrange to read it.
set token3 [lindex $socketRdQueue($connId) 0]
set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
- variable $token3
- upvar 0 $token3 state3
- set tk2 [namespace tail $token3]
#Log pipelined, GRANT read access to $token3 in KeepSocket
set socketRdState($connId) $token3
@@ -425,8 +581,7 @@ proc http::KeepSocket {token} {
# first item in the write queue, a non-pipelined request that is
# waiting for the read queue to empty. That has now happened: so
# give that request read and write access.
- variable $token3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -470,8 +625,7 @@ proc http::KeepSocket {token} {
# Code:
# - The code is the same as the code below for the nonpipelined
# case with a queued request.
- variable $token3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -492,8 +646,7 @@ proc http::KeepSocket {token} {
# If the next request is pipelined, it receives premature read
# access to the socket. This is not a problem.
set token3 [lindex $socketWrQueue($connId) 0]
- variable $token3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -512,6 +665,7 @@ proc http::KeepSocket {token} {
# There is no socketMapping($state(socketinfo)), so it does not matter
# that CloseQueuedQueries is not called.
}
+ return
}
# http::CheckEof -
@@ -537,6 +691,7 @@ proc http::CheckEof {sock} {
# will then be error-handled.
CloseSocket $sock
}
+ return
}
# http::CloseSocket -
@@ -552,8 +707,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]
@@ -580,18 +737,22 @@ proc http::CloseSocket {s {token {}}} {
Log "Closing connection $connId (sock $socketMapping($connId))"
if {[catch {close $socketMapping($connId)} err]} {
Log "Error closing connection: $err"
+ } else {
}
if {$token eq {}} {
# Cases with a non-empty token are handled by Finish, so the tokens
# are finished in connection order.
http::CloseQueuedQueries $connId
+ } else {
}
} else {
Log "Closing socket $s (no connection info)"
if {[catch {close $s} err]} {
Log "Error closing socket: $err"
+ } else {
}
}
+ return
}
# http::CloseQueuedQueries
@@ -608,9 +769,12 @@ 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)]} {
# Command has already been called.
# Don't come here again - especially recursively.
@@ -634,6 +798,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
# - Also clear the queues to prevent calls to Finish that would set the
# state for the requests that will be retried to "finished with error
# status".
+ # - At this stage socketPhQueue is empty.
set unfinished $socketPlayCmd($connId)
set socketRdQueue($connId) {}
set socketWrQueue($connId) {}
@@ -645,9 +810,11 @@ proc http::CloseQueuedQueries {connId {token {}}} {
if {$unfinished ne {}} {
Log ^R$tk Any unfinished transactions (excluding $token) failed \
- - token $token
+ - token $token - unfinished $unfinished
{*}$unfinished
+ # Calls ReplayIfClose.
}
+ return
}
# http::Unset
@@ -663,8 +830,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)
@@ -673,6 +842,7 @@ proc http::Unset {connId} {
unset -nocomplain socketWrQueue($connId)
unset -nocomplain socketClosing($connId)
unset -nocomplain socketPlayCmd($connId)
+ return
}
# http::reset --
@@ -698,6 +868,7 @@ proc http::reset {token {why reset}} {
unset state
eval ::error $errorlist
}
+ return
}
# http::geturl --
@@ -713,15 +884,100 @@ proc http::reset {token {why reset}} {
# array that the caller should unset to garbage collect the state.
proc http::geturl {url args} {
+ variable urlTypes
+
+ # The value is set in the namespace header of this file. If the file has
+ # not been modified the value is "::http::socket".
+ set socketCmd [lindex $urlTypes(http) 1]
+
+ # - If ::tls::socketCmd has its default value "::socket", change it to the
+ # new value $socketCmd.
+ # - If the old value is different, then it has been modified either by the
+ # script or by the Tcl installation, and replaced by a new command. The
+ # script or installation that modified ::tls::socketCmd is also
+ # responsible for integrating ::http::socket into its own "new" command,
+ # if it wishes to do so.
+
+ if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
+ set ::tls::socketCmd $socketCmd
+ }
+
+ 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(usingThread) if not already done
+# - 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.
+ if {![info exists http(usingThread)]} {
+ set http(usingThread) 0
+ }
if {![info exists http(uid)]} {
set http(uid) 0
}
@@ -745,6 +1001,7 @@ proc http::geturl {url args} {
-type application/x-www-form-urlencoded
-queryprogress {}
-protocol 1.1
+ -guesstype 0
binary 0
state created
meta {}
@@ -754,11 +1011,18 @@ proc http::geturl {url args} {
totalsize 0
querylength 0
queryoffset 0
- type text/html
+ type application/octet-stream
body {}
status ""
http ""
+ httpResponse {}
+ responseCode {}
+ reasonPhrase {}
connection keep-alive
+ tid {}
+ requestHeaders {}
+ requestLine {}
+ transfer {}
}
set state(-keepalive) $defaultKeepalive
set state(-strict) $strict
@@ -766,6 +1030,7 @@ proc http::geturl {url args} {
array set type {
-binary boolean
-blocksize integer
+ -guesstype boolean
-queryblocksize integer
-strict boolean
-timeout integer
@@ -774,7 +1039,7 @@ proc http::geturl {url args} {
}
set state(charset) $defaultCharset
set options {
- -binary -blocksize -channel -command -handler -headers -keepalive
+ -binary -blocksize -channel -command -guesstype -handler -headers -keepalive
-method -myaddr -progress -protocol -query -queryblocksize
-querychannel -queryprogress -strict -timeout -type -validate
}
@@ -793,8 +1058,8 @@ proc http::geturl {url args} {
}
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"
+ return -code error "Bad value for $flag ($value), number\
+ of list elements must be even"
}
set state($flag) $value
} else {
@@ -846,6 +1111,9 @@ proc http::geturl {url args} {
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
+ # RFC 9110 Sec 4.2.4 goes further than this, and deprecates the format
+ # "user:password@". It is retained here for backward compatibility,
+ # but its use is not recommended.
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded. This is only
@@ -958,6 +1226,9 @@ proc http::geturl {url args} {
if {![catch {$http(-proxyfilter) $host} proxy]} {
set phost [lindex $proxy 0]
set pport [lindex $proxy 1]
+ } else {
+ set phost {}
+ set pport {}
}
# OK, now reassemble into a full URL
@@ -971,20 +1242,9 @@ proc http::geturl {url args} {
append url : $port
}
append url $srvurl
- # Don't append the fragment!
+ # Don't append the fragment! RFC 7230 Sec 5.1
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
@@ -1038,6 +1298,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
@@ -1047,15 +1326,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
@@ -1078,14 +1360,20 @@ proc http::geturl {url args} {
# causes a call to Finish.
set reusing 1
set sock $socketMapping($state(socketinfo))
- Log "reusing socket $sock for $state(socketinfo) - token $token"
+ 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
- } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
+ ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo))
+ ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo))
+ } elseif {
+ [catch {fconfigure $socketMapping($state(socketinfo))}]
+ && (![SockIsPlaceHolder $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,
# rather than discarding the queued transactions.
@@ -1099,43 +1387,113 @@ proc http::geturl {url args} {
Unset $state(socketinfo)
} else {
# Use the persistent socket.
- # The socket may not be ready to write: an earlier request might
- # 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 be ready to write: an earlier request might
+ # 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))
- Log "reusing socket $sock for $state(socketinfo) - token $token"
-
+ if {[SockIsPlaceHolder $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.
set state(connection) keep-alive
}
}
- 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::SockIsPlaceHolder
+# ------------------------------------------------------------------------------
+# 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::SockIsPlaceHolder {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)} {
@@ -1143,29 +1501,173 @@ 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)
- }
- 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]} {
- # 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.
+ 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}
+ }
- set state(sock) NONE
- Finish $token $sock 1
- cleanup $token
- dict unset errdict -level
- return -options $errdict $sock
- } else {
+ if {$state(ReusingPlaceholder)} {
+ # - This request was added to the socketPhQueue of 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
+ } elseif {$state(alreadyQueued)} {
+ # - This request was added to the socketWrQueue and socketPlayCmd
+ # of a persistent connection that will close at the end of its current
+ # read operation.
+ Log >J$tk after idle coro NO - alreadyQueued
+ } else {
+ Log >J$tk after idle coro YES
+ set CoroName ${token}--SocketCoroutine
+ set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
+ $token $DoLater]]
+ dict set socketCoEvent($state(socketinfo)) $token $cancel
+ set state(socketcoro) $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
+ unset -nocomplain state(socketcoro)
+
+ if {[catch {
+ if {$state(reusing)} {
+ # If ($state(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 $state(openCmd) - token $token
+ set sock [namespace eval :: $state(openCmd)]
+
+ # 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
@@ -1173,85 +1675,224 @@ proc http::geturl {url args} {
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize)
##Log socket opened, DONE fconfigure - token $token
- }
+ }
+
+ Log "Using $sock for $state(socketinfo) - token $token" \
+ [expr {$state(-keepalive)?"keepalive":""}]
+
+ # Code above has set state(sock) $sock
+ ConfigureNewSocket $token $sockOld $DoLater
+ } result errdict]} {
+ Finish $token $result
}
- # 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).
+ ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token
+ return
+}
- 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
+# ------------------------------------------------------------------------------
+# 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
- if {![info exists socketRdState($state(socketinfo))]} {
- set socketRdState($state(socketinfo)) {}
+ set reusing $state(reusing)
+ set sock $state(sock)
+ ##Log " ConfigureNewSocket" $token $sockOld ... -- $sock
+
+ if {(!$reusing) && ($sock ne $sockOld)} {
+ # Replace the placeholder value sockOld with sock.
+
+ 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)]
+ } {
+ ##Log " ConfigureNewSocket" $token scheduled, now do $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 ""
- }
- if {$reusing} {
- # For use by http::ReplayIfDead if the persistent connection has died.
- # Also used by NextPipelinedWrite.
- set state(tmpConnArgs) [list $proto $phost $srvurl]
+ # 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) {}
}
+ ##Log " ConfigureNewSocket" $token DONE
+
+ return
+}
- # 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.
- if {$alreadyQueued} {
+# ------------------------------------------------------------------------------
+# 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
+# ------------------------------------------------------------------------------
+
+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
@@ -1284,53 +1925,78 @@ 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]
- }
- # Wait for the connection to complete.
- 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
+ lassign $state(connArgs) proto phost srvurl
- 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
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SendHeader
+# ------------------------------------------------------------------------------
+# Command to send a request header, and keep a copy in state(requestHeaders)
+# for debugging purposes.
+#
+# Arguments:
+# token - connection token (name of an array)
+# key - header name
+# value - header value
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::SendHeader {token key value} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ set sock $state(sock)
+ lappend state(requestHeaders) [string tolower $key] $value
+ puts $sock "$key: $value"
+ return
}
# http::Connected --
@@ -1354,8 +2020,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
@@ -1415,29 +2083,31 @@ proc http::Connected {token proto phost srvurl} {
if {[catch {
set state(method) $how
- puts $sock "$how $srvurl HTTP/$state(-protocol)"
+ set state(requestHeaders) {}
+ set state(requestLine) "$how $srvurl HTTP/$state(-protocol)"
+ puts $sock $state(requestLine)
set hostValue [GetFieldValue $state(-headers) Host]
if {$hostValue ne {}} {
# Allow Host spoofing. [Bug 928154]
regexp {^[^:]+} $hostValue state(host)
- puts $sock "Host: $hostValue"
+ SendHeader $token Host $hostValue
} elseif {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# #504508]
set state(host) $host
- puts $sock "Host: $host"
+ SendHeader $token Host $host
} else {
set state(host) $host
- puts $sock "Host: $host:$port"
+ SendHeader $token Host "$host:$port"
}
- puts $sock "User-Agent: $http(-useragent)"
+ SendHeader $token User-Agent $http(-useragent)
if {($state(-protocol) > 1.0) && $state(-keepalive)} {
# Send this header, because a 1.1 server is not compelled to treat
# this as the default.
- puts $sock "Connection: keep-alive"
+ SendHeader $token Connection keep-alive
}
if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
- puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
+ SendHeader $token Connection close ;# RFC2616 sec 8.1.2.1
}
if {($state(-protocol) < 1.1)} {
# RFC7230 A.1
@@ -1446,7 +2116,7 @@ proc http::Connected {token proto phost srvurl} {
# Don't leave this to chance.
# For HTTP/1.0 we have already "set state(connection) close"
# and "state(-keepalive) 0".
- puts $sock "Connection: close"
+ SendHeader $token Connection close
}
# RFC7230 A.1 - "clients are encouraged not to send the
# Proxy-Connection header field in any requests"
@@ -1472,19 +2142,22 @@ proc http::Connected {token proto phost srvurl} {
set state(querylength) $value
}
if {[string length $key]} {
- puts $sock "$key: $value"
+ SendHeader $token $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)"
+ SendHeader $token Accept $state(accept-types)
}
if { (!$accept_encoding_seen)
&& (![info exists state(-handler)])
&& $http(-zip)
} {
- puts $sock "Accept-Encoding: gzip,deflate,compress"
+ SendHeader $token Accept-Encoding gzip,deflate
+ } elseif {!$accept_encoding_seen} {
+ SendHeader $token Accept-Encoding identity
+ } else {
}
if {$isQueryChannel && ($state(querylength) == 0)} {
# Try to determine size of data in channel. If we cannot seek, the
@@ -1509,7 +2182,7 @@ proc http::Connected {token proto phost srvurl} {
set separator "; "
}
if {$cookies ne ""} {
- puts $sock "Cookie: $cookies"
+ SendHeader $token Cookie $cookies
}
}
@@ -1533,10 +2206,10 @@ proc http::Connected {token proto phost srvurl} {
if {$isQuery || $isQueryChannel} {
# POST method.
if {!$content_type_seen} {
- puts $sock "Content-Type: $state(-type)"
+ SendHeader $token Content-Type $state(-type)
}
if {!$contDone} {
- puts $sock "Content-Length: $state(querylength)"
+ SendHeader $token Content-Length $state(querylength)
}
puts $sock ""
flush $sock
@@ -1601,6 +2274,7 @@ proc http::Connected {token proto phost srvurl} {
Finish $token $err
}
}
+ return
}
# http::registerError
@@ -1646,8 +2320,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
@@ -1706,6 +2382,7 @@ proc http::DoneRequest {token} {
# In the nonpipeline case, connection for reading always occurs.
ReceiveResponse $token
}
+ return
}
# http::ReceiveResponse
@@ -1724,11 +2401,11 @@ proc http::ReceiveResponse {token} {
-buffersize $state(-blocksize)
Log ^D$tk begin receiving response - token $token
- coroutine ${token}EventCoroutine http::Event $sock $token
+ coroutine ${token}--EventCoroutine http::Event $sock $token
if {[info exists state(-handler)] || [info exists state(-progress)]} {
fileevent $sock readable [list http::EventGateway $sock $token]
} else {
- fileevent $sock readable ${token}EventCoroutine
+ fileevent $sock readable ${token}--EventCoroutine
}
return
}
@@ -1752,14 +2429,14 @@ proc http::EventGateway {sock token} {
variable $token
upvar 0 $token state
fileevent $sock readable {}
- catch {${token}EventCoroutine} res opts
- if {[info commands ${token}EventCoroutine] ne {}} {
+ catch {${token}--EventCoroutine} res opts
+ if {[info commands ${token}--EventCoroutine] ne {}} {
# The coroutine can be deleted by completion (a non-yield return), by
# http::Finish (when there is a premature end to the transaction), by
# http::reset or http::cleanup, or if the caller set option -channel
# but not option -handler: in the last case reading from the socket is
# now managed by commands ::http::Copy*, http::ReceiveChunked, and
- # http::make-transformation-chunked.
+ # http::MakeTransformationChunked.
#
# Catch in case the coroutine has closed the socket.
catch {fileevent $sock readable [list http::EventGateway $sock $token]}
@@ -1821,7 +2498,7 @@ proc http::NextPipelinedWrite {token} {
} {
# - The usual case for a pipelined connection, ready for a new request.
#Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
- set conn [set ${token2}(tmpConnArgs)]
+ set conn [set ${token2}(connArgs)]
set socketWrState($connId) $token2
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
@@ -1846,9 +2523,7 @@ proc http::NextPipelinedWrite {token} {
# The case in which the next request will be non-pipelined, and the read
# and write queues is ready: which is the condition for a non-pipelined
# write.
- variable $token3
- upvar 0 $token3 state3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -1880,6 +2555,7 @@ proc http::NextPipelinedWrite {token} {
#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
set socketWrState($connId) peNding
}
+ return
}
# http::CancelReadPipeline
@@ -1912,6 +2588,7 @@ proc http::CancelReadPipeline {name1 connId op} {
}
set socketRdQueue($connId) {}
}
+ return
}
# http::CancelWritePipeline
@@ -1945,6 +2622,7 @@ proc http::CancelWritePipeline {name1 connId op} {
}
set socketWrQueue($connId) {}
}
+ return
}
# http::ReplayIfDead --
@@ -1967,19 +2645,21 @@ proc http::CancelWritePipeline {name1 connId op} {
# Side Effects:
# Use the same token, but try to open a new socket.
-proc http::ReplayIfDead {tokenArg doing} {
+proc http::ReplayIfDead {token doing} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
- variable $tokenArg
- upvar 0 $tokenArg stateArg
+ variable $token
+ upvar 0 $token state
- Log running http::ReplayIfDead for $tokenArg $doing
+ Log running http::ReplayIfDead for $token $doing
# 1. Merge the tokens for transactions in flight, the read (response) queue,
# and the write (request) queue.
@@ -1988,85 +2668,86 @@ proc http::ReplayIfDead {tokenArg doing} {
set InFlightW {}
# Obtain the tokens for transactions in flight.
- if {$stateArg(-pipeline)} {
+ if {$state(-pipeline)} {
# Two transactions may be in flight. The "read" transaction was first.
# It is unlikely that the server would close the socket if a response
# was pending; however, an earlier request (as well as the present
# request) may have been sent and ignored if the socket was half-closed
# by the server.
- if { [info exists socketRdState($stateArg(socketinfo))]
- && ($socketRdState($stateArg(socketinfo)) ne "Rready")
+ if { [info exists socketRdState($state(socketinfo))]
+ && ($socketRdState($state(socketinfo)) ne "Rready")
} {
- lappend InFlightR $socketRdState($stateArg(socketinfo))
+ lappend InFlightR $socketRdState($state(socketinfo))
} elseif {($doing eq "read")} {
- lappend InFlightR $tokenArg
+ lappend InFlightR $token
}
- if { [info exists socketWrState($stateArg(socketinfo))]
- && $socketWrState($stateArg(socketinfo)) ni {Wready peNding}
+ if { [info exists socketWrState($state(socketinfo))]
+ && $socketWrState($state(socketinfo)) ni {Wready peNding}
} {
- lappend InFlightW $socketWrState($stateArg(socketinfo))
+ lappend InFlightW $socketWrState($state(socketinfo))
} elseif {($doing eq "write")} {
- lappend InFlightW $tokenArg
+ lappend InFlightW $token
}
- # Report any inconsistency of $tokenArg with socket*state.
+ # Report any inconsistency of $token with socket*state.
if { ($doing eq "read")
- && [info exists socketRdState($stateArg(socketinfo))]
- && ($tokenArg ne $socketRdState($stateArg(socketinfo)))
+ && [info exists socketRdState($state(socketinfo))]
+ && ($token ne $socketRdState($state(socketinfo)))
} {
- Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
- ne socketRdState($stateArg(socketinfo)) \
- $socketRdState($stateArg(socketinfo))
+ Log WARNING - ReplayIfDead pipelined token $token $doing \
+ ne socketRdState($state(socketinfo)) \
+ $socketRdState($state(socketinfo))
} elseif {
($doing eq "write")
- && [info exists socketWrState($stateArg(socketinfo))]
- && ($tokenArg ne $socketWrState($stateArg(socketinfo)))
+ && [info exists socketWrState($state(socketinfo))]
+ && ($token ne $socketWrState($state(socketinfo)))
} {
- Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
- ne socketWrState($stateArg(socketinfo)) \
- $socketWrState($stateArg(socketinfo))
+ Log WARNING - ReplayIfDead pipelined token $token $doing \
+ ne socketWrState($state(socketinfo)) \
+ $socketWrState($state(socketinfo))
}
} else {
# One transaction should be in flight.
# socketRdState, socketWrQueue are used.
# socketRdQueue should be empty.
- # Report any inconsistency of $tokenArg with socket*state.
- if {$tokenArg ne $socketRdState($stateArg(socketinfo))} {
- Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
- ne socketRdState($stateArg(socketinfo)) \
- $socketRdState($stateArg(socketinfo))
+ # Report any inconsistency of $token with socket*state.
+ if {$token ne $socketRdState($state(socketinfo))} {
+ Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+ ne socketRdState($state(socketinfo)) \
+ $socketRdState($state(socketinfo))
}
# Report the inconsistency that socketRdQueue is non-empty.
- if { [info exists socketRdQueue($stateArg(socketinfo))]
- && ($socketRdQueue($stateArg(socketinfo)) ne {})
+ if { [info exists socketRdQueue($state(socketinfo))]
+ && ($socketRdQueue($state(socketinfo)) ne {})
} {
- Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
- has read queue socketRdQueue($stateArg(socketinfo)) \
- $socketRdQueue($stateArg(socketinfo)) ne {}
+ Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+ has read queue socketRdQueue($state(socketinfo)) \
+ $socketRdQueue($state(socketinfo)) ne {}
}
- lappend InFlightW $socketRdState($stateArg(socketinfo))
- set socketRdQueue($stateArg(socketinfo)) {}
+ lappend InFlightW $socketRdState($state(socketinfo))
+ set socketRdQueue($state(socketinfo)) {}
}
set newQueue {}
lappend newQueue {*}$InFlightR
- lappend newQueue {*}$socketRdQueue($stateArg(socketinfo))
+ lappend newQueue {*}$socketRdQueue($state(socketinfo))
lappend newQueue {*}$InFlightW
- lappend newQueue {*}$socketWrQueue($stateArg(socketinfo))
+ lappend newQueue {*}$socketWrQueue($state(socketinfo))
- # 2. Tidy up tokenArg. This is a cut-down form of Finish/CloseSocket.
+ # 2. Tidy up token. This is a cut-down form of Finish/CloseSocket.
# Do not change state(status).
- # No need to after cancel stateArg(after) - either this is done in
+ # No need to after cancel state(after) - either this is done in
# ReplayCore/ReInit, or Finish is called.
- catch {close $stateArg(sock)}
+ catch {close $state(sock)}
+ Unset $state(socketinfo)
# 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit.
# - Transactions, if any, that are awaiting responses cannot be completed.
@@ -2078,6 +2759,7 @@ proc http::ReplayIfDead {tokenArg doing} {
# to new values in ReplayCore.
ReplayCore $newQueue
+ return
}
# http::ReplayIfClose --
@@ -2108,7 +2790,7 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
if {$Wstate ni {Wready peNding}} {
lappend InFlightW $Wstate
}
-
+ ##Log $Rqueue -- $InFlightW -- $Wqueue
set newQueue {}
lappend newQueue {*}$Rqueue
lappend newQueue {*}$InFlightW
@@ -2117,6 +2799,7 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
# 2. Cleanup - none needed, done by the caller.
ReplayCore $newQueue
+ return
}
# http::ReInit --
@@ -2160,6 +2843,11 @@ proc http::ReInit {token} {
after cancel $state(after)
unset state(after)
}
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (ReInit)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
+ }
# Don't alter state(status) - this would trigger http::wait if it is in use.
set tmpState $state(tmpState)
@@ -2199,13 +2887,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.
@@ -2237,92 +2929,30 @@ 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
- Finish $token {cannot send this request again}
+ Finish $tok {cannot send this request again}
}
}
- # 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":""}]
-
- # 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
+ AsyncTransaction $token
- # Connect does its own fconfigure.
- fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs]
- #Log ---- $sock << conn to $token for HTTP request (e)
+ return
}
# Data access functions:
@@ -2331,7 +2961,7 @@ proc http::ReplayCore {newQueue} {
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data
-proc http::data {token} {
+proc http::responseBody {token} {
variable $token
upvar 0 $token state
return $state(body)
@@ -2344,12 +2974,17 @@ proc http::status {token} {
upvar 0 $token state
return $state(status)
}
-proc http::code {token} {
+proc http::responseLine {token} {
variable $token
upvar 0 $token state
return $state(http)
}
-proc http::ncode {token} {
+proc http::requestLine {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(requestLine)
+}
+proc http::responseCode {token} {
variable $token
upvar 0 $token state
if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
@@ -2363,10 +2998,133 @@ proc http::size {token} {
upvar 0 $token state
return $state(currentsize)
}
-proc http::meta {token} {
+proc http::requestHeaders {token args} {
+ set lenny [llength $args]
+ if {$lenny > 1} {
+ return -code error {usage: ::http::requestHeaders token ?headerName?}
+ } else {
+ return [Meta $token request {*}$args]
+ }
+}
+proc http::responseHeaders {token args} {
+ set lenny [llength $args]
+ if {$lenny > 1} {
+ return -code error {usage: ::http::responseHeaders token ?headerName?}
+ } else {
+ return [Meta $token response {*}$args]
+ }
+}
+proc http::requestHeaderValue {token header} {
+ Meta $token request $header VALUE
+}
+proc http::responseHeaderValue {token header} {
+ Meta $token response $header VALUE
+}
+proc http::Meta {token who args} {
variable $token
upvar 0 $token state
- return $state(meta)
+
+ if {$who eq {request}} {
+ set whom requestHeaders
+ } elseif {$who eq {response}} {
+ set whom meta
+ } else {
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ }
+
+ set header [string tolower [lindex $args 0]]
+ set how [string tolower [lindex $args 1]]
+ set lenny [llength $args]
+ if {$lenny == 0} {
+ return $state($whom)
+ } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ } else {
+ set result {}
+ set combined {}
+ foreach {key value} $state($whom) {
+ if {$key eq $header} {
+ lappend result $key $value
+ append combined $value {, }
+ }
+ }
+ if {$lenny == 1} {
+ return $result
+ } else {
+ return [string range $combined 0 end-2]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::responseInfo
+# ------------------------------------------------------------------------------
+# Command to return a dictionary of the most useful metadata of a HTTP
+# response.
+#
+# Arguments:
+# token - connection token (name of an array)
+#
+# Return Value: a dict. See man page http(n) for a description of each item.
+# ------------------------------------------------------------------------------
+
+proc http::responseInfo {token} {
+ variable $token
+ upvar 0 $token state
+ set result {}
+ foreach {key origin name} {
+ stage STATE state
+ status STATE status
+ responseCode STATE responseCode
+ reasonPhrase STATE reasonPhrase
+ contentType STATE type
+ binary STATE binary
+ redirection RESP location
+ upgrade STATE upgrade
+ error ERROR -
+ postError STATE posterror
+ method STATE method
+ charset STATE charset
+ compression STATE coding
+ httpRequest STATE -protocol
+ httpResponse STATE httpResponse
+ url STATE url
+ connectionRequest REQ connection
+ connectionResponse RESP connection
+ connectionActual STATE connection
+ transferEncoding STATE transfer
+ totalPost STATE querylength
+ currentPost STATE queryoffset
+ totalSize STATE totalsize
+ currentSize STATE currentsize
+ } {
+ if {$origin eq {STATE}} {
+ if {[info exists state($name)]} {
+ dict set result $key $state($name)
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ } elseif {$origin eq {REQ}} {
+ dict set result $key [requestHeaderValue $token $name]
+ } elseif {$origin eq {RESP}} {
+ dict set result $key [responseHeaderValue $token $name]
+ } elseif {$origin eq {ERROR}} {
+ # Don't flood the dict with data. The command ::http::error is
+ # available.
+ if {[info exists state(error)]} {
+ set msg [lindex $state(error) 0]
+ } else {
+ set msg {}
+ }
+ dict set result $key $msg
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ }
+ return $result
}
proc http::error {token} {
variable $token
@@ -2374,7 +3132,15 @@ proc http::error {token} {
if {[info exists state(error)]} {
return $state(error)
}
- return ""
+ return
+}
+proc http::postError {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(postErrorFull)]} {
+ return $state(postErrorFull)
+ }
+ return
}
# http::cleanup
@@ -2390,16 +3156,25 @@ proc http::error {token} {
proc http::cleanup {token} {
variable $token
upvar 0 $token state
- if {[info commands ${token}EventCoroutine] ne {}} {
- rename ${token}EventCoroutine {}
+ 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)
}
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (cleanup)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
+ }
if {[info exists state]} {
unset state
}
+ return
}
# http::Connect
@@ -2417,11 +3192,20 @@ proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
- set err "due to unexpected EOF"
- if {
- [eof $state(sock)] ||
- [set err [fconfigure $state(sock) -error]] ne ""
- } {
+
+ if {[catch {eof $state(sock)} tmp] || $tmp} {
+ set err "due to unexpected EOF"
+ } elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
+ # set err is done in test
+ } else {
+ # All OK
+ set state(state) connecting
+ fileevent $state(sock) writable {}
+ ::http::Connected $token $proto $phost $srvurl
+ return
+ }
+
+ # Error cases.
Log "WARNING - if testing, pay special attention to this\
case (GJ) which is seldom executed - token $token"
if {[info exists state(reusing)] && $state(reusing)} {
@@ -2438,11 +3222,7 @@ proc http::Connect {token proto phost srvurl} {
# be discarded.
}
Finish $token "connect failed $err"
- } else {
- set state(state) connecting
- fileevent $state(sock) writable {}
- ::http::Connected $token $proto $phost $srvurl
- }
+ return
}
# http::Write
@@ -2462,8 +3242,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
@@ -2524,11 +3306,13 @@ proc http::Write {token} {
set done 1
}
}
- } err]} {
+ } err opts]} {
# Do not call Finish here, but instead let the read half of the socket
# process whatever server reply there is to get.
-
set state(posterror) $err
+ set info [dict get $opts -errorinfo]
+ set code [dict get $opts -code]
+ set state(postErrorFull) [list $err $info $code]
set done 1
}
@@ -2544,15 +3328,16 @@ proc http::Write {token} {
# Callback to the client after we've completely handled everything.
if {[string length $state(-queryprogress)]} {
- eval $state(-queryprogress) \
+ namespace eval :: $state(-queryprogress) \
[list $token $state(querylength) $state(queryoffset)]
}
+ return
}
# http::Event
#
# Handle input on the socket. This command is the core of
-# the coroutine commands ${token}EventCoroutine that are
+# the coroutine commands ${token}--EventCoroutine that are
# bound to "fileevent $sock readable" and process input.
#
# Arguments
@@ -2569,8 +3354,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
@@ -2581,15 +3368,18 @@ proc http::Event {sock token} {
if {![info exists state]} {
Log "Event $sock with invalid token '$token' - remote close?"
- if {![eof $sock]} {
+ if {!([catch {eof $sock} tmp] || $tmp)} {
if {[set d [read $sock]] ne ""} {
Log "WARNING: additional data left on closed socket\
- token $token"
+ } else {
}
+ } else {
}
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
return
+ } else {
}
if {$state(state) eq "connecting"} {
##Log - connecting - token $token
@@ -2600,6 +3390,7 @@ proc http::Event {sock token} {
} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
+ } else {
}
if {[catch {gets $sock state(http)} nsl]} {
@@ -2611,8 +3402,8 @@ proc http::Event {sock token} {
if {[TestForReplay $token read $nsl c]} {
return
+ } else {
}
-
# else:
# This is NOT a persistent socket that has been closed since
# its last use.
@@ -2626,7 +3417,7 @@ proc http::Event {sock token} {
} elseif {$nsl >= 0} {
##Log - connecting 1 - token $token
set state(state) "header"
- } elseif { [eof $sock]
+ } elseif { ([catch {eof $sock} tmp] || $tmp)
&& [info exists state(reusing)]
&& $state(reusing)
} {
@@ -2636,6 +3427,7 @@ proc http::Event {sock token} {
if {[TestForReplay $token read {} d]} {
return
+ } else {
}
# else:
@@ -2643,6 +3435,7 @@ proc http::Event {sock token} {
# last use.
# If any other requests are in flight or pipelined/queued, they
# will be discarded.
+ } else {
}
} elseif {$state(state) eq "header"} {
if {[catch {gets $sock line} nhl]} {
@@ -2661,6 +3454,20 @@ proc http::Event {sock token} {
set state(state) "connecting"
continue
# This was a "return" in the pre-coroutine code.
+ } else {
+ }
+
+ # We have $state(http) so let's split it into its components.
+ if {[regexp {^HTTP/(\S+) ([0-9]{3}) (.*)$} $state(http) \
+ -> httpResponse responseCode reasonPhrase]
+ } {
+ set state(httpResponse) $httpResponse
+ set state(responseCode) $responseCode
+ set state(reasonPhrase) $reasonPhrase
+ } else {
+ set state(httpResponse) $state(http)
+ set state(responseCode) $state(http)
+ set state(reasonPhrase) $state(http)
}
if { ([info exists state(connection)])
@@ -2676,6 +3483,7 @@ proc http::Event {sock token} {
# Previous value is $token. It cannot be "pending".
set socketWrState($state(socketinfo)) Wready
http::NextPipelinedWrite $token
+ } else {
}
# Once a "close" has been signaled, the client MUST NOT send any
@@ -2694,6 +3502,21 @@ proc http::Event {sock token} {
# response.
##Log WARNING - socket will close after response for $token
# Prepare data for a call to ReplayIfClose.
+ Log $token socket will close after this transaction
+ # 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
+ unset -nocomplain ${tok}(socketcoro)
+ after cancel $can
+ Log $tok Cancel socket after-idle event (Event)
+ Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro
+ }
+ set socketCoEvent($state(socketinfo)) {}
+ } else {
+ }
+
if { ($socketRdQueue($state(socketinfo)) ne {})
|| ($socketWrQueue($state(socketinfo)) ne {})
|| ($socketWrState($state(socketinfo)) ni
@@ -2706,7 +3529,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)) \
@@ -2721,16 +3543,20 @@ proc http::Event {sock token} {
if {[info exists ${tokenVal}(after)]} {
after cancel [set ${tokenVal}(after)]
unset ${tokenVal}(after)
+ } else {
}
+ # Tokens in the read queue have no (socketcoro) to
+ # cancel.
}
-
} else {
set socketPlayCmd($state(socketinfo)) \
{ReplayIfClose Wready {} {}}
}
- # Do not allow further connections on this socket.
+ # Do not allow further connections on this socket (but
+ # geturl can add new requests to the replay).
set socketClosing($state(socketinfo)) 1
+ } else {
}
set state(state) body
@@ -2746,6 +3572,7 @@ proc http::Event {sock token} {
&& ("keep-alive" ni $state(connection))
} {
lappend state(connection) "keep-alive"
+ } else {
}
# If doing a HEAD, then we won't get any body
@@ -2754,6 +3581,7 @@ proc http::Event {sock token} {
set state(state) complete
Eot $token
return
+ } else {
}
# - For non-chunked transfer we may have no body - in this case
@@ -2774,7 +3602,7 @@ proc http::Event {sock token} {
&& ("close" in $state(connection))
)
)
- && (![info exists state(transfer)])
+ && ($state(transfer) eq {})
&& ($state(totalsize) == 0)
} {
set msg {body size is 0 and no events likely - complete}
@@ -2784,6 +3612,7 @@ proc http::Event {sock token} {
set state(state) complete
Eot $token
return
+ } else {
}
# We have to use binary translation to count bytes properly.
@@ -2795,24 +3624,29 @@ proc http::Event {sock token} {
} {
# Turn off conversions for non-text data.
set state(binary) 1
+ } else {
}
if {[info exists state(-channel)]} {
if {$state(binary) || [llength [ContentEncoding $token]]} {
fconfigure $state(-channel) -translation binary
+ } else {
}
if {![info exists state(-handler)]} {
# Initiate a sequence of background fcopies.
fileevent $sock readable {}
- rename ${token}EventCoroutine {}
+ rename ${token}--EventCoroutine {}
CopyStart $sock $token
return
+ } else {
}
+ } else {
}
} elseif {$nhl > 0} {
# Process header lines.
##Log header - token $token - $line
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
- switch -- [string tolower $key] {
+ set key [string tolower $key]
+ switch -- $key {
content-type {
set state(type) [string trim [string tolower $value]]
# Grab the optional charset information.
@@ -2839,6 +3673,12 @@ proc http::Event {sock token} {
connection {
# RFC 7230 Section 6.1 states that a comma-separated
# list is an acceptable value.
+ if {![info exists state(connectionRespFlag)]} {
+ # This is the first "Connection" response header.
+ # Scrub the earlier value set by iniitialisation.
+ set state(connectionRespFlag) {}
+ set state(connection) {}
+ }
foreach el [SplitCommaSeparatedFieldValue $value] {
lappend state(connection) [string tolower $el]
}
@@ -2849,18 +3689,21 @@ proc http::Event {sock token} {
set-cookie {
if {$http(-cookiejar) ne ""} {
ParseCookie $token [string trim $value]
+ } else {
}
}
}
lappend state(meta) $key [string trim $value]
+ } else {
}
+ } else {
}
} else {
# Now reading body
##Log body - token $token
if {[catch {
if {[info exists state(-handler)]} {
- set n [eval $state(-handler) [list $sock $token]]
+ set n [namespace eval :: $state(-handler) [list $sock $token]]
##Log handler $n - token $token
# N.B. the protocol has been set to 1.0 because the -handler
# logic is not expected to handle chunked encoding.
@@ -2869,6 +3712,7 @@ proc http::Event {sock token} {
# We know the transfer is complete only when the server
# closes the connection - i.e. eof is not an error.
set state(state) complete
+ } else {
}
if {![string is integer -strict $n]} {
if 1 {
@@ -2898,10 +3742,11 @@ proc http::Event {sock token} {
set n 0
set state(state) complete
}
+ } else {
}
} elseif {[info exists state(transfer_final)]} {
# This code forgives EOF in place of the final CRLF.
- set line [getTextLine $sock]
+ set line [GetTextLine $sock]
set n [string length $line]
set state(state) complete
if {$n > 0} {
@@ -2924,7 +3769,7 @@ proc http::Event {sock token} {
} {
##Log chunked - token $token
set size 0
- set hexLenChunk [getTextLine $sock]
+ set hexLenChunk [GetTextLine $sock]
#set ntl [string length $hexLenChunk]
if {[string trim $hexLenChunk] ne ""} {
scan $hexLenChunk %x size
@@ -2937,6 +3782,7 @@ proc http::Event {sock token} {
incr state(log_size) [string length $chunk]
##Log chunk $n cumul $state(log_size) -\
token $token
+ } else {
}
if {$size != [string length $chunk]} {
Log "WARNING: mis-sized chunk:\
@@ -2949,10 +3795,11 @@ proc http::Event {sock token} {
set msg {error in chunked encoding - fetch\
terminated}
Eot $token $msg
+ } else {
}
# CRLF that follows chunk.
# If eof, this is handled at the end of this proc.
- getTextLine $sock
+ GetTextLine $sock
} else {
set n 0
set state(transfer_final) {}
@@ -2996,6 +3843,7 @@ proc http::Event {sock token} {
append state(body) $block
##Log non-chunk [string length $state(body)] -\
token $token
+ } else {
}
}
# This calculation uses n from the -handler, chunked, or
@@ -3007,6 +3855,7 @@ proc http::Event {sock token} {
set t $state(totalsize)
##Log another $n currentsize $c totalsize $t -\
token $token
+ } else {
}
# If Content-Length - check for end of data.
if {
@@ -3017,7 +3866,9 @@ proc http::Event {sock token} {
token $token
set state(state) complete
Eot $token
+ } else {
}
+ } else {
}
} err]} {
Log ^X$tk end of response (error ${err}) - token $token
@@ -3025,15 +3876,17 @@ proc http::Event {sock token} {
return
} else {
if {[info exists state(-progress)]} {
- eval $state(-progress) \
+ namespace eval :: $state(-progress) \
[list $token $state(totalsize) $state(currentsize)]
+ } else {
}
}
}
# catch as an Eot above may have closed the socket already
# $state(state) may be connecting, header, body, or complete
- if {![set cc [catch {eof $sock} eof]] && $eof} {
+ if {(![catch {eof $sock} eof]) && $eof} {
+ # [eof sock] succeeded and the result was 1
##Log eof - token $token
if {[info exists $token]} {
set state(connection) close
@@ -3055,10 +3908,12 @@ proc http::Event {sock token} {
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
}
- } elseif {$cc} {
- return
+ } else {
+ # EITHER [eof sock] failed - presumed done by Eot
+ # OR [eof sock] succeeded and the result was 0
}
}
+ return
}
# http::TestForReplay
@@ -3225,10 +4080,11 @@ proc http::ParseCookie {token value} {
{*}$http(-cookiejar) storeCookie $realopts
}
-# http::getTextLine --
+# http::GetTextLine --
#
# Get one line with the stream in crlf mode.
-# Used if Transfer-Encoding is chunked.
+# Used if Transfer-Encoding is chunked, to read the line that
+# reports the size of the following chunk.
# Empty line is not distinguished from eof. The caller must
# be able to handle this.
#
@@ -3238,7 +4094,7 @@ proc http::ParseCookie {token value} {
# Results:
# The line of text, without trailing newline
-proc http::getTextLine {sock} {
+proc http::GetTextLine {sock} {
set tr [fconfigure $sock -translation]
lassign $tr trRead trWrite
fconfigure $sock -translation [list crlf $trWrite]
@@ -3251,6 +4107,8 @@ proc http::getTextLine {sock} {
#
# Replacement for a blocking read.
# The caller must be a coroutine.
+# Used when we expect to read a chunked-encoding
+# chunk of known size.
proc http::BlockingRead {sock size} {
if {$size < 1} {
@@ -3260,7 +4118,7 @@ proc http::BlockingRead {sock size} {
while 1 {
set need [expr {$size - [string length $result]}]
set block [read $sock $need]
- set eof [eof $sock]
+ set eof [expr {[catch {eof $sock} tmp] || $tmp}]
append result $block
if {[string length $result] >= $size || $eof} {
return $result
@@ -3280,7 +4138,7 @@ proc http::BlockingRead {sock size} {
proc http::BlockingGets {sock} {
while 1 {
set count [gets $sock line]
- set eof [eof $sock]
+ set eof [expr {[catch {eof $sock} tmp] || $tmp}]
if {$count >= 0 || $eof} {
return $line
} else {
@@ -3301,16 +4159,28 @@ proc http::BlockingGets {sock} {
# This closes the connection upon error
proc http::CopyStart {sock token {initial 1}} {
- upvar #0 $token state
+ upvar 0 $token state
if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
foreach coding [ContentEncoding $token] {
- lappend state(zlib) [zlib stream $coding]
+ if {$coding eq {deflateX}} {
+ # Use the standards-compliant choice.
+ set coding2 decompress
+ } else {
+ set coding2 $coding
+ }
+ lappend state(zlib) [zlib stream $coding2]
}
- make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
+ MakeTransformationChunked $sock [namespace code [list CopyChunk $token]]
} else {
if {$initial} {
foreach coding [ContentEncoding $token] {
- zlib push $coding $sock
+ if {$coding eq {deflateX}} {
+ # Use the standards-compliant choice.
+ set coding2 decompress
+ } else {
+ set coding2 $coding
+ }
+ zlib push $coding2 $sock
}
}
if {[catch {
@@ -3324,6 +4194,7 @@ proc http::CopyStart {sock token {initial 1}} {
Finish $token $err
}
}
+ return
}
proc http::CopyChunk {token chunk} {
@@ -3337,7 +4208,7 @@ proc http::CopyChunk {token chunk} {
}
puts -nonewline $state(-channel) $chunk
if {[info exists state(-progress)]} {
- eval [linsert $state(-progress) end \
+ namespace eval :: [linsert $state(-progress) end \
$token $state(totalsize) $state(currentsize)]
}
} else {
@@ -3345,7 +4216,12 @@ proc http::CopyChunk {token chunk} {
if {[info exists state(zlib)]} {
set excess ""
foreach stream $state(zlib) {
- catch {set excess [$stream add -finalize $excess]}
+ catch {
+ $stream put -finalize $excess
+ set excess ""
+ set overflood ""
+ while {[set overflood [$stream get]] ne ""} { append excess $overflood }
+ }
}
puts -nonewline $state(-channel) $excess
foreach stream $state(zlib) { $stream close }
@@ -3353,6 +4229,7 @@ proc http::CopyChunk {token chunk} {
}
Eot $token ;# FIX ME: pipelining.
}
+ return
}
# http::CopyDone
@@ -3372,7 +4249,7 @@ proc http::CopyDone {token count {error {}}} {
set sock $state(sock)
incr state(currentsize) $count
if {[info exists state(-progress)]} {
- eval $state(-progress) \
+ namespace eval :: $state(-progress) \
[list $token $state(totalsize) $state(currentsize)]
}
# At this point the token may have been reset.
@@ -3383,6 +4260,7 @@ proc http::CopyDone {token count {error {}}} {
} else {
CopyStart $sock $token 0
}
+ return
}
# http::Eot
@@ -3428,7 +4306,20 @@ proc http::Eot {token {reason {}}} {
if {[string length $state(body)] > 0} {
if {[catch {
foreach coding [ContentEncoding $token] {
- set state(body) [zlib $coding $state(body)]
+ if {$coding eq {deflateX}} {
+ # First try the standards-compliant choice.
+ set coding2 decompress
+ if {[catch {zlib $coding2 $state(body)} result]} {
+ # If that fails, try the MS non-compliant choice.
+ set coding2 inflate
+ set state(body) [zlib $coding2 $state(body)]
+ } else {
+ # error {failed at standards-compliant deflate}
+ set state(body) $result
+ }
+ } else {
+ set state(body) [zlib $coding $state(body)]
+ }
}
} err]} {
Log "error doing decompression for token $token: $err"
@@ -3450,10 +4341,92 @@ proc http::Eot {token {reason {}}} {
# Translate text line endings.
set state(body) [string map {\r\n \n \r \n} $state(body)]
}
+ if {[info exists state(-guesstype)] && $state(-guesstype)} {
+ GuessType $token
+ }
}
Finish $token $reason
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::GuessType
+# ------------------------------------------------------------------------------
+# Command to attempt limited analysis of a resource with undetermined
+# Content-Type, i.e. "application/octet-stream". This value can be set for two
+# reasons:
+# (a) by the server, in a Content-Type header
+# (b) by http::geturl, as the default value if the server does not supply a
+# Content-Type header.
+#
+# This command converts a resource if:
+# (1) it has type application/octet-stream
+# (2) it begins with an XML declaration "<?xml name="value" ... >?"
+# (3) one tag is named "encoding" and has a recognised value; or no "encoding"
+# tag exists (defaulting to utf-8)
+#
+# RFC 9110 Sec. 8.3 states:
+# "If a Content-Type header field is not present, the recipient MAY either
+# assume a media type of "application/octet-stream" ([RFC2046], Section 4.5.1)
+# or examine the data to determine its type."
+#
+# The RFC goes on to describe the pitfalls of "MIME sniffing", including
+# possible security risks.
+#
+# Arguments:
+# token - connection token
+#
+# Return Value: (boolean) true iff a change has been made
+# ------------------------------------------------------------------------------
+
+proc http::GuessType {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {$state(type) ne {application/octet-stream}} {
+ return 0
+ }
+
+ set body $state(body)
+ # e.g. {<?xml version="1.0" encoding="utf-8"?> ...}
+
+ if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
+ return 0
+ }
+ # e.g. {<?xml version="1.0" encoding="utf-8"?>}
+
+ set contents [regsub -- {[[:space:]]+} $match { }]
+ set contents [string range [string tolower $contents] 6 end-2]
+ # e.g. {version="1.0" encoding="utf-8"}
+ # without excess whitespace or upper-case letters
+
+ if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
+ return 0
+ }
+ # The application/xml default encoding:
+ set res utf-8
+
+ set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
+ foreach tag $tagList {
+ regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
+ if {$name eq {encoding}} {
+ set res $value
+ }
+ }
+ set enc [CharsetToEncoding $res]
+ if {$enc eq "binary"} {
+ return 0
+ }
+ set state(body) [encoding convertfrom $enc $state(body)]
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ set state(type) application/xml
+ set state(binary) 0
+ set state(charset) $res
+ return 1
}
+
# http::wait --
#
# See documentation for details.
@@ -3498,7 +4471,7 @@ proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
- append result $sep [mapReply $i]
+ append result $sep [quoteString $i]
if {$sep eq "="} {
set sep &
} else {
@@ -3508,7 +4481,7 @@ proc http::formatQuery {args} {
return $result
}
-# http::mapReply --
+# http::quoteString --
#
# Do x-www-urlencoded character mapping
#
@@ -3518,7 +4491,7 @@ proc http::formatQuery {args} {
# Results:
# The encoded string
-proc http::mapReply {string} {
+proc http::quoteString {string} {
variable http
variable formMap
@@ -3529,7 +4502,6 @@ proc http::mapReply {string} {
set string [encoding convertto $http(-urlencoding) $string]
return [string map $formMap $string]
}
-interp alias {} http::quoteString {} http::mapReply
# http::ProxyRequired --
# Default proxy filter.
@@ -3550,6 +4522,8 @@ proc http::ProxyRequired {host} {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
+ } else {
+ return
}
}
@@ -3595,16 +4569,41 @@ proc http::CharsetToEncoding {charset} {
}
}
+
+# ------------------------------------------------------------------------------
+# Proc http::ContentEncoding
+# ------------------------------------------------------------------------------
# Return the list of content-encoding transformations we need to do in order.
+#
+ # --------------------------------------------------------------------------
+ # Options for Accept-Encoding, Content-Encoding: the switch command
+ # --------------------------------------------------------------------------
+ # The symbol deflateX allows http to attempt both versions of "deflate",
+ # unless there is a -channel - for a -channel, only "decompress" is tried.
+ # Alternative/extra lines for switch:
+ # The standards-compliant version of "deflate" can be chosen with:
+ # deflate { lappend r decompress }
+ # The Microsoft non-compliant version of "deflate" can be chosen with:
+ # deflate { lappend r inflate }
+ # The previously used implementation of "compress", which appears to be
+ # incorrect and is rarely used by web servers, can be chosen with:
+ # compress - x-compress { lappend r decompress }
+ # --------------------------------------------------------------------------
+#
+# Arguments:
+# token - Connection token.
+#
+# Return Value: list
+# ------------------------------------------------------------------------------
+
proc http::ContentEncoding {token} {
upvar 0 $token state
set r {}
if {[info exists state(coding)]} {
foreach coding [split $state(coding) ,] {
switch -exact -- $coding {
- deflate { lappend r inflate }
+ deflate { lappend r deflateX }
gzip - x-gzip { lappend r gunzip }
- compress - x-compress { lappend r decompress }
identity {}
br {
return -code error\
@@ -3695,9 +4694,288 @@ proc http::GetFieldValue {headers fieldName} {
return $r
}
-proc http::make-transformation-chunked {chan command} {
+proc http::MakeTransformationChunked {chan command} {
coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
chan event $chan readable [namespace current]::dechunk$chan
+ return
+}
+
+interp alias {} http::data {} http::responseBody
+interp alias {} http::code {} http::responseLine
+interp alias {} http::mapReply {} http::quoteString
+interp alias {} http::meta {} http::responseHeaders
+interp alias {} http::metaValue {} http::responseHeaderValue
+interp alias {} http::ncode {} http::responseCode
+
+# ------------------------------------------------------------------------------
+# Proc http::socket
+# ------------------------------------------------------------------------------
+# This command is a drop-in replacement for ::socket.
+# Arguments and return value as for ::socket.
+#
+# Notes.
+# - http::socket is specified in place of ::socket by the definition of urlTypes
+# in the namespace header of this file (http.tcl).
+# - The command makes a simple call to ::socket unless the user has called
+# http::config to change the value of -threadlevel from the default value 0.
+# - For -threadlevel 1 or 2, if the Thread package is available, the command
+# waits in the event loop while the socket is opened in another thread. This
+# is a workaround for bug [824251] - it prevents http::geturl from blocking
+# the event loop if the DNS lookup or server connection is slow.
+# - FIXME Use a thread pool if connections are very frequent.
+# - FIXME The peer thread can transfer the socket only to the main interpreter
+# in the present thread. Therefore this code works only if this script runs
+# in the main interpreter. In a child interpreter, the parent must alias a
+# command to ::http::socket in the child, run http::socket in the parent,
+# and then transfer the socket to the child.
+# - The http::socket command is simple, and can easily be replaced with an
+# alternative command that uses a different technique to open a socket while
+# entering the event loop.
+# - Unexpected behaviour by thread::send -async (Thread 2.8.6).
+# An error in thread::send -async causes return of just the error message
+# (not the expected 3 elements), and raises a bgerror in the main thread.
+# Hence wrap the command with catch as a precaution.
+# ------------------------------------------------------------------------------
+
+proc http::socket {args} {
+ variable ThreadVar
+ variable ThreadCounter
+ variable http
+
+ LoadThreadIfNeeded
+
+ set targ [lsearch -exact $args -token]
+ if {$targ != -1} {
+ set token [lindex $args $targ+1]
+ set args [lreplace $args $targ $targ+1]
+ upvar 0 $token state
+ }
+
+ if {!$http(usingThread)} {
+ # Use plain "::socket". This is the default.
+ return [eval ::socket $args]
+ }
+
+ set defcmd ::socket
+ set sockargs $args
+ set script "
+ set code \[catch {
+ [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
+ [list ::SockInThread [thread::id] $defcmd $sockargs]
+ } result opts\]
+ list \$code \$opts \$result
+ "
+
+ set state(tid) [thread::create]
+ set varName ::http::ThreadVar([incr ThreadCounter])
+ thread::send -async $state(tid) $script $varName
+ Log >T Thread Start Wait $args -- coro [info coroutine] $varName
+ if {[info coroutine] ne {}} {
+ # All callers in the http package are coroutines launched by
+ # the event loop.
+ # The cwait command requires a coroutine because it yields
+ # to the caller; $varName is traced and the coroutine resumes
+ # when the variable is written.
+ cwait $varName
+ } else {
+ return -code error {code must run in a coroutine}
+ # For testing with a non-coroutine caller outside the http package.
+ # vwait $varName
+ }
+ Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
+ thread::release $state(tid)
+ set state(tid) {}
+ set result [set $varName]
+ unset $varName
+ if {(![string is list $result]) || ([llength $result] != 3)} {
+ return -code error "result from peer thread is not a list of\
+ length 3: it is \n$result"
+ }
+ lassign $result threadCode threadDict threadResult
+ if {($threadCode != 0)} {
+ # This is an error in thread::send. Return the lot.
+ return -options $threadDict -code error $threadResult
+ }
+
+ # Now the results of the catch in the peer thread.
+ lassign $threadResult catchCode errdict sock
+
+ if {($catchCode == 0) && ($sock ni [chan names])} {
+ return -code error {Transfer of socket from peer thread failed.\
+ Check that this script is not running in a child interpreter.}
+ }
+ return -options $errdict -code $catchCode $sock
+}
+
+# The commands below are dependencies of http::socket and
+# are not used elsewhere.
+
+# ------------------------------------------------------------------------------
+# Proc http::LoadThreadIfNeeded
+# ------------------------------------------------------------------------------
+# Command to load the Thread package if it is needed. If it is needed and not
+# loadable, the outcome depends on $http(-threadlevel):
+# value 0 => Thread package not required, no problem
+# value 1 => operate as if -threadlevel 0
+# value 2 => error return
+#
+# Arguments: none
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::LoadThreadIfNeeded {} {
+ variable http
+ if {$http(usingThread) || ($http(-threadlevel) == 0)} {
+ return
+ }
+ if {[catch {package require Thread}]} {
+ if {$http(-threadlevel) == 2} {
+ set msg {[http::config -threadlevel] has value 2,\
+ but the Thread package is not available}
+ return -code error $msg
+ }
+ return
+ }
+ set http(usingThread) 1
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SockInThread
+# ------------------------------------------------------------------------------
+# Command http::socket is a ::socket replacement. It defines and runs this
+# command, http::SockInThread, in a peer thread.
+#
+# Arguments:
+# caller
+# defcmd
+# sockargs
+#
+# Return value: list of values that describe the outcome. The return is
+# intended to be a normal (non-error) return in all cases.
+# ------------------------------------------------------------------------------
+
+proc http::SockInThread {caller defcmd sockargs} {
+ package require Thread
+
+ set catchCode [catch {eval $defcmd $sockargs} sock errdict]
+ if {$catchCode == 0} {
+ set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
+ }
+ return [list $catchCode $errdict $sock]
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::cwaiter::cwait
+# ------------------------------------------------------------------------------
+# Command to substitute for vwait, without the ordering issues.
+# A command that uses cwait must be a coroutine that is launched by an event,
+# e.g. fileevent or after idle, and has no calling code to be resumed upon
+# "yield". It cannot return a value.
+#
+# Arguments:
+# varName - fully-qualified name of the variable that the calling script
+# will write to resume the coroutine. Any scalar variable or
+# array element is permitted.
+# coroName - (optional) name of the coroutine to be called when varName is
+# written - defaults to this coroutine
+# timeout - (optional) timeout value in ms
+# timeoutValue - (optional) value to assign to varName if there is a timeout
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+namespace eval http::cwaiter {
+ namespace export cwait
+ variable log {}
+ variable logOn 0
+}
+
+proc http::cwaiter::cwait {
+ varName {coroName {}} {timeout {}} {timeoutValue {}}
+} {
+ set thisCoro [info coroutine]
+ if {$thisCoro eq {}} {
+ return -code error {cwait cannot be called outside a coroutine}
+ }
+ if {$coroName eq {}} {
+ set coroName $thisCoro
+ }
+ if {[string range $varName 0 1] ne {::}} {
+ return -code error {argument varName must be fully qualified}
+ }
+ if {$timeout eq {}} {
+ set toe {}
+ } elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
+ set toe [after $timeout [list set $varName $timeoutValue]]
+ } else {
+ return -code error {if timeout is supplied it must be a positive integer}
+ }
+
+ set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
+ trace add variable $varName write $cmd
+ CoLog "Yield $varName $coroName"
+ yield
+ CoLog "Resume $varName $coroName"
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::cwaiter::CwaitHelper
+# ------------------------------------------------------------------------------
+# Helper command called by the trace set by cwait.
+# - Ignores the arguments added by trace.
+# - A simple call to $coroName works, and in error cases gives a suitable stack
+# trace, but because it is inside a trace the headline error message is
+# something like {can't set "::Result(6)": error}, not the actual
+# error. So let the trace command return.
+# - Remove the trace immediately. We don't want multiple calls.
+# ------------------------------------------------------------------------------
+
+proc http::cwaiter::CwaitHelper {varName coroName toe args} {
+ CoLog "got $varName for $coroName"
+ set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
+ trace remove variable $varName write $cmd
+ after cancel $toe
+
+ after 0 $coroName
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::cwaiter::LogInit
+# ------------------------------------------------------------------------------
+# Call this command to initiate debug logging and clear the log.
+# ------------------------------------------------------------------------------
+
+proc http::cwaiter::LogInit {} {
+ variable log
+ variable logOn
+ set log {}
+ set logOn 1
+ return
+}
+
+proc http::cwaiter::LogRead {} {
+ variable log
+ return $log
+}
+
+proc http::cwaiter::CoLog {msg} {
+ variable log
+ variable logOn
+ if {$logOn} {
+ append log $msg \n
+ }
+ return
+}
+
+namespace eval http {
+ namespace import ::http::cwaiter::*
}
# Local variables:
generated by cgit v0.12 at 2024-10-20 19:30:38 (GMT)