# Commands covered:  http::config, http::geturl, http::wait, http::reset

#

# This file contains a collection of tests for the http script library.

# Sourcing this file into Tcl runs the tests and

# generates output for errors.  No output means no errors were found.

#

# Copyright (c) 1991-1993 The Regents of the University of California.

# Copyright (c) 1994-1996 Sun Microsystems, Inc.

# Copyright (c) 1998-2000 by Ajuba Solutions.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

#

# RCS: @(#) $Id: http.test,v 1.33.2.6 2006/10/06 19:00:53 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {

    package require tcltest 2

    namespace import -force ::tcltest::*

}

if {[catch {package require http 2} version]} {

    if {[info exists http2]} {

	catch {puts "Cannot load http 2.* package"}

	return

    } else {

	catch {puts "Running http 2.* tests in slave interp"}

	set interp [interp create http2]

	$interp eval [list set http2 "running"]

	$interp eval [list set argv $argv]

	$interp eval [list source [info script]]

	interp delete $interp

	return

    }

}

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"

catch {unset data}

# Ensure httpd file exists

set origFile [file join [pwd] [file dirname [info script]] httpd]

set httpdFile [file join [temporaryDirectory] httpd_[pid]]

if {![file exists $httpdFile]} {

    makeFile "" $httpdFile

    file delete $httpdFile

    file copy $origFile $httpdFile

    set removeHttpd 1

}

if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {

    set httpthread [testthread create "

	source [list $httpdFile]

	testthread wait

    "]

    testthread send $httpthread [list set port $port]

    testthread send $httpthread [list set bindata $bindata]

    testthread send $httpthread {httpd_init $port}

    puts "Running httpd in thread $httpthread"

} else {

    if {![file exists $httpdFile]} {

	puts "Cannot read $httpdFile script, http test skipped"

	unset port

	return

    }

    source $httpdFile

    # Let the OS pick the port; that's much more flexible

    if {[catch {httpd_init 0} listen]} {

	puts "Cannot start http server, http test skipped"

	unset port

	return

    } else {

	set port [lindex [fconfigure $listen -sockname] 2]

    }

}

test http-1.1 {http::config} {

    http::config

} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]

test http-1.2 {http::config} {

    http::config -proxyfilter

} http::ProxyRequired

test http-1.3 {http::config} {

    catch {http::config -junk}

} 1

test http-1.4 {http::config} {

    set savedconf [http::config]

    http::config -proxyhost nowhere.come -proxyport 8080 \

	-proxyfilter myFilter -useragent "Tcl Test Suite" \

	-urlencoding iso8859-1

    set x [http::config]

    eval http::config $savedconf

    set x

} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}

test http-1.5 {http::config} {

    list [catch {http::config -proxyhost {} -junk 8080} msg] $msg

} {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}

test http-1.6 {http::config} {

    set enc [list [http::config -urlencoding]]

    http::config -urlencoding iso8859-1

    lappend enc [http::config -urlencoding]

    http::config -urlencoding [lindex $enc 0]

    set enc

} {utf-8 iso8859-1}

test http-2.1 {http::reset} {

    catch {http::reset http#1}

} 0

test http-3.1 {http::geturl} {

    list [catch {http::geturl -bogus flag} msg] $msg

} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}

test http-3.2 {http::geturl} {

    catch {http::geturl http:junk} err

    set err

} {Unsupported URL: http:junk}

set url //[info hostname]:$port

set badurl //[info hostname]:6666

test http-3.3 {http::geturl} {

    set token [http::geturl $url]

    http::data $token

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET /</h2>

</body></html>"

set tail /a/b/c

set url //[info hostname]:$port/a/b/c

set fullurl http://user:pass@[info hostname]:$port/a/b/c

set binurl //[info hostname]:$port/binary

set posturl //[info hostname]:$port/post

set badposturl //[info hostname]:$port/droppost

set badcharurl //%user@[info hostname]:$port/a/^b/c

test http-3.4 {http::geturl} {

    set token [http::geturl $url]

    http::data $token

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET $tail</h2>

</body></html>"

proc selfproxy {host} {

    global port

    return [list [info hostname] $port]

}

test http-3.5 {http::geturl} {

    http::config -proxyfilter selfproxy

    set token [http::geturl $url]

    http::config -proxyfilter http::ProxyRequired

    http::data $token

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET http:$url</h2>

</body></html>"

test http-3.6 {http::geturl} {

    http::config -proxyfilter bogus

    set token [http::geturl $url]

    http::config -proxyfilter http::ProxyRequired

    http::data $token

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET $tail</h2>

</body></html>"

test http-3.7 {http::geturl} {

    set token [http::geturl $url -headers {Pragma no-cache}]

    http::data $token

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET $tail</h2>

</body></html>"

test http-3.8 {http::geturl} {

    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>

<h2>POST $tail</h2>

<h2>Query</h2>

<dl>

<dt>Name<dd>Value

<dt>Foo<dd>Bar

</dl>

</body></html>"

test http-3.9 {http::geturl} {

    set token [http::geturl $url -validate 1]

    http::code $token

} "HTTP/1.0 200 OK"

test http-3.10 {http::geturl queryprogress} {

    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 &

    }

    proc postProgress {token x y} {

	global postProgress

	lappend postProgress $y

    }

    set postProgress {}

    set t [http::geturl $posturl -query $query \

	    -queryprogress postProgress -queryblocksize 16384]

    http::wait $t

    list [http::status $t] [string length $query] $postProgress [http::data $t]

} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}

test http-3.11 {http::geturl querychannel with -command} {

    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 &

    }

    set file [makeFile $query outdata]

    set fp [open $file]

    proc asyncCB {token} {

	global postResult

	lappend postResult [http::data $token]

    }

    set postResult [list ]

    set t [http::geturl $posturl -querychannel $fp]

    http::wait $t

    set testRes [list [http::status $t] [string length $query] [http::data $t]]

    # Now do async

    http::cleanup $t

    close $fp

    set fp [open $file]

    set t [http::geturl $posturl -querychannel $fp -command asyncCB]

    set postResult [list PostStart]

    http::wait $t

    close $fp

    lappend testRes [http::status $t] $postResult

    removeFile outdata

    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 &

    }

    set file [makeFile $query outdata]

    set fp [open $file]

    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

    }

    removeFile outdata

    list [http::status $t] [http::code $t]

} {ok {HTTP/1.0 200 Data follows}}

test http-3.13 {http::geturl socket leak test} {

    set chanCount [llength [file channels]]

    for {set i 0} {$i < 3} {incr i} {

	catch {http::geturl $badurl -timeout 5000}

    }

    # No extra channels should be taken

    expr {[llength [file channels]] == $chanCount}

} 1

test http-3.14 "http::geturl $fullurl" {

    set token [http::geturl $fullurl -validate 1]

    http::code $token

} "HTTP/1.0 200 OK"

test http-3.15 {http::geturl parse failures} -body {

    http::geturl "{invalid}:url"

} -returnCodes error -result {Unsupported URL: {invalid}:url}

test http-3.16 {http::geturl parse failures} -body {

    http::geturl http:relative/url

} -returnCodes error -result {Unsupported URL: http:relative/url}

test http-3.17 {http::geturl parse failures} -body {

    http::geturl /absolute/url

} -returnCodes error -result {Missing host part: /absolute/url}

test http-3.18 {http::geturl parse failures} -body {

    http::geturl http://somewhere:123456789/

} -returnCodes error -result {Invalid port number: 123456789}

test http-3.19 {http::geturl parse failures} -body {

    set ::http::strict 1

    http::geturl http://{user}@somewhere

} -returnCodes error -result {Illegal characters in URL user}

test http-3.20 {http::geturl parse failures} -body {

    set ::http::strict 1

    http::geturl http://%user@somewhere

} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}

test http-3.21 {http::geturl parse failures} -body {

    set ::http::strict 1

    http::geturl http://somewhere/{path}

} -returnCodes error -result {Illegal characters in URL path}

test http-3.22 {http::geturl parse failures} -body {

    set ::http::strict 1

    http::geturl http://somewhere/%path

} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}

test http-3.23 {http::geturl parse failures} -body {

    set ::http::strict 1

    http::geturl http://somewhere/path?{query}

} -returnCodes error -result {Illegal characters in URL path}

test http-3.24 {http::geturl parse failures} -body {

    set ::http::strict 1

    http::geturl http://somewhere/path?%query

} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}

test http-3.25 {http::geturl parse failures} -body {

    set ::http::strict 0

    set token [http::geturl $badcharurl]

    http::cleanup $token

} -returnCodes ok -result {}

test http-4.1 {http::Event} {

    set token [http::geturl $url]

    upvar #0 $token data

    array set meta $data(meta)

    expr ($data(totalsize) == $meta(Content-Length))

} 1

test http-4.2 {http::Event} {

    set token [http::geturl $url]

    upvar #0 $token data

    array set meta $data(meta)

    string compare $data(type) [string trim $meta(Content-Type)]

} 0

test http-4.3 {http::Event} {

    set token [http::geturl $url]

    http::code $token

} {HTTP/1.0 200 Data follows}

test http-4.4 {http::Event} {

    set testfile [makeFile "" testfile]

    set out [open $testfile w]

    set token [http::geturl $url -channel $out]

    close $out

    set in [open $testfile]

    set x [read $in]

    close $in

    removeFile $testfile

    set x

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET $tail</h2>

</body></html>"

test http-4.5 {http::Event} {

    set testfile [makeFile "" testfile]

    set out [open $testfile w]

    set token [http::geturl $url -channel $out]

    close $out

    upvar #0 $token data

    removeFile $testfile

    expr $data(currentsize) == $data(totalsize)

} 1

test http-4.6 {http::Event} {

    set testfile [makeFile "" testfile]

    set out [open $testfile w]

    set token [http::geturl $binurl -channel $out]

    close $out

    set in [open $testfile]

    fconfigure $in -translation binary

    set x [read $in]

    close $in

    removeFile $testfile

    set x

} "$bindata[string trimleft $binurl /]"

proc myProgress {token total current} {

    global progress httpLog

    if {[info exists httpLog] && $httpLog} {

	puts "progress $total $current"

    }

    set progress [list $total $current]

}

if 0 {

    # This test hangs on Windows95 because the client never gets EOF

    set httpLog 1

    test http-4.6.1 {http::Event} knownBug {

	set token [http::geturl $url -blocksize 50 -progress myProgress]

	set progress

    } {111 111}

}

test http-4.7 {http::Event} {

    set token [http::geturl $url -progress myProgress]

    set progress

} {111 111}

test http-4.8 {http::Event} {

    set token [http::geturl $url]

    http::status $token

} {ok}

test http-4.9 {http::Event} {

    set token [http::geturl $url -progress myProgress]

    http::code $token

} {HTTP/1.0 200 Data follows}

test http-4.10 {http::Event} {

    set token [http::geturl $url -progress myProgress]

    http::size $token

} {111}

# Timeout cases

#	Short timeout to working server (the test server). 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 -command {#}]

    http::reset $token

    http::status $token

} {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 $url?timeout=30 -timeout 10 -command {#}]

    http::wait $token

    http::status $token

} {timeout}

#	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 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 [regexp {(connect failed|couldn't open socket)} $err]

} {1 1}

# Bogus host

test http-4.15 {http::Event} {

    # This test may fail if you use a proxy server.  That is to be

    # expected and is not a problem with Tcl.

    set code [catch {

	set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}]

	http::wait $token

	http::status $token

    } err]

    # error code varies among platforms.

    list $code [string match "couldn't open socket*" $err]

} {1 1}

test http-5.1 {http::formatQuery} {

    http::formatQuery name1 value1 name2 "value two"

} {name1=value1&name2=value%20two}

# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5

test http-5.3 {http::formatQuery} {

    http::formatQuery lines "line1\nline2\nline3"

} {lines=line1%0d%0aline2%0d%0aline3}

test http-5.4 {http::formatQuery} {

    http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2

} {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2}

test http-5.5 {http::formatQuery} {

    set enc [http::config -urlencoding]

    http::config -urlencoding iso8859-1

    set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]

    http::config -urlencoding $enc

    set res

} {name1=~bwelch&name2=%a1%a2%a2}

test http-6.1 {http::ProxyRequired} {

    http::config -proxyhost [info hostname] -proxyport $port

    set token [http::geturl $url]

    http::wait $token

    http::config -proxyhost {} -proxyport {}

    upvar #0 $token data

    set data(body)

} "<html><head><title>HTTP/1.0 TEST</title></head><body>

<h1>Hello, World!</h1>

<h2>GET http:$url</h2>

</body></html>"

test http-7.1 {http::mapReply} {

    http::mapReply "abc\$\[\]\"\\()\}\{"

} {abc%24%5b%5d%22%5c%28%29%7d%7b}

test http-7.2 {http::mapReply} {

    # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,

    # so make sure this gets converted to utf-8 then urlencoded.

    http::mapReply "\u2208"

} {%e2%88%88}

test http-7.3 {http::formatQuery} {

    set enc [http::config -urlencoding]

    # this would be reverting to http <=2.4 behavior

    http::config -urlencoding ""

    set res [list [catch {http::mapReply "\u2208"} msg] $msg]

    http::config -urlencoding $enc

    set res

} [list 1 "can't read \"formMap(\u2208)\": no such element in array"]

test http-7.4 {http::formatQuery} {

    set enc [http::config -urlencoding]

    # this would be reverting to http <=2.4 behavior w/o errors

    # (unknown chars become '?')

    http::config -urlencoding "iso8859-1"

    set res [http::mapReply "\u2208"]

    http::config -urlencoding $enc

    set res

} {%3f}

# cleanup

catch {unset url}

catch {unset badurl}

catch {unset port}

catch {unset data}

if {[info exists httpthread]} {

    testthread send -async $httpthread {

	testthread exit

    }

} else {

    close $listen

}

if {[info exists removeHttpd]} {

    removeFile $httpdFile

}

rename bgerror {}

::tcltest::cleanupTests