summaryrefslogtreecommitdiffstats
path: root/library/http
diff options
context:
space:
mode:
Diffstat (limited to 'library/http')
-rw-r--r--library/http/http.tcl280
-rw-r--r--library/http/pkgIndex.tcl6
2 files changed, 160 insertions, 126 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl
index fa0425d..d57e3ce 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -8,10 +8,10 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require Tcl 8.4
+package require Tcl 8.6
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.7.10
+package provide http 2.8.5
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -25,7 +25,13 @@ namespace eval http {
-proxyfilter http::ProxyRequired
-urlencoding utf-8
}
- set http(-useragent) "Tcl http client package [package provide http]"
+ # We need a useragent string of this style or various servers will refuse to
+ # send us compressed content even when we ask for it. This follows the
+ # de-facto layout of user-agent strings in current browsers.
+ set http(-useragent) "Mozilla/5.0\
+ ([string totitle $::tcl_platform(platform)]; U;\
+ $::tcl_platform(os) $::tcl_platform(osVersion))\
+ http/[package provide http] Tcl/[package provide Tcl]"
}
proc init {} {
@@ -92,7 +98,7 @@ namespace eval http {
# Arguments:
# msg Message to output
#
-proc http::Log {args} {}
+if {[info command http::Log] eq {}} {proc http::Log {args} {}}
# http::register --
#
@@ -193,7 +199,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
if {
($state(status) eq "timeout") || ($state(status) eq "error") ||
([info exists state(connection)] && ($state(connection) eq "close"))
- } then {
+ } {
CloseSocket $state(sock) $token
}
if {[info exists state(after)]} {
@@ -359,7 +365,7 @@ proc http::geturl {url args} {
if {
[info exists type($flag)] &&
![string is $type($flag) -strict $value]
- } then {
+ } {
unset $token
return -code error \
"Bad value for $flag ($value), must be $type($flag)"
@@ -411,7 +417,6 @@ 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.
- # Also note that we do not currently support IPv6 addresses.
#
# 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
@@ -426,7 +431,10 @@ proc http::geturl {url args} {
[^@/\#?]+ # <userinfo part of authority>
) @
)?
- ( [^/:\#?]+ ) # <host part of authority>
+ ( # <host part of authority>
+ [^/:\#?]+ | # host name or IPv4 address
+ \[ [^/\#?]+ \] # IPv6 address in square brackets
+ )
(?: : (\d+) )? # <port part of authority>
)?
( / [^\#]*)? # <path> (including query)
@@ -440,6 +448,7 @@ proc http::geturl {url args} {
return -code error "Unsupported URL: $url"
}
# Phase two: validate
+ set host [string trim $host {[]}]; # strip square brackets from IPv6 address
if {$host eq ""} {
# Caller has to provide a host name; we do not have a "default host"
# that would enable us to handle relative URLs.
@@ -645,7 +654,11 @@ proc http::geturl {url args} {
if {[info exists state(-method)] && $state(-method) ne ""} {
set how $state(-method)
}
-
+ # We cannot handle chunked encodings with -handler, so force HTTP/1.0
+ # until we can manage this.
+ if {[info exists state(-handler)]} {
+ set state(-protocol) 1.0
+ }
if {[catch {
puts $sock "$how $srvurl HTTP/$state(-protocol)"
puts $sock "Accept: $http(-accept)"
@@ -693,14 +706,8 @@ proc http::geturl {url args} {
puts $sock "$key: $value"
}
}
- # Soft zlib dependency check - no package require
- if {
- !$accept_encoding_seen &&
- ([package vsatisfies [package provide Tcl] 8.6]
- || [llength [package provide zlib]]) &&
- !([info exists state(-channel)] || [info exists state(-handler)])
- } then {
- puts $sock "Accept-Encoding: gzip, identity, *;q=0.1"
+ if {!$accept_encoding_seen && ![info exists state(-handler)]} {
+ puts $sock "Accept-Encoding: deflate,gzip,compress"
}
if {$isQueryChannel && $state(querylength) == 0} {
# Try to determine size of data in channel. If we cannot seek, the
@@ -724,7 +731,7 @@ proc http::geturl {url args} {
# versions TclHttpd in various error cases). Depending on the
# platform, the client may or may not be able to get the response from
# the server because of the error it will get trying to write the post
- # data. Having both fileevents active changes the timing and the
+ # data. Having both fileevents active changes the timing and the
# behavior, but no two platforms (among Solaris, Linux, and NT) behave
# the same, and none behave all that well in any case. Servers should
# always read their POST data if they expect the client to read their
@@ -757,7 +764,7 @@ proc http::geturl {url args} {
return -code error [lindex $state(error) 0]
}
}
- } err]} then {
+ } err]} {
# The socket probably was never connected, or the connection dropped
# later.
@@ -865,7 +872,7 @@ proc http::Connect {token} {
if {
[eof $state(sock)] ||
[set err [fconfigure $state(sock) -error]] ne ""
- } then {
+ } {
Finish $token "connect failed $err" 1
} else {
set state(status) connect
@@ -916,7 +923,7 @@ proc http::Write {token} {
set done 1
}
}
- } err]} then {
+ } err]} {
# Do not call Finish here, but instead let the read half of the socket
# process whatever server reply there is to get.
@@ -995,7 +1002,7 @@ proc http::Event {sock token} {
&& ($state(connection) eq "close"))
|| [info exists state(transfer)])
&& ($state(totalsize) == 0)
- } then {
+ } {
Log "body size is 0 and no events likely - complete."
Eof $token
return
@@ -1006,26 +1013,20 @@ proc http::Event {sock token} {
if {
$state(-binary) || ![string match -nocase text* $state(type)]
- } then {
+ } {
# Turn off conversions for non-text data
set state(binary) 1
}
- if {
- $state(binary) || [string match *gzip* $state(coding)] ||
- [string match *compress* $state(coding)]
- } then {
- if {[info exists state(-channel)]} {
+ if {[info exists state(-channel)]} {
+ if {$state(binary) || [llength [ContentEncoding $token]]} {
fconfigure $state(-channel) -translation binary
}
- }
- if {
- [info exists state(-channel)] &&
- ![info exists state(-handler)]
- } then {
- # Initiate a sequence of background fcopies
- fileevent $sock readable {}
- CopyStart $sock $token
- return
+ if {![info exists state(-handler)]} {
+ # Initiate a sequence of background fcopies
+ fileevent $sock readable {}
+ CopyStart $sock $token
+ return
+ }
}
} elseif {$n > 0} {
# Process header lines
@@ -1080,7 +1081,7 @@ proc http::Event {sock token} {
} elseif {
[info exists state(transfer)]
&& $state(transfer) eq "chunked"
- } then {
+ } {
set size 0
set chunk [getTextLine $sock]
set n [string length $chunk]
@@ -1120,11 +1121,11 @@ proc http::Event {sock token} {
if {
($state(totalsize) > 0)
&& ($state(currentsize) >= $state(totalsize))
- } then {
+ } {
Eof $token
}
}
- } err]} then {
+ } err]} {
return [Finish $token $err]
} else {
if {[info exists state(-progress)]} {
@@ -1177,14 +1178,54 @@ proc http::getTextLine {sock} {
# Side Effects
# This closes the connection upon error
-proc http::CopyStart {sock token} {
- variable $token
+proc http::CopyStart {sock token {initial 1}} {
+ upvar #0 $token state
+ if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
+ foreach coding [ContentEncoding $token] {
+ lappend state(zlib) [zlib stream $coding]
+ }
+ make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
+ } else {
+ if {$initial} {
+ foreach coding [ContentEncoding $token] {
+ zlib push $coding $sock
+ }
+ }
+ if {[catch {
+ fcopy $sock $state(-channel) -size $state(-blocksize) -command \
+ [list http::CopyDone $token]
+ } err]} {
+ Finish $token $err
+ }
+ }
+}
+
+proc http::CopyChunk {token chunk} {
upvar 0 $token state
- if {[catch {
- fcopy $sock $state(-channel) -size $state(-blocksize) -command \
- [list http::CopyDone $token]
- } err]} then {
- Finish $token $err
+ if {[set count [string length $chunk]]} {
+ incr state(currentsize) $count
+ if {[info exists state(zlib)]} {
+ foreach stream $state(zlib) {
+ set chunk [$stream add $chunk]
+ }
+ }
+ puts -nonewline $state(-channel) $chunk
+ if {[info exists state(-progress)]} {
+ eval [linsert $state(-progress) end \
+ $token $state(totalsize) $state(currentsize)]
+ }
+ } else {
+ Log "CopyChunk Finish $token"
+ if {[info exists state(zlib)]} {
+ set excess ""
+ foreach stream $state(zlib) {
+ catch {set excess [$stream add -finalize $excess]}
+ }
+ puts -nonewline $state(-channel) $excess
+ foreach stream $state(zlib) { $stream close }
+ unset state(zlib)
+ }
+ Eof $token ;# FIX ME: pipelining.
}
}
@@ -1214,7 +1255,7 @@ proc http::CopyDone {token count {error {}}} {
} elseif {[catch {eof $sock} iseof] || $iseof} {
Eof $token
} else {
- CopyStart $sock $token
+ CopyStart $sock $token 0
}
}
@@ -1238,34 +1279,31 @@ proc http::Eof {token {force 0}} {
set state(status) ok
}
- if {($state(coding) eq "gzip") && [string length $state(body)] > 0} {
- if {[catch {
- if {[package vsatisfies [package present Tcl] 8.6]} {
- # The zlib integration into 8.6 includes proper gzip support
- set state(body) [zlib gunzip $state(body)]
- } else {
- set state(body) [Gunzip $state(body)]
+ if {[string length $state(body)] > 0} {
+ if {[catch {
+ foreach coding [ContentEncoding $token] {
+ set state(body) [zlib $coding $state(body)]
}
- } err]} then {
+ } err]} {
+ Log "error doing $coding '$state(body)'"
return [Finish $token $err]
- }
- }
+ }
- if {!$state(binary)} {
- # If we are getting text, set the incoming channel's encoding
- # correctly. iso8859-1 is the RFC default, but this could be any IANA
- # charset. However, we only know how to convert what we have
- # encodings for.
+ if {!$state(binary)} {
+ # If we are getting text, set the incoming channel's encoding
+ # correctly. iso8859-1 is the RFC default, but this could be any IANA
+ # charset. However, we only know how to convert what we have
+ # encodings for.
- set enc [CharsetToEncoding $state(charset)]
- if {$enc ne "binary"} {
- set state(body) [encoding convertfrom $enc $state(body)]
- }
+ set enc [CharsetToEncoding $state(charset)]
+ if {$enc ne "binary"} {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
- # Translate text line endings.
- set state(body) [string map {\r\n \n \r \n} $state(body)]
+ # Translate text line endings.
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ }
}
-
Finish $token
}
@@ -1364,7 +1402,7 @@ proc http::ProxyRequired {host} {
if {
![info exists http(-proxyport)] ||
![string length $http(-proxyport)]
- } then {
+ } {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
@@ -1410,59 +1448,57 @@ proc http::CharsetToEncoding {charset} {
}
}
-# http::Gunzip --
-#
-# Decompress data transmitted using the gzip transfer coding.
-#
-
-# FIX ME: redo using zlib sinflate
-proc http::Gunzip {data} {
- binary scan $data Scb5icc magic method flags time xfl os
- set pos 10
- if {$magic != 0x1f8b} {
- return -code error "invalid data: supplied data is not in gzip format"
- }
- if {$method != 8} {
- return -code error "invalid compression method"
- }
-
- # lassign [split $flags ""] f_text f_crc f_extra f_name f_comment
- foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break
- set extra ""
- if {$f_extra} {
- binary scan $data @${pos}S xlen
- incr pos 2
- set extra [string range $data $pos $xlen]
- set pos [incr xlen]
- }
-
- set name ""
- if {$f_name} {
- set ndx [string first \0 $data $pos]
- set name [string range $data $pos $ndx]
- set pos [incr ndx]
- }
-
- set comment ""
- if {$f_comment} {
- set ndx [string first \0 $data $pos]
- set comment [string range $data $pos $ndx]
- set pos [incr ndx]
- }
-
- set fcrc ""
- if {$f_crc} {
- set fcrc [string range $data $pos [incr pos]]
- incr pos
+# Return the list of content-encoding transformations we need to do in order.
+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 }
+ gzip - x-gzip { lappend r gunzip }
+ compress - x-compress { lappend r decompress }
+ identity {}
+ default {
+ return -code error "unsupported content-encoding \"$coding\""
+ }
+ }
+ }
}
+ return $r
+}
- binary scan [string range $data end-7 end] ii crc size
- set inflated [zlib inflate [string range $data $pos end-8]]
- set chk [zlib crc32 $inflated]
- if {($crc & 0xffffffff) != ($chk & 0xffffffff)} {
- return -code error "invalid data: checksum mismatch $crc != $chk"
- }
- return $inflated
+proc http::make-transformation-chunked {chan command} {
+ set lambda {{chan command} {
+ set data ""
+ set size -1
+ yield
+ while {1} {
+ chan configure $chan -translation {crlf binary}
+ while {[gets $chan line] < 1} { yield }
+ chan configure $chan -translation {binary binary}
+ if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
+ set chunk ""
+ while {$size && ![chan eof $chan]} {
+ set part [chan read $chan $size]
+ incr size -[string length $part]
+ append chunk $part
+ }
+ if {[catch {
+ uplevel #0 [linsert $command end $chunk]
+ }]} {
+ http::Log "Error in callback: $::errorInfo"
+ }
+ if {[string length $chunk] == 0} {
+ # channel might have been closed in the callback
+ catch {chan event $chan readable {}}
+ return
+ }
+ }
+ }}
+ coroutine dechunk$chan ::apply $lambda $chan $command
+ chan event $chan readable [namespace origin dechunk$chan]
+ return
}
# Local variables:
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 0b5cdeb..303d3bd 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,4 +1,2 @@
-# Tcl package index file, version 1.1
-
-if {![package vsatisfies [package provide Tcl] 8.4]} {return}
-package ifneeded http 2.7.10 [list tclPkgSetup $dir http 2.7.10 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+if {![package vsatisfies [package provide Tcl] 8.6]} {return}
+package ifneeded http 2.8.5 [list tclPkgSetup $dir http 2.8.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]