diff options
| -rw-r--r-- | doc/http.n | 27 | ||||
| -rw-r--r-- | library/http/http.tcl | 300 | ||||
| -rw-r--r-- | tests/http.test | 49 | ||||
| -rw-r--r-- | tests/http11.test | 22 | ||||
| -rw-r--r-- | tests/httpPipeline.test | 26 |
5 files changed, 398 insertions, 26 deletions
@@ -173,6 +173,19 @@ retrying the POST. The value \fBtrue\fR should be used only under certain conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. .TP +\fB\-threadlevel\fR \fIlevel\fR +. +Specifies whether and how to use the \fBThread\fR package. Possible values of \fIlevel\fR are 0, 1 or 2. +.RS +.PP +.DS +0 - (the default) do not use Thread +1 - use Thread if it is available, do not use it if it is unavailable +2 - use Thread if it is available, raise an error if it is unavailable +.DE +The Tcl \fBsocket -async\fR command can block in adverse cases (e.g. a slow DNS lookup). Using the Thread package works around this problem, for both HTTP and HTTPS transactions. Values of \fIlevel\fR other than 0 are available only to the main interpreter in each thread. See section \fBTHREADS\fR for more information. +.RE +.TP \fB\-urlencoding\fR \fIencoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with @@ -986,6 +999,20 @@ the server response code is a 307 redirect, and the response header again in order to fetch this URL. See https://w3c.github.io/webappsec-upgrade-insecure-requests/ .PP +.SH THREADS +.PP +.SS "PURPOSE" +.PP +Command \fB::http::geturl\fR uses the Tcl \fB::socket\fR command with the \-async option to connect to a remote server, but the return from this command can be delayed in adverse cases (e.g. a slow DNS lookup), preventing the event loop from processing other events. This delay is avoided if the \fB::socket\fR command is evaluated in another thread. The Thread package is not part of Tcl but is provided in "Batteries Included" distributions. Instead of the \fB::socket\fR command, the http package uses \fB::http::socket\fR which makes connections in the manner specified by the value of \-threadlevel and the availability of package Thread. +.PP +.SS "WITH TLS (HTTPS)" +.PP +The same \-threadlevel configuration applies to both HTTP and HTTPS connections. HTTPS is enabled by using the \fBhttp::register\fR command, typically by specifying the \fB::tls::socket\fR command of the tls package to handle TLS cryptography. The \fB::tls::socket\fR command connects to the remote server by using the command specified by the value of variable \fI::tls::socketCmd\fR, and this value defaults to "::socket". If http::geturl finds that \fI::tls::socketCmd\fR has this value, it replaces it with the value "::http::socket". If \fI::tls::socketCmd\fR has a value other than "::socket", i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value. The script or installation that modified \fI::tls::socketCmd\fR is responsible for integrating \fR::http::socket\fR into its own replacement command. +.PP +.SS "WITH A CHILD INTERPRETER" +.PP +The peer thread can transfer the socket only to the main interpreter of the script's thread. Therefore the thread-based \fB::http::socket\fR works with non-zero \-threadlevel values only if the script runs in the main interpreter. A child interpreter must use \-threadlevel 0 unless the parent interpreter has provided alternative facilities. The main parent interpreter may grant full \-threadlevel facilities to a child interpreter, for example by aliasing, to \fB::http::socket\fR in the child, a command that runs \fBhttp::socket\fR in the parent, and then transfers the socket to the child. +.PP .SH EXAMPLE .PP This example creates a procedure to copy a URL to a file while printing a diff --git a/library/http/http.tcl b/library/http/http.tcl index c3679f1..01d3f8b 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 } @@ -113,7 +114,7 @@ namespace eval http { 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]] @@ -148,6 +149,7 @@ namespace eval http { } variable TmpSockCounter 0 + variable ThreadCounter 0 namespace export geturl config reset wait formatQuery quoteString namespace export register unregister registerError @@ -240,6 +242,9 @@ proc http::config {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 @@ -313,6 +318,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # 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 @@ -762,6 +775,24 @@ 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 @@ -810,6 +841,7 @@ proc http::geturl {url args} { # 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 @@ -834,6 +866,9 @@ proc http::CreateToken {url args} { # 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 } @@ -871,6 +906,7 @@ proc http::CreateToken {url args} { status "" http "" connection keep-alive + tid {} } set state(-keepalive) $defaultKeepalive set state(-strict) $strict @@ -1086,7 +1122,7 @@ proc http::CreateToken {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 # Proxy connections aren't shared among different hosts. @@ -1213,8 +1249,9 @@ proc http::CreateToken {url args} { lappend socketWrQueue($state(socketinfo)) $token ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo)) ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo)) - } elseif { [catch {fconfigure $socketMapping($state(socketinfo))}] - && (![SockIsPlaHolder $socketMapping($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 @@ -1237,7 +1274,7 @@ proc http::CreateToken {url args} { # - The socket may not yet exist, and be defined with a placeholder. set reusing 1 set sock $socketMapping($state(socketinfo)) - if {[SockIsPlaHolder $sock]} { + if {[SockIsPlaceHolder $sock]} { set state(ReusingPlaceholder) 1 lappend socketPhQueue($sock) $token } else { @@ -1272,7 +1309,7 @@ proc http::CreateToken {url args} { # ------------------------------------------------------------------------------ -# Proc ::http::SockIsPlaHolder +# 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 @@ -1284,7 +1321,7 @@ proc http::CreateToken {url args} { # Return Value: 0 or 1 # ------------------------------------------------------------------------------ -proc http::SockIsPlaHolder {sock} { +proc http::SockIsPlaceHolder {sock} { expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}} } @@ -4178,6 +4215,255 @@ proc http::make-transformation-chunked {chan command} { return } + +# ------------------------------------------------------------------------------ +# 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. +# ------------------------------------------------------------------------------ + +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 " + [list proc ::SockInThread {caller defcmd sockargs} [info body http::SockInThread]] + [list ::SockInThread [thread::id] $defcmd $sockargs] + " + + 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) {} + lassign [set $varName] catchCode errdict sock + unset $varName + dict set errdict -code $catchCode + return -options $errdict $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: # indent-tabs-mode: t # End: diff --git a/tests/http.test b/tests/http.test index 59078f2..26ba710 100644 --- a/tests/http.test +++ b/tests/http.test @@ -17,20 +17,7 @@ if {"::tcltest" ni [namespace children]} { } package require tcltests -if {[catch {package require http 2} version]} { - if {[info exists http2]} { - catch {puts "Cannot load http 2.* package"} - return - } else { - catch {puts "Running http 2.* tests in child interp"} - set interp [interp create http2] - $interp eval [list set http2 "running"] - $interp eval [list set argv $argv] - $interp eval [list source [info script]] - interp delete $interp - return - } -} +package require http 2.10 proc bgerror {args} { global errorInfo @@ -78,11 +65,31 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { return } } + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -97,10 +104,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1] test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} +} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { @@ -139,9 +146,11 @@ test http-2.8 {http::CharsetToEncoding} { test http-3.1 {http::geturl} -returnCodes error -body { http::geturl -bogus flag } -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} + test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} + set url //${::HOST}:$port set badurl //${::HOST}:[expr {$port+1}] test http-3.3 {http::geturl} -body { @@ -153,6 +162,7 @@ test http-3.3 {http::geturl} -body { <h1>Hello, World!</h1> <h2>GET /</h2> </body></html>" + set tail /a/b/c set url //${::HOST}:$port/a/b/c set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c @@ -162,6 +172,7 @@ set posturl //${::HOST}:$port/post set badposturl //${::HOST}:$port/droppost set authorityurl //${::HOST}:$port set ipv6url http://\[::1\]:$port/ + test http-3.4 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -572,6 +583,7 @@ test http-4.10 {http::Event} -body { } -cleanup { http::cleanup $token } -result {111} + # Timeout cases # Short timeout to working server (the test server). This lets us try a # reset during the connection. @@ -582,6 +594,7 @@ test http-4.11 {http::Event} -body { } -cleanup { http::cleanup $token } -result {reset} + # Longer timeout with reset. test http-4.12 {http::Event} -body { set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#] @@ -590,6 +603,7 @@ test http-4.12 {http::Event} -body { } -cleanup { http::cleanup $token } -result {reset} + # Medium timeout to working server that waits even longer. The timeout # hits while waiting for a reply. test http-4.13 {http::Event} -body { @@ -599,6 +613,7 @@ test http-4.13 {http::Event} -body { } -cleanup { http::cleanup $token } -result {timeout} + # Longer timeout to good host, bad port, gets an error after the # connection "completes" but the socket is bad. test http-4.14 {http::Event} -body { diff --git a/tests/http11.test b/tests/http11.test index 4f6fb92..346e334 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -package require http 2.9 +package require http 2.10 # start the server variable httpd_output @@ -87,6 +87,26 @@ proc check_crc {tok args} { } makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel # ------------------------------------------------------------------------- diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 4e55a10..161519f 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -13,7 +13,31 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -package require http 2.9 +package require http 2.10 + +# ------------------------------------------------------------------------------ +# (0) Socket Creation in Thread, which triples the number of tests. +# ------------------------------------------------------------------------------ + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] |