sl@0: # Commands covered: http::config, http::geturl, http::wait, http::reset sl@0: # sl@0: # This file contains a collection of tests for the http script library. sl@0: # Sourcing this file into Tcl runs the tests and sl@0: # generates output for errors. No output means no errors were found. sl@0: # sl@0: # Copyright (c) 1991-1993 The Regents of the University of California. sl@0: # Copyright (c) 1994-1996 Sun Microsystems, Inc. sl@0: # Copyright (c) 1998-2000 by Ajuba Solutions. sl@0: # sl@0: # See the file "license.terms" for information on usage and redistribution sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: # sl@0: # sl@0: # RCS: @(#) $Id: http.test,v 1.33.2.6 2006/10/06 19:00:53 hobbs Exp $ sl@0: sl@0: if {[lsearch [namespace children] ::tcltest] == -1} { sl@0: package require tcltest 2 sl@0: namespace import -force ::tcltest::* sl@0: } sl@0: sl@0: if {[catch {package require http 2} version]} { sl@0: if {[info exists http2]} { sl@0: catch {puts "Cannot load http 2.* package"} sl@0: return sl@0: } else { sl@0: catch {puts "Running http 2.* tests in slave interp"} sl@0: set interp [interp create http2] sl@0: $interp eval [list set http2 "running"] sl@0: $interp eval [list set argv $argv] sl@0: $interp eval [list source [info script]] sl@0: interp delete $interp sl@0: return sl@0: } sl@0: } sl@0: sl@0: proc bgerror {args} { sl@0: global errorInfo sl@0: puts stderr "http.test bgerror" sl@0: puts stderr [join $args] sl@0: puts stderr $errorInfo sl@0: } sl@0: sl@0: set port 8010 sl@0: set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" sl@0: catch {unset data} sl@0: sl@0: # Ensure httpd file exists sl@0: sl@0: set origFile [file join [pwd] [file dirname [info script]] httpd] sl@0: set httpdFile [file join [temporaryDirectory] httpd_[pid]] sl@0: if {![file exists $httpdFile]} { sl@0: makeFile "" $httpdFile sl@0: file delete $httpdFile sl@0: file copy $origFile $httpdFile sl@0: set removeHttpd 1 sl@0: } sl@0: sl@0: if {[info commands testthread] == "testthread" && [file exists $httpdFile]} { sl@0: set httpthread [testthread create " sl@0: source [list $httpdFile] sl@0: testthread wait sl@0: "] sl@0: testthread send $httpthread [list set port $port] sl@0: testthread send $httpthread [list set bindata $bindata] sl@0: testthread send $httpthread {httpd_init $port} sl@0: puts "Running httpd in thread $httpthread" sl@0: } else { sl@0: if {![file exists $httpdFile]} { sl@0: puts "Cannot read $httpdFile script, http test skipped" sl@0: unset port sl@0: return sl@0: } sl@0: source $httpdFile sl@0: # Let the OS pick the port; that's much more flexible sl@0: if {[catch {httpd_init 0} listen]} { sl@0: puts "Cannot start http server, http test skipped" sl@0: unset port sl@0: return sl@0: } else { sl@0: set port [lindex [fconfigure $listen -sockname] 2] sl@0: } sl@0: } sl@0: sl@0: test http-1.1 {http::config} { sl@0: http::config sl@0: } [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"] sl@0: test http-1.2 {http::config} { sl@0: http::config -proxyfilter sl@0: } http::ProxyRequired sl@0: test http-1.3 {http::config} { sl@0: catch {http::config -junk} sl@0: } 1 sl@0: test http-1.4 {http::config} { sl@0: set savedconf [http::config] sl@0: http::config -proxyhost nowhere.come -proxyport 8080 \ sl@0: -proxyfilter myFilter -useragent "Tcl Test Suite" \ sl@0: -urlencoding iso8859-1 sl@0: set x [http::config] sl@0: eval http::config $savedconf sl@0: set x sl@0: } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} sl@0: test http-1.5 {http::config} { sl@0: list [catch {http::config -proxyhost {} -junk 8080} msg] $msg sl@0: } {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}} sl@0: test http-1.6 {http::config} { sl@0: set enc [list [http::config -urlencoding]] sl@0: http::config -urlencoding iso8859-1 sl@0: lappend enc [http::config -urlencoding] sl@0: http::config -urlencoding [lindex $enc 0] sl@0: set enc sl@0: } {utf-8 iso8859-1} sl@0: sl@0: test http-2.1 {http::reset} { sl@0: catch {http::reset http#1} sl@0: } 0 sl@0: sl@0: test http-3.1 {http::geturl} { sl@0: list [catch {http::geturl -bogus flag} msg] $msg sl@0: } {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}} sl@0: test http-3.2 {http::geturl} { sl@0: catch {http::geturl http:junk} err sl@0: set err sl@0: } {Unsupported URL: http:junk} sl@0: set url //[info hostname]:$port sl@0: set badurl //[info hostname]:6666 sl@0: test http-3.3 {http::geturl} { sl@0: set token [http::geturl $url] sl@0: http::data $token sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET /

sl@0: " sl@0: set tail /a/b/c sl@0: set url //[info hostname]:$port/a/b/c sl@0: set fullurl http://user:pass@[info hostname]:$port/a/b/c sl@0: set binurl //[info hostname]:$port/binary sl@0: set posturl //[info hostname]:$port/post sl@0: set badposturl //[info hostname]:$port/droppost sl@0: set badcharurl //%user@[info hostname]:$port/a/^b/c sl@0: sl@0: test http-3.4 {http::geturl} { sl@0: set token [http::geturl $url] sl@0: http::data $token sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET $tail

sl@0: " sl@0: proc selfproxy {host} { sl@0: global port sl@0: return [list [info hostname] $port] sl@0: } sl@0: test http-3.5 {http::geturl} { sl@0: http::config -proxyfilter selfproxy sl@0: set token [http::geturl $url] sl@0: http::config -proxyfilter http::ProxyRequired sl@0: http::data $token sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET http:$url

sl@0: " sl@0: test http-3.6 {http::geturl} { sl@0: http::config -proxyfilter bogus sl@0: set token [http::geturl $url] sl@0: http::config -proxyfilter http::ProxyRequired sl@0: http::data $token sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET $tail

sl@0: " sl@0: test http-3.7 {http::geturl} { sl@0: set token [http::geturl $url -headers {Pragma no-cache}] sl@0: http::data $token sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET $tail

sl@0: " sl@0: test http-3.8 {http::geturl} { sl@0: set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000] sl@0: http::data $token sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

POST $tail

sl@0:

Query

sl@0:
sl@0:
Name
Value sl@0:
Foo
Bar sl@0:
sl@0: " sl@0: test http-3.9 {http::geturl} { sl@0: set token [http::geturl $url -validate 1] sl@0: http::code $token sl@0: } "HTTP/1.0 200 OK" sl@0: test http-3.10 {http::geturl queryprogress} { sl@0: set query foo=bar sl@0: set sep "" sl@0: set i 0 sl@0: # Create about 120K of query data sl@0: while {$i < 14} { sl@0: incr i sl@0: append query $sep$query sl@0: set sep & sl@0: } sl@0: sl@0: proc postProgress {token x y} { sl@0: global postProgress sl@0: lappend postProgress $y sl@0: } sl@0: set postProgress {} sl@0: set t [http::geturl $posturl -query $query \ sl@0: -queryprogress postProgress -queryblocksize 16384] sl@0: http::wait $t sl@0: list [http::status $t] [string length $query] $postProgress [http::data $t] sl@0: } {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}} sl@0: test http-3.11 {http::geturl querychannel with -command} { sl@0: set query foo=bar sl@0: set sep "" sl@0: set i 0 sl@0: # Create about 120K of query data sl@0: while {$i < 14} { sl@0: incr i sl@0: append query $sep$query sl@0: set sep & sl@0: } sl@0: set file [makeFile $query outdata] sl@0: set fp [open $file] sl@0: sl@0: proc asyncCB {token} { sl@0: global postResult sl@0: lappend postResult [http::data $token] sl@0: } sl@0: set postResult [list ] sl@0: set t [http::geturl $posturl -querychannel $fp] sl@0: http::wait $t sl@0: set testRes [list [http::status $t] [string length $query] [http::data $t]] sl@0: sl@0: # Now do async sl@0: http::cleanup $t sl@0: close $fp sl@0: set fp [open $file] sl@0: set t [http::geturl $posturl -querychannel $fp -command asyncCB] sl@0: set postResult [list PostStart] sl@0: http::wait $t sl@0: close $fp sl@0: sl@0: lappend testRes [http::status $t] $postResult sl@0: removeFile outdata sl@0: set testRes sl@0: } {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}} sl@0: # On Linux platforms when the client and server are on the same host, the sl@0: # client is unable to read the server's response one it hits the write error. sl@0: # The status is "eof". sl@0: # On Windows, the http::wait procedure gets a "connection reset by peer" error sl@0: # while reading the reply. sl@0: test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} { sl@0: set query foo=bar sl@0: set sep "" sl@0: set i 0 sl@0: # Create about 120K of query data sl@0: while {$i < 14} { sl@0: incr i sl@0: append query $sep$query sl@0: set sep & sl@0: } sl@0: set file [makeFile $query outdata] sl@0: set fp [open $file] sl@0: sl@0: proc asyncCB {token} { sl@0: global postResult sl@0: lappend postResult [http::data $token] sl@0: } sl@0: proc postProgress {token x y} { sl@0: global postProgress sl@0: lappend postProgress $y sl@0: } sl@0: set postProgress {} sl@0: # Now do async sl@0: set postResult [list PostStart] sl@0: if {[catch { sl@0: set t [http::geturl $badposturl -querychannel $fp -command asyncCB \ sl@0: -queryprogress postProgress] sl@0: http::wait $t sl@0: upvar #0 $t state sl@0: } err]} { sl@0: puts $errorInfo sl@0: error $err sl@0: } sl@0: sl@0: removeFile outdata sl@0: list [http::status $t] [http::code $t] sl@0: } {ok {HTTP/1.0 200 Data follows}} sl@0: test http-3.13 {http::geturl socket leak test} { sl@0: set chanCount [llength [file channels]] sl@0: for {set i 0} {$i < 3} {incr i} { sl@0: catch {http::geturl $badurl -timeout 5000} sl@0: } sl@0: sl@0: # No extra channels should be taken sl@0: expr {[llength [file channels]] == $chanCount} sl@0: } 1 sl@0: test http-3.14 "http::geturl $fullurl" { sl@0: set token [http::geturl $fullurl -validate 1] sl@0: http::code $token sl@0: } "HTTP/1.0 200 OK" sl@0: test http-3.15 {http::geturl parse failures} -body { sl@0: http::geturl "{invalid}:url" sl@0: } -returnCodes error -result {Unsupported URL: {invalid}:url} sl@0: test http-3.16 {http::geturl parse failures} -body { sl@0: http::geturl http:relative/url sl@0: } -returnCodes error -result {Unsupported URL: http:relative/url} sl@0: test http-3.17 {http::geturl parse failures} -body { sl@0: http::geturl /absolute/url sl@0: } -returnCodes error -result {Missing host part: /absolute/url} sl@0: test http-3.18 {http::geturl parse failures} -body { sl@0: http::geturl http://somewhere:123456789/ sl@0: } -returnCodes error -result {Invalid port number: 123456789} sl@0: test http-3.19 {http::geturl parse failures} -body { sl@0: set ::http::strict 1 sl@0: http::geturl http://{user}@somewhere sl@0: } -returnCodes error -result {Illegal characters in URL user} sl@0: test http-3.20 {http::geturl parse failures} -body { sl@0: set ::http::strict 1 sl@0: http::geturl http://%user@somewhere sl@0: } -returnCodes error -result {Illegal encoding character usage "%us" in URL user} sl@0: test http-3.21 {http::geturl parse failures} -body { sl@0: set ::http::strict 1 sl@0: http::geturl http://somewhere/{path} sl@0: } -returnCodes error -result {Illegal characters in URL path} sl@0: test http-3.22 {http::geturl parse failures} -body { sl@0: set ::http::strict 1 sl@0: http::geturl http://somewhere/%path sl@0: } -returnCodes error -result {Illegal encoding character usage "%pa" in URL path} sl@0: test http-3.23 {http::geturl parse failures} -body { sl@0: set ::http::strict 1 sl@0: http::geturl http://somewhere/path?{query} sl@0: } -returnCodes error -result {Illegal characters in URL path} sl@0: test http-3.24 {http::geturl parse failures} -body { sl@0: set ::http::strict 1 sl@0: http::geturl http://somewhere/path?%query sl@0: } -returnCodes error -result {Illegal encoding character usage "%qu" in URL path} sl@0: test http-3.25 {http::geturl parse failures} -body { sl@0: set ::http::strict 0 sl@0: set token [http::geturl $badcharurl] sl@0: http::cleanup $token sl@0: } -returnCodes ok -result {} sl@0: sl@0: test http-4.1 {http::Event} { sl@0: set token [http::geturl $url] sl@0: upvar #0 $token data sl@0: array set meta $data(meta) sl@0: expr ($data(totalsize) == $meta(Content-Length)) sl@0: } 1 sl@0: test http-4.2 {http::Event} { sl@0: set token [http::geturl $url] sl@0: upvar #0 $token data sl@0: array set meta $data(meta) sl@0: string compare $data(type) [string trim $meta(Content-Type)] sl@0: } 0 sl@0: test http-4.3 {http::Event} { sl@0: set token [http::geturl $url] sl@0: http::code $token sl@0: } {HTTP/1.0 200 Data follows} sl@0: test http-4.4 {http::Event} { sl@0: set testfile [makeFile "" testfile] sl@0: set out [open $testfile w] sl@0: set token [http::geturl $url -channel $out] sl@0: close $out sl@0: set in [open $testfile] sl@0: set x [read $in] sl@0: close $in sl@0: removeFile $testfile sl@0: set x sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET $tail

sl@0: " sl@0: test http-4.5 {http::Event} { sl@0: set testfile [makeFile "" testfile] sl@0: set out [open $testfile w] sl@0: set token [http::geturl $url -channel $out] sl@0: close $out sl@0: upvar #0 $token data sl@0: removeFile $testfile sl@0: expr $data(currentsize) == $data(totalsize) sl@0: } 1 sl@0: test http-4.6 {http::Event} { sl@0: set testfile [makeFile "" testfile] sl@0: set out [open $testfile w] sl@0: set token [http::geturl $binurl -channel $out] sl@0: close $out sl@0: set in [open $testfile] sl@0: fconfigure $in -translation binary sl@0: set x [read $in] sl@0: close $in sl@0: removeFile $testfile sl@0: set x sl@0: } "$bindata[string trimleft $binurl /]" sl@0: proc myProgress {token total current} { sl@0: global progress httpLog sl@0: if {[info exists httpLog] && $httpLog} { sl@0: puts "progress $total $current" sl@0: } sl@0: set progress [list $total $current] sl@0: } sl@0: if 0 { sl@0: # This test hangs on Windows95 because the client never gets EOF sl@0: set httpLog 1 sl@0: test http-4.6.1 {http::Event} knownBug { sl@0: set token [http::geturl $url -blocksize 50 -progress myProgress] sl@0: set progress sl@0: } {111 111} sl@0: } sl@0: test http-4.7 {http::Event} { sl@0: set token [http::geturl $url -progress myProgress] sl@0: set progress sl@0: } {111 111} sl@0: test http-4.8 {http::Event} { sl@0: set token [http::geturl $url] sl@0: http::status $token sl@0: } {ok} sl@0: test http-4.9 {http::Event} { sl@0: set token [http::geturl $url -progress myProgress] sl@0: http::code $token sl@0: } {HTTP/1.0 200 Data follows} sl@0: test http-4.10 {http::Event} { sl@0: set token [http::geturl $url -progress myProgress] sl@0: http::size $token sl@0: } {111} sl@0: # Timeout cases sl@0: # Short timeout to working server (the test server). This lets us try a sl@0: # reset during the connection. sl@0: test http-4.11 {http::Event} { sl@0: set token [http::geturl $url -timeout 1 -command {#}] sl@0: http::reset $token sl@0: http::status $token sl@0: } {reset} sl@0: # Longer timeout with reset. sl@0: test http-4.12 {http::Event} { sl@0: set token [http::geturl $url/?timeout=10 -command {#}] sl@0: http::reset $token sl@0: http::status $token sl@0: } {reset} sl@0: # Medium timeout to working server that waits even longer. The timeout sl@0: # hits while waiting for a reply. sl@0: test http-4.13 {http::Event} { sl@0: set token [http::geturl $url?timeout=30 -timeout 10 -command {#}] sl@0: http::wait $token sl@0: http::status $token sl@0: } {timeout} sl@0: # Longer timeout to good host, bad port, gets an error after the sl@0: # connection "completes" but the socket is bad. sl@0: test http-4.14 {http::Event} { sl@0: set code [catch { sl@0: set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}] sl@0: if {[string length $token] == 0} { sl@0: error "bogus return from http::geturl" sl@0: } sl@0: http::wait $token sl@0: http::status $token sl@0: } err] sl@0: # error code varies among platforms. sl@0: list $code [regexp {(connect failed|couldn't open socket)} $err] sl@0: } {1 1} sl@0: # Bogus host sl@0: test http-4.15 {http::Event} { sl@0: # This test may fail if you use a proxy server. That is to be sl@0: # expected and is not a problem with Tcl. sl@0: set code [catch { sl@0: set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}] sl@0: http::wait $token sl@0: http::status $token sl@0: } err] sl@0: # error code varies among platforms. sl@0: list $code [string match "couldn't open socket*" $err] sl@0: } {1 1} sl@0: sl@0: test http-5.1 {http::formatQuery} { sl@0: http::formatQuery name1 value1 name2 "value two" sl@0: } {name1=value1&name2=value%20two} sl@0: # test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5 sl@0: test http-5.3 {http::formatQuery} { sl@0: http::formatQuery lines "line1\nline2\nline3" sl@0: } {lines=line1%0d%0aline2%0d%0aline3} sl@0: test http-5.4 {http::formatQuery} { sl@0: http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 sl@0: } {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2} sl@0: test http-5.5 {http::formatQuery} { sl@0: set enc [http::config -urlencoding] sl@0: http::config -urlencoding iso8859-1 sl@0: set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2] sl@0: http::config -urlencoding $enc sl@0: set res sl@0: } {name1=~bwelch&name2=%a1%a2%a2} sl@0: sl@0: test http-6.1 {http::ProxyRequired} { sl@0: http::config -proxyhost [info hostname] -proxyport $port sl@0: set token [http::geturl $url] sl@0: http::wait $token sl@0: http::config -proxyhost {} -proxyport {} sl@0: upvar #0 $token data sl@0: set data(body) sl@0: } "HTTP/1.0 TEST sl@0:

Hello, World!

sl@0:

GET http:$url

sl@0: " sl@0: sl@0: test http-7.1 {http::mapReply} { sl@0: http::mapReply "abc\$\[\]\"\\()\}\{" sl@0: } {abc%24%5b%5d%22%5c%28%29%7d%7b} sl@0: test http-7.2 {http::mapReply} { sl@0: # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default, sl@0: # so make sure this gets converted to utf-8 then urlencoded. sl@0: http::mapReply "\u2208" sl@0: } {%e2%88%88} sl@0: test http-7.3 {http::formatQuery} { sl@0: set enc [http::config -urlencoding] sl@0: # this would be reverting to http <=2.4 behavior sl@0: http::config -urlencoding "" sl@0: set res [list [catch {http::mapReply "\u2208"} msg] $msg] sl@0: http::config -urlencoding $enc sl@0: set res sl@0: } [list 1 "can't read \"formMap(\u2208)\": no such element in array"] sl@0: test http-7.4 {http::formatQuery} { sl@0: set enc [http::config -urlencoding] sl@0: # this would be reverting to http <=2.4 behavior w/o errors sl@0: # (unknown chars become '?') sl@0: http::config -urlencoding "iso8859-1" sl@0: set res [http::mapReply "\u2208"] sl@0: http::config -urlencoding $enc sl@0: set res sl@0: } {%3f} sl@0: sl@0: # cleanup sl@0: catch {unset url} sl@0: catch {unset badurl} sl@0: catch {unset port} sl@0: catch {unset data} sl@0: if {[info exists httpthread]} { sl@0: testthread send -async $httpthread { sl@0: testthread exit sl@0: } sl@0: } else { sl@0: close $listen sl@0: } sl@0: sl@0: if {[info exists removeHttpd]} { sl@0: removeFile $httpdFile sl@0: } sl@0: sl@0: rename bgerror {} sl@0: ::tcltest::cleanupTests