summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/http.test5
-rw-r--r--tests/http11.test579
-rw-r--r--tests/httpd11.tcl225
3 files changed, 807 insertions, 2 deletions
diff --git a/tests/http.test b/tests/http.test
index c4006f9..7fac104 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -12,7 +12,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
-# RCS: @(#) $Id: http.test,v 1.50 2009/04/10 09:37:52 patthoyts Exp $
+# RCS: @(#) $Id: http.test,v 1.51 2009/04/10 14:19:45 patthoyts Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -83,8 +83,9 @@ if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
}
test http-1.1 {http::config} {
+ http::config -useragent UserAgent
http::config
-} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]
+} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
diff --git a/tests/http11.test b/tests/http11.test
new file mode 100644
index 0000000..58bb091
--- /dev/null
+++ b/tests/http11.test
@@ -0,0 +1,579 @@
+# http11.test -- -*- tcl-*-
+#
+# Test HTTP/1.1 features.
+#
+# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+package require http 2.8
+
+# 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..afa5f5d
--- /dev/null
+++ b/tests/httpd11.tcl
@@ -0,0 +1,225 @@
+# httpd11.tcl -- -*- tcl -*-
+#
+# A simple httpd for testing HTTP/1.1 client features.
+# Not suitable for use on a internet connected port.
+#
+# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# 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.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
+}
generated by cgit v0.12 at 2024-11-05 13:50:29 (GMT)