diff options
| -rw-r--r-- | tests/http.test | 108 | ||||
| -rw-r--r-- | tests/httpd | 86 |
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 |