summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorwelch <welch>2000-04-09 23:56:31 (GMT)
committerwelch <welch>2000-04-09 23:56:31 (GMT)
commit3478f86ac104867c93711c5cbac651552dab24d6 (patch)
tree3057e86ecff13676d79742ee3664e83846b051d4
parent57f0ac3080516da423ae7cfc25075539a085baa6 (diff)
downloadtcl-3478f86ac104867c93711c5cbac651552dab24d6.zip
tcl-3478f86ac104867c93711c5cbac651552dab24d6.tar.gz
tcl-3478f86ac104867c93711c5cbac651552dab24d6.tar.bz2
Added "server closes without reading post data" case.
-rw-r--r--tests/http.test108
-rw-r--r--tests/httpd86
2 files changed, 146 insertions, 48 deletions
diff --git a/tests/http.test b/tests/http.test
index c242ae0..4ae5757 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -12,19 +12,21 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
-# RCS: @(#) $Id: http.test,v 1.16 2000/03/19 22:32:26 sandeep Exp $
+# RCS: @(#) $Id: http.test,v 1.17 2000/04/09 23:56:31 welch Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import ::tcltest::*
}
+set tcltest::testConstraints(notLinux) \
+ [expr ![string equal Linux $tcl_platform(os)]]
-if {[catch {package require http 2}]} {
+if {[catch {package require http 2} version]} {
if {[info exist http2]} {
- catch {puts "Cannot load http 2.2 package"}
+ catch {puts "Cannot load http 2.* package"}
return
} else {
- catch {puts "Running http 2.2 tests in slave interp"}
+ catch {puts "Running http 2.* tests in slave interp"}
set interp [interp create http2]
$interp eval [list set http2 "running"]
$interp eval [list source [info script]]
@@ -33,6 +35,12 @@ if {[catch {package require http 2}]} {
}
}
+proc bgerror {args} {
+ global errorInfo
+ puts stderr "http.test bgerror"
+ puts stderr [join $args]
+ puts stderr $errorInfo
+}
set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
@@ -74,7 +82,7 @@ if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
test http-1.1 {http::config} {
http::config
-} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.2}}
+} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent "Tcl http client package $version"]
test http-1.2 {http::config} {
http::config -proxyfilter
@@ -122,6 +130,7 @@ set tail /a/b/c
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary
set posturl [info hostname]:$port/post
+set badposturl [info hostname]:$port/droppost
test http-3.4 {http::geturl} {
set token [http::geturl $url]
@@ -164,7 +173,7 @@ test http-3.7 {http::geturl} {
</body></html>"
test http-3.8 {http::geturl} {
- set token [http::geturl $url -query Name=Value&Foo=Bar]
+ set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
@@ -237,6 +246,50 @@ test http-3.11 {http::geturl querychannel with -command} {
set testRes
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
+# On Linux platforms when the client and server are on the same
+# host, the client is unable to read the server's response one
+# it hits the write error. The status is "eof"
+
+# On Windows, the http::wait procedure gets a
+# "connection reset by peer" error while reading the reply
+
+test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
+ set query foo=bar
+ set sep ""
+ set i 0
+ # Create about 120K of query data
+ while {$i < 14} {
+ incr i
+ append query $sep$query
+ set sep &
+ }
+ ::tcltest::makeFile $query outdata
+ set fp [open outdata]
+
+ proc asyncCB {token} {
+ global postResult
+ lappend postResult [http::data $token]
+ }
+ proc postProgress {token x y} {
+ global postProgress
+ lappend postProgress $y
+ }
+ set postProgress {}
+ # Now do async
+ set postResult [list PostStart]
+ if {[catch {
+ set t [http::geturl $badposturl -querychannel $fp -command asyncCB \
+ -queryprogress postProgress]
+ http::wait $t
+ upvar #0 $t state
+ } err]} {
+ puts $errorInfo
+ error $err
+ }
+
+ list [http::status $t] [http::code $t]
+} {ok {HTTP/1.0 200 Data follows}}
+
test http-4.1 {http::Event} {
set token [http::geturl $url]
@@ -325,41 +378,48 @@ test http-4.10 {http::Event} {
} {111}
# Timeout cases
+
# Short timeout to working server (the test server)
-# Short timeout to working server that waits longer
-# Short timeout to good host, bad port, hits in connection phase
-# Longer timeout to good host, bad port, hits in I/O phase
+# This lets us try a reset during the connection
test http-4.11 {http::Event} {
set token [http::geturl $url -timeout 1 -command {#}]
http::reset $token
http::status $token
} {reset}
+
+# Longer timeout with reset
+
test http-4.12 {http::Event} {
- set token [http::geturl $url?timeout=10 -timeout 1 -command {#}]
- http::wait $token
+ set token [http::geturl $url/?timeout=10 -command {#}]
+ http::reset $token
http::status $token
-} {timeout}
+} {reset}
+
+# Medium timeout to working server that waits even longer
+# The timeout hits while waiting for a reply
test http-4.13 {http::Event} {
- set token [http::geturl $badurl/?timeout=10 -timeout 1 -command {#}]
- if {[string length $token] == 0} {
- error "bogus return from http::geturl"
- }
+ set token [http::geturl $url?timeout=30 -timeout 10 -command {#}]
http::wait $token
http::status $token
} {timeout}
-# Longer timeout hits after connection (to a bad socket!) completes
+# 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} {
- set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]
- if {[string length $token] == 0} {
- error "bogus return from http::geturl"
- }
- http::wait $token
- http::status $token
-} {ioerror}
+ set code [catch {
+ set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]
+ if {[string length $token] == 0} {
+ error "bogus return from http::geturl"
+ }
+ http::wait $token
+ http::status $token
+ } err]
+ # error code varies among platforms.
+ list $code [string match "connect failed*" $err]
+} {1 1}
# Bogus host
diff --git a/tests/httpd b/tests/httpd
index aa2e51d..e5fa282 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -2,6 +2,7 @@
# The httpd_ procedures implement a stub http server.
#
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
+# Copyright (c) 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,6 +23,7 @@ proc httpd_log {args} {
array set httpdErrors {
204 {No Content}
400 {Bad Request}
+ 401 {Authorization Required}
404 {Not Found}
503 {Service Unavailable}
504 {Service Temporarily Unavailable}
@@ -47,10 +49,15 @@ proc httpdAccept {newsock ipaddr port} {
proc httpdRead { sock } {
upvar #0 httpd$sock data
- if {![info exists data(state)]} {
+ if {[eof $sock]} {
+ set readCount -1
+ } elseif {![info exists data(state)]} {
+
+ # Read the protocol line and parse out the URL and query
+
set readCount [gets $sock line]
- if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
- $line x data(proto) data(url) data(query)] {
+ if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} \
+ $line x data(proto) data(url) data(query) data(httpversion)] {
set data(state) mime
httpd_log $sock Query $line
} else {
@@ -60,11 +67,14 @@ proc httpdRead { sock } {
}
return
} elseif {$data(state) == "mime"} {
+
+ # Read the HTTP headers
+
set readCount [gets $sock line]
- if {[regexp {Content-Length: (\d+)} $line match length]} {
- set data(length) $length
- }
} elseif {$data(state) == "query"} {
+
+ # Read the query data
+
if {![info exist data(length_orig)]} {
set data(length_orig) $data(length)
}
@@ -86,18 +96,41 @@ proc httpdRead { sock } {
}
0,mime,HEAD -
0,mime,GET -
- 0,query,POST { httpdRespond $sock }
- 0,mime,POST { set data(state) query }
+ 0,query,POST {
+ # Empty line at end of headers,
+ # or eof after query data
+ httpdRespond $sock
+ }
+ 0,mime,POST {
+ # Empty line between headers and query data
+ if {![info exist data(mime,content-length)]} {
+ httpd_log $sock Error "No Content-Length for POST"
+ httpdError $sock 400
+ httpdSockDone $sock
+ } else {
+ set data(state) query
+ set data(length) $data(mime,content-length)
+
+ # Special case to simulate servers that respond
+ # without reading the post data.
+
+ if {[string match *droppost* $data(url)]} {
+ fileevent $sock readable {}
+ httpdRespond $sock
+ }
+ }
+ }
1,mime,HEAD -
1,mime,POST -
1,mime,GET {
+ # A line of HTTP headers
if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} {
set data(mime,[string tolower $key]) $value
}
}
-1,query,POST {
httpd_log $sock Error "unexpected eof on <$data(url)> request"
- httpdError $sock 404
+ httpdError $sock 400
httpdSockDone $sock
}
1,query,POST {
@@ -108,7 +141,7 @@ proc httpdRead { sock } {
}
}
default {
- if [eof $sock] {
+ if {[eof $sock]} {
httpd_log $sock Error "unexpected eof on <$data(url)> request"
} else {
httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
@@ -119,9 +152,9 @@ proc httpdRead { sock } {
}
}
proc httpdSockDone { sock } {
-upvar #0 httpd$sock data
+ upvar #0 httpd$sock data
unset data
- close $sock
+ catch {close $sock}
}
# Respond to the query.
@@ -156,19 +189,24 @@ proc httpdRespond { sock } {
append html </body></html>
}
}
+
+ # Catch errors from premature client closes
- if {$data(proto) == "HEAD"} {
- puts $sock "HTTP/1.0 200 OK"
- } else {
- puts $sock "HTTP/1.0 200 Data follows"
- }
- puts $sock "Date: [clock format [clock clicks]]"
- puts $sock "Content-Type: $type"
- puts $sock "Content-Length: [string length $html]"
- puts $sock ""
- if {$data(proto) != "HEAD"} {
- fconfigure $sock -translation binary
- puts -nonewline $sock $html
+ catch {
+ if {$data(proto) == "HEAD"} {
+ puts $sock "HTTP/1.0 200 OK"
+ } else {
+ puts $sock "HTTP/1.0 200 Data follows"
+ }
+ puts $sock "Date: [clock format [clock clicks]]"
+ puts $sock "Content-Type: $type"
+ puts $sock "Content-Length: [string length $html]"
+ puts $sock ""
+ flush $sock
+ if {$data(proto) != "HEAD"} {
+ fconfigure $sock -translation binary
+ puts -nonewline $sock $html
+ }
}
httpd_log $sock Done ""
httpdSockDone $sock