Posted to tcl by patthoyts at Fri Apr 10 01:04:29 GMT 2009view raw
- commit 09ff76b16e1dd98fe49c5db1496538aa20de02b6
- Author: Pat Thoyts <patthoyts@users.sourceforge.net>
- Date: Fri Apr 10 01:49:10 2009 +0100
- Improved HTTP/1.1 support and added specific HTTP/1.1 testing.
- This patch makes use of the 8.6 zlib support to provide for
- deflate and gzip support and handles the -channel option with
- compression and chunked transfer encoding. For the -handler
- option we currently disable HTTP/1.1 features as we cannot
- properly pass the data through to the caller.
- diff --git a/library/http/http.tcl b/library/http/http.tcl
- index 54732fd..1638109 100644
- --- a/library/http/http.tcl
- +++ b/library/http/http.tcl
- @@ -10,10 +10,10 @@
- #
- # RCS: @(#) $Id$
- -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.3
- +package provide http 2.8a1
- namespace eval http {
- # Allow resourcing to not clobber existing data
- @@ -27,7 +27,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 {} {
- @@ -94,7 +100,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 --
- #
- @@ -649,7 +655,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 +703,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
- @@ -1009,22 +1013,16 @@ proc http::Event {sock token} {
- # 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
- @@ -1170,14 +1168,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.
- }
- }
- @@ -1207,7 +1245,7 @@ proc http::CopyDone {token count {error {}}} {
- } elseif {[catch {eof $sock} iseof] || $iseof} {
- Eof $token
- } else {
- - CopyStart $sock $token
- + CopyStart $sock $token 0
- }
- }
- @@ -1231,34 +1269,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.
- -
- - 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)]
- + }
- +
- + 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)]
- + }
- +
- + # Translate text line endings.
- + set state(body) [string map {\r\n \n \r \n} $state(body)]
- + }
- }
- -
- Finish $token
- }
- @@ -1403,59 +1438,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]
- + }]} then {
- + 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 07724d3..1e27324 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.3 [list tclPkgSetup $dir http 2.7.3 {{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.8a1 [list tclPkgSetup $dir http 2.8a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
- diff --git a/tests/http11.test b/tests/http11.test
- new file mode 100644
- index 0000000..66dca57
- --- /dev/null
- +++ b/tests/http11.test
- @@ -0,0 +1,573 @@
- +# http11.test -- -*- tcl-*-
- +
- +package require tcltest 2
- +namespace import -force ::tcltest::*
- +
- +package require http ;#2.8a0
- +#source http.tcl
- +
- +# start the server
- +variable httpd_output
- +proc create_httpd {} {
- + proc httpd_read {chan} {
- + variable httpd_output
- + if {[gets $chan line] != -1} {
- + #puts stderr "read '$line'"
- + set httpd_output $line
- + }
- + if {[eof $chan]} {
- + puts stderr "eof from httpd"
- + fileevent $chan readable {}
- + close $chan
- + }
- + }
- + variable httpd_output
- + set httpd_script [file join [pwd] [file dirname [info script]] httpd11.tcl]
- + set httpd [open "|[list [interpreter] -encoding utf-8 $httpd_script]" r+]
- + fconfigure $httpd -buffering line -blocking 0
- + fileevent $httpd readable [list httpd_read $httpd]
- + vwait httpd_output
- + variable httpd_port [lindex $httpd_output 2]
- + return $httpd
- +}
- +
- +proc halt_httpd {} {
- + variable httpd_output
- + variable httpd
- + if {[info exists httpd]} {
- + puts $httpd "quit"
- + vwait httpd_output
- + close $httpd
- + }
- + unset -nocomplain httpd_output httpd
- +}
- +
- +proc meta {tok {key ""}} {
- + set meta [http::meta $tok]
- + if {$key ne ""} {
- + if {[dict exists $meta $key]} {
- + return [dict get $meta $key]
- + } else {
- + return ""
- + }
- + }
- + return $meta
- +}
- +
- +proc check_crc {tok args} {
- + set crc [meta $tok x-crc32]
- + if {[llength $args]} {set data [lindex $args 0]} else {set data [http::data $tok]}
- + set chk [format %x [zlib crc32 $data]]
- + if {$crc ne $chk} {
- + return "crc32 mismatch: $crc ne $chk"
- + }
- + return "ok"
- +}
- +
- +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
- +
- +# -------------------------------------------------------------------------
- +
- +test http-1.0 "normal request for document " -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] [meta $tok connection]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close}
- +
- +test http-1.1 "normal,gzip,non-chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 10000 -headers {accept-encoding gzip}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok gzip {}}
- +
- +test http-1.2 "normal,deflated,non-chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 10000 -headers {accept-encoding deflate}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
- +
- +test http-1.3 "normal,compressed,non-chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 10000 -headers {accept-encoding compress}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok compress {}}
- +
- +test http-1.4 "normal,identity,non-chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 10000 -headers {accept-encoding identity}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok {} {}}
- +
- +test http-1.5 "normal request for document, unsupported coding" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -headers {accept-encoding unsupported}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok {}}
- +
- +test http-1.6 "normal, specify 1.1 " -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -protocol 1.1 -timeout 10000]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok connection] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close chunked}
- +
- +test http-1.7 "normal, 1.1 and keepalive " -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -protocol 1.1 -keepalive 1 -timeout 10000]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok connection] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
- +
- +test http-1.8 "normal, 1.1 and keepalive, server close" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -protocol 1.1 -keepalive 1 -timeout 10000]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok connection] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close {}}
- +
- +test http-1.9 "normal,gzip,chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -headers {accept-encoding gzip}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok gzip chunked}
- +
- +test http-1.10 "normal,deflate,chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -headers {accept-encoding deflate}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
- +
- +test http-1.11 "normal,compress,chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -headers {accept-encoding compress}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok compress chunked}
- +
- +test http-1.11 "normal,identity,chunked" -setup {
- + variable httpd [create_httpd]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -headers {accept-encoding identity}]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok] \
- + [meta $tok content-encoding] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
- +
- +# -------------------------------------------------------------------------
- +
- +test http-2.0 "-channel" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close chunked}
- +
- +test http-2.1 "-channel, encoding gzip" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan -headers {accept-encoding gzip}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked}
- +
- +test http-2.2 "-channel, encoding deflate" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
- +
- +test http-2.3 "-channel,encoding compress" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan \
- + -headers {accept-encoding compress}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close compress chunked}
- +
- +test http-2.4 "-channel,encoding identity" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan \
- + -headers {accept-encoding identity}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
- +
- +test http-2.5 "-channel,encoding unsupported" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan \
- + -headers {accept-encoding unsupported}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
- +
- +test http-2.6 "-channel,encoding gzip,non-chunked" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 5000 -channel $chan -headers {accept-encoding gzip}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]\
- + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0}
- +
- +test http-2.7 "-channel,encoding deflate,non-chunked" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]\
- + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
- +
- +test http-2.8 "-channel,encoding compress,non-chunked" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 5000 -channel $chan -headers {accept-encoding compress}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]\
- + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close compress {} 0}
- +
- +test http-2.9 "-channel,encoding identity,non-chunked" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 5000 -channel $chan -headers {accept-encoding identity}]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]\
- + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0}
- +
- +test http-2.10 "-channel,deflate,keepalive" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 5000 -channel $chan -keepalive 1]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]\
- + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
- +
- +test http-2.11 "-channel,identity,keepalive" -setup {
- + variable httpd [create_httpd]
- + set chan [open [makeFile {} testfile.tmp] wb+]
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -headers {accept-encoding identity} \
- + -timeout 5000 -channel $chan -keepalive 1]
- + http::wait $tok
- + seek $chan 0
- + set data [read $chan]
- + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
- + [meta $tok connection] [meta $tok content-encoding]\
- + [meta $tok transfer-encoding]
- +} -cleanup {
- + http::cleanup $tok
- + close $chan
- + removeFile testfile.tmp
- + halt_httpd
- +} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}
- +
- +# -------------------------------------------------------------------------
- +#
- +# The following tests for the -handler option will require changes in
- +# the future. At the moment we cannot handler chunked data with this
- +# option. Therefore we currently force HTTP/1.0 protocol version.
- +#
- +# Once this is solved, these tests should be fixed to assume chunked
- +# returns in 3.2 and 3.3 and HTTP/1.1 in all but test 3.1
- +
- +proc handler {var sock token} {
- + upvar #0 $var data
- + set chunk [read $sock]
- + append data $chunk
- + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
- + if {[eof $sock]} {
- + #::http::Log "handler eof $sock"
- + chan event $sock readable {}
- + }
- +}
- +
- +test http-3.0 "-handler,close,identity" -setup {
- + variable httpd [create_httpd]
- + set testdata ""
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 10000 -handler [namespace code [list handler testdata]]]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
- + [meta $tok connection] [meta $tok content-encoding] \
- + [meta $tok transfer-encoding] \
- + [expr {[file size testdoc.html]-[string length $testdata]}]
- +} -cleanup {
- + http::cleanup $tok
- + unset -nocomplain testdata
- + halt_httpd
- +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
- +
- +test http-3.1 "-handler,protocol1.0" -setup {
- + variable httpd [create_httpd]
- + set testdata ""
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
- + -timeout 10000 -protocol 1.0 \
- + -handler [namespace code [list handler testdata]]]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
- + [meta $tok connection] [meta $tok content-encoding] \
- + [meta $tok transfer-encoding] \
- + [expr {[file size testdoc.html]-[string length $testdata]}]
- +} -cleanup {
- + http::cleanup $tok
- + unset -nocomplain testdata
- + halt_httpd
- +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
- +
- +test http-3.2 "-handler,close,chunked" -setup {
- + variable httpd [create_httpd]
- + set testdata ""
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -keepalive 0 -binary 1\
- + -handler [namespace code [list handler testdata]]]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
- + [meta $tok connection] [meta $tok content-encoding] \
- + [meta $tok transfer-encoding] \
- + [expr {[file size testdoc.html]-[string length $testdata]}]
- +} -cleanup {
- + http::cleanup $tok
- + unset -nocomplain testdata
- + halt_httpd
- +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
- +
- +test http-3.3 "-handler,keepalive,chunked" -setup {
- + variable httpd [create_httpd]
- + set testdata ""
- +} -body {
- + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- + -timeout 10000 -keepalive 1 -binary 1\
- + -handler [namespace code [list handler testdata]]]
- + http::wait $tok
- + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
- + [meta $tok connection] [meta $tok content-encoding] \
- + [meta $tok transfer-encoding] \
- + [expr {[file size testdoc.html]-[string length $testdata]}]
- +} -cleanup {
- + http::cleanup $tok
- + unset -nocomplain testdata
- + halt_httpd
- +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
- +
- +# -------------------------------------------------------------------------
- +
- +unset -nocomplain httpd_port
- +::tcltest::cleanupTests
- diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
- new file mode 100644
- index 0000000..09630e1
- --- /dev/null
- +++ b/tests/httpd11.tcl
- @@ -0,0 +1,221 @@
- +# httpd11.tcl -- -*- tcl -*-
- +#
- +# A simple httpd for testing HTTP/1.1 client features.
- +# Not suitable for use on a internet connected port.
- +#
- +
- +package require Tcl 8.6
- +
- +proc ::tcl::dict::get? {dict key} {
- + if {[dict exists $dict $key]} {
- + return [dict get $dict $key]
- + }
- + return
- +}
- +namespace ensemble configure dict \
- + -map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?]
- +
- +proc make-chunk-generator {data {size 4096}} {
- + variable _chunk_gen_uid
- + if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0}
- + set lambda {{data size} {
- + set pos 0
- + yield
- + while {1} {
- + set payload [string range $data $pos [expr {$pos + $size - 1}]]
- + incr pos $size
- + set chunk [format %x [string length $payload]]\r\n$payload\r\n
- + yield $chunk
- + if {![string length $payload]} {return}
- + }
- + }}
- + set name chunker[incr _chunk_gen_uid]
- + coroutine $name ::apply $lambda $data $size
- + return $name
- +}
- +
- +proc get-chunks {data {compression gzip}} {
- + switch -exact -- $compression {
- + gzip { set data [zlib gzip $data] }
- + deflate { set data [zlib deflate $data] }
- + compress { set data [zlib compress $data] }
- + }
- +
- + set data ""
- + set chunker [make-chunk-generator $data 512]
- + while {[string length [set chunk [$chunker]]]} {
- + append data $chunk
- + }
- + return $data
- +}
- +
- +proc blow-chunks {data {ochan stdout} {compression gzip}} {
- + switch -exact -- $compression {
- + gzip { set data [zlib gzip $data] }
- + deflate { set data [zlib deflate $data] }
- + compress { set data [zlib compress $data] }
- + }
- +
- + set chunker [make-chunk-generator $data 512]
- + while {[string length [set chunk [$chunker]]]} {
- + puts -nonewline $ochan $chunk
- + }
- + return
- +}
- +
- +proc mime-type {filename} {
- + switch -exact -- [file extension $filename] {
- + .htm - .html { return {text text/html}}
- + .png { return {binary image/png} }
- + .jpg { return {binary image/jpeg} }
- + .gif { return {binary image/gif} }
- + .css { return {text text/css} }
- + .xml { return {text text/xml} }
- + .xhtml {return {text application/xml+html} }
- + .svg { return {text image/svg+xml} }
- + .txt - .tcl - .c - .h { return {text text/plain}}
- + }
- + return {binary text/plain}
- +}
- +
- +proc Puts {chan s} {puts $chan $s; puts $s}
- +
- +proc Service {chan addr port} {
- + chan event $chan readable [info coroutine]
- + while {1} {
- + set meta {}
- + chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
- + yield
- + while {[gets $chan line] < 0} {
- + if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
- + yield
- + }
- + if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
- + foreach {req url protocol} {GET {} HTTP/1.1} break
- + regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol
- +
- + puts $line
- + while {[gets $chan line] > 0} {
- + if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
- + #puts "$key $val"
- + lappend meta [string tolower $key] [string trim $val]
- + }
- + yield
- + }
- +
- + if {[scan $url {%[^?]?%s} path query] < 2} {
- + set query ""
- + }
- +
- + set encoding identity
- + set transfer ""
- + set close 1
- + set type text/html
- + set code "404 Not Found"
- + set data "<html><head><title>Error 404</title></head>"
- + append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>"
- +
- + set path [string trimleft $path /]
- + set path [file join [pwd] $path]
- + if {[file exists $path] && [file isfile $path]} {
- + foreach {what type} [mime-type $path] break
- + set f [open $path r]
- + if {$what eq "binary"} {chan configure $f -translation binary}
- + set data [read $f]
- + close $f
- + set code "200 OK"
- + set close [expr {[dict get? $meta connection] eq "close"}]
- + }
- +
- + if {$protocol eq "HTTP/1.1"} {
- + if {[string match "*deflate*" [dict get? $meta accept-encoding]]} {
- + set encoding deflate
- + } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} {
- + set encoding gzip
- + } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} {
- + set encoding compress
- + }
- + set transfer chunked
- + } else {
- + set close 1
- + }
- +
- + foreach pair [split $query &] {
- + if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
- + switch -exact -- $key {
- + close {set close 1 ; set transfer 0}
- + transfer {set transfer $val}
- + content-type {set type $val}
- + }
- + }
- +
- + chan configure $chan -translation crlf
- + Puts $chan "$protocol $code"
- + Puts $chan "content-type: $type"
- + Puts $chan [format "x-crc32: %x" [zlib crc32 $data]]
- + if {$close} {
- + Puts $chan "connection: close"
- + }
- + if {$encoding eq "identity"} {
- + Puts $chan "content-length: [string length $data]"
- + } else {
- + Puts $chan "content-encoding: $encoding"
- + }
- + if {$transfer eq "chunked"} {
- + Puts $chan "transfer-encoding: chunked"
- + }
- + puts $chan ""
- + flush $chan
- +
- + chan configure $chan -translation binary
- + if {$transfer eq "chunked"} {
- + blow-chunks $data $chan $encoding
- + } elseif {$encoding ne "identity"} {
- + puts -nonewline $chan [zlib $encoding $data]
- + } else {
- + puts -nonewline $chan $data
- + }
- +
- + if {$close} {
- + chan event $chan readable {}
- + close $chan
- + puts "close $chan"
- + return
- + } else {
- + flush $chan
- + }
- + puts "pipeline $chan"
- + }
- +}
- +
- +proc Accept {chan addr port} {
- + coroutine client$chan Service $chan $addr $port
- + return
- +}
- +
- +proc Control {chan} {
- + if {[gets $chan line] != -1} {
- + if {[string trim $line] eq "quit"} {
- + set ::forever 1
- + }
- + }
- + if {[eof $chan]} {
- + chan event $chan readable {}
- + }
- +}
- +
- +proc Main {{port 0}} {
- + set server [socket -server Accept -myaddr localhost $port]
- + puts [chan configure $server -sockname]
- + flush stdout
- + chan event stdin readable [list Control stdin]
- + vwait ::forever
- + close $server
- + return "done"
- +}
- +
- +if {!$tcl_interactive} {
- + set r [catch [linsert $argv 0 Main] err]
- + if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err}
- + exit $r
- +}