summaryrefslogtreecommitdiffstats
path: root/library/http/http.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/http/http.tcl')
-rw-r--r--library/http/http.tcl66
1 files changed, 45 insertions, 21 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 3754f71..5a05fa0 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.6
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.8.7
+package provide http 2.8.9
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -113,7 +113,7 @@ if {[info command http::Log] eq {}} {proc http::Log {args} {}}
proc http::register {proto port command} {
variable urlTypes
- set urlTypes($proto) [list $port $command]
+ set urlTypes([string tolower $proto]) [list $port $command]
}
# http::unregister --
@@ -127,11 +127,12 @@ proc http::register {proto port command} {
proc http::unregister {proto} {
variable urlTypes
- if {![info exists urlTypes($proto)]} {
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
return -code error "unsupported url type \"$proto\""
}
- set old $urlTypes($proto)
- unset urlTypes($proto)
+ set old $urlTypes($lower)
+ unset urlTypes($lower)
return $old
}
@@ -514,12 +515,13 @@ proc http::geturl {url args} {
if {$proto eq ""} {
set proto http
}
- if {![info exists urlTypes($proto)]} {
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
unset $token
return -code error "Unsupported URL type \"$proto\""
}
- set defport [lindex $urlTypes($proto) 0]
- set defcmd [lindex $urlTypes($proto) 1]
+ set defport [lindex $urlTypes($lower) 0]
+ set defcmd [lindex $urlTypes($lower) 1]
if {$port eq ""} {
set port $defport
@@ -564,6 +566,10 @@ proc http::geturl {url args} {
# Proxy connections aren't shared among different hosts.
set state(socketinfo) $host:$port
+ # Save the accept types at this point to prevent a race condition. [Bug
+ # c11a51c482]
+ set state(accept-types) $http(-accept)
+
# See if we are supposed to use a previously opened channel.
if {$state(-keepalive)} {
variable socketmap
@@ -635,8 +641,20 @@ proc http::geturl {url args} {
return $token
}
+# http::Connected --
+#
+# Callback used when the connection to the HTTP server is actually
+# established.
+#
+# Arguments:
+# token State token.
+# proto What protocol (http, https, etc.) was used to connect.
+# phost Are we using keep-alive? Non-empty if yes.
+# srvurl Service-local URL that we're requesting
+# Results:
+# None.
-proc http::Connected { token proto phost srvurl} {
+proc http::Connected {token proto phost srvurl} {
variable http
variable urlTypes
@@ -650,7 +668,8 @@ proc http::Connected { token proto phost srvurl} {
set host [lindex [split $state(socketinfo) :] 0]
set port [lindex [split $state(socketinfo) :] 1]
- set defport [lindex $urlTypes($proto) 0]
+ set lower [string tolower $proto]
+ set defport [lindex $urlTypes($lower) 0]
# Send data in cr-lf format, but accept any line terminators
@@ -688,13 +707,12 @@ proc http::Connected { token proto phost srvurl} {
if {[info exists state(-handler)]} {
set state(-protocol) 1.0
}
+ set accept_types_seen 0
if {[catch {
puts $sock "$how $srvurl HTTP/$state(-protocol)"
- puts $sock "Accept: $http(-accept)"
- array set hdrs $state(-headers)
- if {[info exists hdrs(Host)]} {
+ if {[dict exists $state(-headers) Host]} {
# Allow Host spoofing. [Bug 928154]
- puts $sock "Host: $hdrs(Host)"
+ puts $sock "Host: [dict get $state(-headers) Host]"
} elseif {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# #504508]
@@ -702,7 +720,6 @@ proc http::Connected { token proto phost srvurl} {
} else {
puts $sock "Host: $host:$port"
}
- unset hdrs
puts $sock "User-Agent: $http(-useragent)"
if {$state(-protocol) == 1.0 && $state(-keepalive)} {
puts $sock "Connection: keep-alive"
@@ -715,18 +732,21 @@ proc http::Connected { token proto phost srvurl} {
}
set accept_encoding_seen 0
set content_type_seen 0
- foreach {key value} $state(-headers) {
+ dict for {key value} $state(-headers) {
+ set value [string map [list \n "" \r ""] $value]
+ set key [string map {" " -} [string trim $key]]
if {[string equal -nocase $key "host"]} {
continue
}
if {[string equal -nocase $key "accept-encoding"]} {
set accept_encoding_seen 1
}
+ if {[string equal -nocase $key "accept"]} {
+ set accept_types_seen 1
+ }
if {[string equal -nocase $key "content-type"]} {
set content_type_seen 1
}
- set value [string map [list \n "" \r ""] $value]
- set key [string trim $key]
if {[string equal -nocase $key "content-length"]} {
set contDone 1
set state(querylength) $value
@@ -735,8 +755,13 @@ proc http::Connected { token proto phost srvurl} {
puts $sock "$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)"
+ }
if {!$accept_encoding_seen && ![info exists state(-handler)]} {
- puts $sock "Accept-Encoding: deflate,gzip,compress"
+ puts $sock "Accept-Encoding: gzip,deflate,compress"
}
if {$isQueryChannel && $state(querylength) == 0} {
# Try to determine size of data in channel. If we cannot seek, the
@@ -792,7 +817,6 @@ proc http::Connected { token proto phost srvurl} {
Finish $token $err
}
}
-
}
# Data access functions:
@@ -1296,7 +1320,7 @@ proc http::Eof {token {force 0}} {
set state(body) [zlib $coding $state(body)]
}
} err]} {
- Log "error doing $coding '$state(body)'"
+ Log "error doing decompression: $err"
return [Finish $token $err]
}