Added "server closes without reading post data" case.

author: welch <welch> 2000-04-09 23:56:31 (GMT)
committer: welch <welch> 2000-04-09 23:56:31 (GMT)
commit: 3478f86ac104867c93711c5cbac651552dab24d6 (patch)
tree: 3057e86ecff13676d79742ee3664e83846b051d4
parent: 57f0ac3080516da423ae7cfc25075539a085baa6 (diff)
download: tcl-3478f86ac104867c93711c5cbac651552dab24d6.zip
tcl-3478f86ac104867c93711c5cbac651552dab24d6.tar.gz
tcl-3478f86ac104867c93711c5cbac651552dab24d6.tar.bz2
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
author	welch <welch>	2000-04-09 23:56:31 (GMT)
committer	welch <welch>	2000-04-09 23:56:31 (GMT)
commit	3478f86ac104867c93711c5cbac651552dab24d6 (patch)
tree	3057e86ecff13676d79742ee3664e83846b051d4
parent	57f0ac3080516da423ae7cfc25075539a085baa6 (diff)
download	tcl-3478f86ac104867c93711c5cbac651552dab24d6.zip tcl-3478f86ac104867c93711c5cbac651552dab24d6.tar.gz tcl-3478f86ac104867c93711c5cbac651552dab24d6.tar.bz2