diff options
Diffstat (limited to 'tls/tests/tlsIO.test')
-rwxr-xr-x | tls/tests/tlsIO.test | 2072 |
1 files changed, 0 insertions, 2072 deletions
diff --git a/tls/tests/tlsIO.test b/tls/tests/tlsIO.test deleted file mode 100755 index e1d855a..0000000 --- a/tls/tests/tlsIO.test +++ /dev/null @@ -1,2072 +0,0 @@ -# Commands tested in this file: socket. -*- tcl -*- -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 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: tlsIO.test,v 1.24 2015/06/06 09:07:08 apnadkarni Exp $ - -# Running socket tests with a remote server: -# ------------------------------------------ -# -# Some tests in socket.test depend on the existence of a remote server to -# which they connect. The remote server must be an instance of tcltest and it -# must run the script found in the file "remote.tcl" in this directory. You -# can start the remote server on any machine reachable from the machine on -# which you want to run the socket tests, by issuing: -# -# tcltest remote.tcl -port 8048 # Or choose another port number. -# -# If the machine you are running the remote server on has several IP -# interfaces, you can choose which interface the server listens on for -# connections by specifying the -address command line flag, so: -# -# tcltest remote.tcl -address your.machine.com -# -# These options can also be set by environment variables. On Unix, you can -# type these commands to the shell from which the remote server is started: -# -# shell% setenv serverPort 8048 -# shell% setenv serverAddress your.machine.com -# -# and subsequently you can start the remote server with: -# -# tcltest remote.tcl -# -# to have it listen on port 8048 on the interface your.machine.com. -# -# When the server starts, it prints out a detailed message containing its -# configuration information, and it will block until killed with a Ctrl-C. -# Once the remote server exists, you can run the tests in socket.test with -# the server by setting two Tcl variables: -# -# % set remoteServerIP <name or address of machine on which server runs> -# % set remoteServerPort 8048 -# -# These variables are also settable from the environment. On Unix, you can: -# -# shell% setenv remoteServerIP machine.where.server.runs -# shell% setenv remoteServerPort 8048 -# -# The preamble of the socket.test file checks to see if the variables are set -# either in Tcl or in the environment; if they are, it attempts to connect to -# the server. If the connection is successful, the tests using the remote -# server will be performed; otherwise, it will attempt to start the remote -# server (via exec) on platforms that support this, on the local host, -# listening at port 8048. If all fails, a message is printed and the tests -# using the remote server are not performed. - -proc dputs {msg} { return ; puts stderr $msg ; flush stderr } - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -# The build dir is added as the first element of $PATH -set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] -# Load the tls package -package require tls 1.6 - -set tlsServerPort 8048 - -# Specify where the certificates are - -set certsDir [file join [file dirname [info script]] certs] -set serverCert [file join $certsDir server.pem] -set clientCert [file join $certsDir client.pem] -set caCert [file join $certsDir ca.pem] -set serverKey [file join $certsDir server.key] -set clientKey [file join $certsDir client.key] - -# Some tests require the testthread and exec commands - -set ::tcltest::testConstraints(testthread) \ - [expr {[info commands testthread] != {}}] -set ::tcltest::testConstraints(exec) [expr {[info commands exec] != {}}] - -# -# If remoteServerIP or remoteServerPort are not set, check in the -# environment variables for externally set values. -# - -if {![info exists remoteServerIP]} { - if {[info exists env(remoteServerIP)]} { - set remoteServerIP $env(remoteServerIP) - } -} -if {![info exists remoteServerPort]} { - if {[info exists env(remoteServerPort)]} { - set remoteServerPort $env(remoteServerPort) - } else { - if {[info exists remoteServerIP]} { - set remoteServerPort $tlsServerPort - } - } -} - -proc do_handshake {s {type readable} {cmd {}} args} { - if {[eof $s]} { - close $s - dputs "handshake: eof" - set ::do_handshake "eof" - } elseif {[catch {tls::handshake $s} result]} { - # Some errors are normal. - dputs "handshake: $result" - } elseif {$result == 1} { - # Handshake complete - if {[llength $args]} { eval [list fconfigure $s] $args } - if {$cmd == ""} { - fileevent $s $type "" - } else { - fileevent $s $type "$cmd [list $s]" - } - dputs "handshake: complete" - set ::do_handshake "complete" - } else { - dputs "handshake: in progress" - } -} - -# -# Check if we're supposed to do tests against the remote server -# - -set doTestsWithRemoteServer 1 -if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { - set remoteServerIP 127.0.0.1 -} -if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { - set remoteServerPort $tlsServerPort -} - -# Attempt to connect to a remote server if one is already running. If it -# is not running or for some other reason the connect fails, attempt to -# start the remote server on the local host listening on port 8048. This -# is only done on platforms that support exec (i.e. not on the Mac). On -# platforms that do not support exec, the remote server must be started -# by the user before running the tests. - -set remoteProcChan "" -set commandSocket "" -if {$doTestsWithRemoteServer} { - catch {close $commandSocket} - if {[catch {set commandSocket [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP $remoteServerPort]}] != 0} { - if {[info commands exec] == ""} { - set noRemoteTestReason "can't exec" - set doTestsWithRemoteServer 0 - } else { - set remoteServerIP 127.0.0.1 - set remoteFile [file join [pwd] remote.tcl] - if {[catch {set remoteProcChan \ - [open "|[list $::tcltest::tcltest $remoteFile \ - -serverIsSilent -port $remoteServerPort \ - -address $remoteServerIP]" w+]} msg] == 0} { - after 1000 - if {[catch {set commandSocket [tls::socket -cafile $caCert \ - -certfile $clientCert -keyfile $clientKey \ - $remoteServerIP $remoteServerPort]} msg] == 0} { - fconfigure $commandSocket -translation crlf -buffering line - } else { - set noRemoteTestReason $msg - set doTestsWithRemoteServer 0 - } - } else { - set noRemoteTestReason "$msg $::tcltest::tcltest" - set doTestsWithRemoteServer 0 - } - } - } else { - fconfigure $commandSocket -translation crlf -buffering line - } -} - -# Some tests are run only if we are doing testing against a remote server. -set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer -if {$doTestsWithRemoteServer == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts "Skipping tests with remote server. See tests/socket.test for" - puts "information on how to run remote server." - puts "Reason for not doing remote tests: $noRemoteTestReason" - } -} - -# -# If we do the tests, define a command to send a command to the -# remote server. -# - -if {$doTestsWithRemoteServer == 1} { - proc sendCommand {c} { - global commandSocket - - if {[eof $commandSocket]} { - error "remote server disappeared" - } - - if {[catch {puts $commandSocket $c} msg]} { - error "remote server disappeared: $msg" - } - if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} { - error "remote server disappeared: $msg" - } - - set resp "" - while {1} { - set line [gets $commandSocket] - if {[eof $commandSocket]} { - error "remote server disappeared" - } - if {[string compare $line "--Marker--Marker--Marker--"] == 0} { - if {[string compare [lindex $resp 0] error] == 0} { - error [lindex $resp 1] - } else { - return [lindex $resp 1] - } - } else { - append resp $line "\n" - } - } - } - - sendCommand [list proc dputs [info args dputs] [info body dputs]] - - proc sendCertValues {} { - # We need to be able to send certificate values that normalize - # filenames across platforms - sendCommand { - set certsDir [file join [file dirname [info script]] certs] - set serverCert [file join $certsDir server.pem] - set clientCert [file join $certsDir client.pem] - set caCert [file join $certsDir cacert.pem] - set serverKey [file join $certsDir server.key] - set clientKey [file join $certsDir client.key] - } - } -} - -test tlsIO-1.1 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIO-1.2 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server foo} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIO-1.3 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myaddr} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.4 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myaddr 127.0.0.1} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.5 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myport} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.6 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myport xxxx} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.7 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myport 2522} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.8 {arg parsing for socket command} {socket} { - list [catch {tls::socket -froboz} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.9 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server foo -myport 2521 3333} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIO-1.10 {arg parsing for socket command} {socket} { - list [catch {tls::socket host 2528 -junk} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIO-1.11 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server callback 2520 --} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIO-1.12 {arg parsing for socket command} {socket} { - list [catch {tls::socket foo badport} msg] $msg -} {1 {expected integer but got "badport"}} - -test tlsIO-2.1 {tcp connection} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x timed_out"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" - puts $f { - proc accept {file addr port} { - global x - set x done - close $file - } - puts ready - vwait x - after cancel $timer - close $f - puts $x - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8828} msg]} { - set x $msg - } else { - lappend x [gets $f] - close $msg - } - lappend x [gets $f] - close $f - set x -} {ready done {}} - -if [info exists port] { - incr port -} else { - set port [expr {$tlsServerPort + [pid]%1024}] -} - -test tlsIO-2.2 {tcp connection with client port specified} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x done"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]" - puts $f { - proc accept {sock addr port} { - global x - puts "[gets $sock] $port" - close $sock - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - global port - if {[catch {tls::socket -myport $port \ - -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8829} sock]} { - set x $sock - catch {close [tls::socket 127.0.0.1 8829]} - } else { - puts $sock hello - flush $sock - lappend x [gets $f] - close $sock - } - close $f - set x -} [list ready "hello $port"] - -test tlsIO-2.3 {tcp connection with client interface specified} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x done"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]" - puts $f { - proc accept {sock addr port} { - global x - puts "[gets $sock] $addr" - close $sock - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -myaddr 127.0.0.1 \ - -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8830} sock]} { - set x $sock - } else { - puts $sock hello - catch {flush $sock} - lappend x [gets $f] - close $sock - } - close $f - set x -} {ready {hello 127.0.0.1}} - -test tlsIO-2.4 {tcp connection with server interface specified} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x done"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]" - puts $f { - proc accept {sock addr port} { - global x - puts "[gets $sock]" - close $sock - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey [info hostname] 8831} sock]} { - set x $sock - } else { - puts $sock hello - flush $sock - lappend x [gets $f] - close $sock - } - close $f - set x -} {ready hello} - -test tlsIO-2.5 {tcp connection with redundant server port} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x done"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]" - puts $f { - proc accept {sock addr port} { - global x - puts "[gets $sock]" - close $sock - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8832} sock]} { - set x $sock - } else { - puts $sock hello - flush $sock - lappend x [gets $f] - close $sock - } - close $f - set x -} {ready hello} -test tlsIO-2.6 {tcp connection} {socket} { - set status ok - if {![catch {set sock [tls::socket 127.0.0.1 8833]}]} { - if {![catch {gets $sock}]} { - set status broken - } - close $sock - } - set status -} ok - -test tlsIO-2.7 {echo server, one line} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x done"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834 \]" - puts $f { - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -translation lf -buffering line - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - puts $s $l - } - } - puts ready - vwait x - after cancel $timer - close $f - puts done - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8834] - fconfigure $s -buffering line -translation lf - puts $s "hello abcdefghijklmnop" - after 1000 - set x [gets $s] - close $s - set y [gets $f] - close $f - list $x $y -} {{hello abcdefghijklmnop} done} - -test tlsIO-2.8 {echo server, loop 50 times, single connection} {socket stdio} { - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835 \]" - puts $f { - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } - proc echo {s} { - global i - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - incr i - puts $s $l - } - } - set i 0 - puts ready - set timer [after 20000 "set x done"] - vwait x - after cancel $timer - close $f - puts "done $i" - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8835] - fconfigure $s -buffering line - catch { - for {set x 0} {$x < 50} {incr x} { - puts $s "hello abcdefghijklmnop" - gets $s - } - } - close $s - catch {set x [gets $f]} - close $f - set x -} {done 50} - -test tlsIO-2.9 {socket conflict} {socket stdio} { - set s [tls::socket -server accept 8828] - removeFile script - set f [open script w] - puts -nonewline $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - tls::socket -server accept 8828 - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - after 100 - set x [list [catch {close $f} msg] [string range $msg 0 43]] - close $s - set x -} {1 {couldn't open socket: address already in use}} - -test tlsIO-2.10 {close on accept, accepted socket lives} {socket} { - set done 0 - set timer [after 20000 "set done timed_out"] - set ss [tls::socket -server accept -certfile $serverCert -cafile $caCert \ - -keyfile $serverKey 8830] - proc accept {s a p} { - global ss - close $ss - fileevent $s readable "readit $s" - fconfigure $s -trans lf - } - proc readit {s} { - global done - gets $s - close $s - set done 1 - } - set cs [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey [info hostname] 8830] - close $cs - - vwait done - after cancel $timer - set done -} 1 - -test tlsIO-2.11 {detecting new data} {socket} { - proc accept {s a p} { - global sock - # when doing an in-process client/server test, both sides need - # to be non-blocking for the TLS handshake. Also make sure - # to return the channel to line buffering mode. - fconfigure $s -blocking 0 -buffering line - set sock $s - fileevent $s readable [list do_handshake $s] - } - - set s [tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8400] - set sock "" - set s2 [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8400] - # when doing an in-process client/server test, both sides need - # to be non-blocking for the TLS handshake Also make sure to - # return the channel to line buffering mode (TLS sets it to 'none'). - fconfigure $s2 -blocking 0 -buffering line - vwait sock - puts $s2 one - flush $s2 - # need update to complete TLS handshake in-process - update - after 500 - fconfigure $sock -blocking 0 - set result a:[gets $sock] - lappend result b:[gets $sock] - fconfigure $sock -blocking 1 - puts $s2 two - flush $s2 - fconfigure $sock -blocking 0 - lappend result c:[gets $sock] - fconfigure $sock -blocking 1 - close $s2 - close $s - close $sock - set result -} {a:one b: c:two} - -test tlsIO-2.12 {tcp connection; no certificates specified} \ - {socket stdio unixOnly} { - # There is a debug assertion on Windows/SSL that causes a crash when the - # certificate isn't specified. - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set timer [after 2000 "set x timed_out"] - set f [tls::socket -server accept 8828] - proc accept {file addr port} { - global x - set x done - close $file - } - puts ready - vwait x - after cancel $timer - close $f - puts $x - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket 127.0.0.1 8828} msg]} { - set x $msg - } else { - lappend x [gets $f] - close $msg - } - lappend x [gets $f] - close $f - set x -} {ready done {}} - -test tlsIO-3.1 {socket conflict} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" - puts $f { - puts ready - gets stdin - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r+] - gets $f - set x [list [catch {tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -server accept 8828} msg] \ - $msg] - puts $f bye - close $f - set x -} {1 {couldn't open socket: address already in use}} - -test tlsIO-3.2 {server with several clients} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set counter 0 - } - puts $f "set s \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" - puts $f { - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } - proc echo {s} { - global x - set l [gets $s] - if {[eof $s]} { - close $s - set x done - } else { - puts $s $l - } - } - puts ready - vwait x - after cancel $t1 - vwait x - after cancel $t2 - vwait x - after cancel $t3 - close $s - puts $x - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r+] - set x [gets $f] - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8828] - fconfigure $s1 -buffering line - set s2 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8828] - fconfigure $s2 -buffering line - set s3 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8828] - fconfigure $s3 -buffering line - for {set i 0} {$i < 100} {incr i} { - puts $s1 hello,s1 - gets $s1 - puts $s2 hello,s2 - gets $s2 - puts $s3 hello,s3 - gets $s3 - } - close $s1 - close $s2 - close $s3 - lappend x [gets $f] - close $f - set x -} {ready done} - -test tlsIO-4.1 {server with several clients} {socket stdio} { - # have seen intermittent hangs on Windows - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - gets stdin - } - puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]" - puts $f { - fconfigure $s -buffering line - for {set i 0} {$i < 100} {incr i} { - puts $s hello - gets $s - } - close $s - puts bye - gets stdin - } - close $f - set p1 [open "|[list $::tcltest::tcltest script]" r+] - fconfigure $p1 -buffering line - set p2 [open "|[list $::tcltest::tcltest script]" r+] - fconfigure $p2 -buffering line - set p3 [open "|[list $::tcltest::tcltest script]" r+] - fconfigure $p3 -buffering line - proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] - } - proc echo {s} { - global x - set l [gets $s] - if {[eof $s]} { - close $s - set x done - } else { - puts $s $l - } - } - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8828] - puts $p1 open - puts $p2 open - puts $p3 open - vwait x - vwait x - vwait x - after cancel $t1 - after cancel $t2 - after cancel $t3 - close $s - set l "" - lappend l [list p1 [gets $p1] $x] - lappend l [list p2 [gets $p2] $x] - lappend l [list p3 [gets $p3] $x] - puts $p1 bye - puts $p2 bye - puts $p3 bye - close $p1 - close $p2 - close $p3 - set l -} {{p1 bye done} {p2 bye done} {p3 bye done}} - -test tlsIO-4.2 {byte order problems, socket numbers, htons} {socket} { - set x ok - if {[catch {tls::socket -server dodo 0x3000} msg]} { - set x $msg - } else { - close $msg - } - set x -} ok - -test tlsIO-5.1 {byte order problems, socket numbers, htons} \ - {socket unixOnly notRoot} { - set x {couldn't open socket: not owner} - if {![catch {tls::socket -server dodo 0x1} msg]} { - set x {htons problem, should be disallowed, are you running as SU?} - close $msg - } - set x -} {couldn't open socket: not owner} -test tlsIO-5.2 {byte order problems, socket numbers, htons} {socket} { - set x {couldn't open socket: port number too high} - if {![catch {tls::socket -server dodo 0x10000} msg]} { - set x {port resolution problem, should be disallowed} - close $msg - } - set x -} {couldn't open socket: port number too high} -test tlsIO-5.3 {byte order problems, socket numbers, htons} \ - {socket unixOnly notRoot} { - set x {couldn't open socket: not owner} - if {![catch {tls::socket -server dodo 21} msg]} { - set x {htons problem, should be disallowed, are you running as SU?} - close $msg - } - set x -} {couldn't open socket: not owner} - -test tlsIO-6.1 {accept callback error} {socket stdio} { - # There is a debug assertion on Windows/SSL that causes a crash when the - # certificate isn't specified. - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - gets stdin - } - puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848] - close $f - set f [open "|[list $::tcltest::tcltest script]" r+] - proc bgerror args { - global x - set x $args - } - proc accept {s a p} {expr 10 / 0} - set s [tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8848] - puts $f hello - close $f - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - rename bgerror {} - set x -} {{divide by zero}} - -test tlsIO-7.1 {testing socket specific options} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f [list tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820] - puts $f { - proc accept args { - global x - set x done - } - puts ready - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8820] - set p [fconfigure $s -peername] - close $s - close $f - set l "" - lappend l [string compare [lindex $p 0] 127.0.0.1] - lappend l [string compare [lindex $p 2] 8820] - lappend l [llength $p] -} {0 0 3} - -test tlsIO-7.2 {testing socket specific options} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821" - puts $f { - proc accept args { - global x - set x done - } - puts ready - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8821] - set p [fconfigure $s -sockname] - close $s - close $f - set l "" - lappend l [llength $p] - lappend l [lindex $p 0] - lappend l [string equal [lindex $p 2] 8821] -} {3 127.0.0.1 0} - -test tlsIO-7.3 {testing socket specific options} {socket} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8822] - set l [llength [fconfigure $s]] - close $s - update - # A bug fixed in fconfigure for 8.3.4+ make this return 14 normally, - # but 12 in older versions. - expr {$l >= 12 && (($l % 2) == 0)} -} 1 - -# bug report #5812 fconfigure doesn't return value for '-sockname' - -test tlsIO-7.4 {testing socket specific options} {socket} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8823] - proc accept {s a p} { - global x - set x [fconfigure $s -sockname] - close $s - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8823] - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - close $s1 - set l "" - lappend l [lindex $x 2] [llength $x] -} {8823 3} - -# bug report #5812 fconfigure doesn't return value for '-sockname' - -test tlsIO-7.5 {testing socket specific options} {socket unixOrPc} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8829] - proc accept {s a p} { - global x - set x [fconfigure $s -sockname] - close $s - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8829] - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - close $s1 - set l "" - lappend l [lindex $x 0] [lindex $x 2] [llength $x] -} {127.0.0.1 8829 3} - -test tlsIO-8.1 {testing -async flag on sockets} {socket} { - # NOTE: This test may fail on some Solaris 2.4 systems. - # See notes in Tcl's socket.test. - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8830] - proc accept {s a p} { - global x - # when doing an in-process client/server test, both sides need - # to be non-blocking for the TLS handshake. Also make sure - # to return the channel to line buffering mode. - fconfigure $s -blocking 0 -buffering line - puts $s bye - # Only OpenSSL 0.9.5a on Windows seems to need the after (delayed) - # close, but it works just the same for all others. -hobbs - after 500 close $s - set x done - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -async [info hostname] 8830] - # when doing an in-process client/server test, both sides need - # to be non-blocking for the TLS handshake Also make sure to - # return the channel to line buffering mode (TLS sets it to 'none'). - fconfigure $s1 -blocking 0 -buffering line - vwait x - # TLS handshaking needs one byte from the client... - puts $s1 a - # need update to complete TLS handshake in-process - update - set z [gets $s1] - close $s - close $s1 - set z -} bye - -test tlsIO-9.1 {testing spurious events} {socket} { - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - proc accept {s a p} { - fconfigure $s -blocking 0 - fileevent $s readable [list do_handshake $s readable readlittle \ - -buffering none] - } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8831] - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8831] - # This differs from socket-9.1 in that both sides need to be - # non-blocking because of TLS' required handshake - fconfigure $c -blocking 0 - puts -nonewline $c 01234567890123456789012345678901234567890123456789 - close $c - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - close $s - list $spurious $len -} {0 50} - -test tlsIO-9.2 {testing async write, fileevents, flush on close} {socket} { - set firstblock [string repeat a 31] - set secondblock [string repeat b 65535] - proc accept {s a p} { - fconfigure $s -blocking 0 - fileevent $s readable [list do_handshake $s readable readable \ - -translation lf -buffersize 16384 -buffering line] - } - proc readable {s} { - set l [gets $s] - dputs "got \"[string replace $l 10 end-3 ...]\" \ - ([string length $l]) from $s" - fileevent $s readable {} - after 1000 respond $s - } - proc respond {s} { - global firstblock - dputs "send \"[string replace $firstblock 10 end-3 ...]\" \ - ([string length $firstblock]) down $s" - puts -nonewline $s $firstblock - after 1000 writedata $s - } - proc writedata {s} { - global secondblock - dputs "send \"[string replace $secondblock 10 end-3 ...]\" \ - ([string length $secondblock]) down $s" - puts -nonewline $s $secondblock - close $s - } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8832] - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8832] - fconfigure $c -blocking 0 -trans lf -buffering line - set count 0 - puts $c hello - proc readit {s} { - global count done - set data [read $s] - dputs "read \"[string replace $data 10 end-3 ...]\" \ - ([string length $data]) from $s" - incr count [string length $data] - if {[eof $s]} { - close $s - set done 1 - } - } - fileevent $c readable "readit $c" - set done 0 - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - close $s - list $count $done -} {65566 1} - -test tlsIO-9.3 {testing EOF stickyness} {unexplainedFailure socket} { - # HOBBS: never worked correctly - proc count_to_eof {s} { - global count done timer - set l [gets $s] - if {[eof $s]} { - incr count - if {$count > 9} { - close $s - set done true - set count {eof is sticky} - after cancel $timer - } - } - } - proc timerproc {} { - global done count c - set done true - set count {timer went off, eof is not sticky} - close $c - } - set count 0 - set done false - proc write_then_close {s} { - puts $s bye - close $s - } - proc accept {s a p} { - fconfigure $s -blocking 0 -buffering line -translation lf - fileevent $s writable [list do_handshake $s writable write_then_close \ - -buffering line -translation lf] - } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8833] - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8833] - fconfigure $c -blocking 0 -buffering line -translation lf - fileevent $c readable "count_to_eof $c" - set timer [after 2000 timerproc] - vwait done - close $s - set count -} {eof is sticky} - -removeFile script - -test tlsIO-10.1 {testing socket accept callback error handling} {socket} { - set goterror 0 - proc bgerror args {global goterror; set goterror 1} - set s [tls::socket -cafile $caCert -server accept 8898] - proc accept {s a p} {close $s; error} - set c [tls::socket -cafile $caCert 127.0.0.1 8898] - vwait goterror - close $s - close $c - set goterror -} 1 - -test tlsIO-11.1 {tcp connection} {socket doTestsWithRemoteServer} { - sendCertValues - sendCommand { - set socket9_1_test_server [tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834] - proc accept {s a p} { - tls::handshake $s - puts $s done - close $s - } - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8834] - set r [gets $s] - close $s - sendCommand {close $socket9_1_test_server} - set r -} done - -test tlsIO-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { - if {[info exists port]} { - incr port - } else { - set port [expr {$tlsServerPort + [pid]%1024}] - } - sendCertValues - sendCommand { - set socket9_2_test_server [tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835] - proc accept {s a p} { - tls::handshake $s - puts $s $p - close $s - } - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -myport $port $remoteServerIP 8835] - set r [gets $s] - close $s - sendCommand {close $socket9_2_test_server} - if {$r == $port} { - set result ok - } else { - set result broken - } - set result -} ok - -test tlsIO-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { - set status ok - if {![catch {set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIp 8836]}]} { - if {![catch {gets $s}]} { - set status broken - } - close $s - } - set status -} ok - -test tlsIO-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { - sendCertValues - sendCommand { - set socket10_6_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - proc accept {s a p} { - tls::handshake $s - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - close $s - } else { - puts $s $l - } - } - } - set f [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - fconfigure $f -translation crlf -buffering line - puts $f hello - set r [gets $f] - close $f - sendCommand {close $socket10_6_test_server} - set r -} hello - -test tlsIO-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { - sendCertValues - sendCommand { - set socket10_7_test_server [tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] - proc accept {s a p} { - tls::handshake $s - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - close $s - } else { - puts $s $l - } - } - } - set f [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - fconfigure $f -translation crlf -buffering line - for {set cnt 0} {$cnt < 50} {incr cnt} { - puts $f "hello, $cnt" - if {[string compare [gets $f] "hello, $cnt"] != 0} { - break - } - } - close $f - sendCommand {close $socket10_7_test_server} - set cnt -} 50 - -# Macintosh sockets can have more than one server per port -if {$tcl_platform(platform) == "macintosh"} { - set conflictResult {0 8836} -} else { - set conflictResult {1 {couldn't open socket: address already in use}} -} - -test tlsIO-11.6 {socket conflict} {socket doTestsWithRemoteServer} { - set s1 [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - if {[catch {set s2 [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836]} msg]} { - set result [list 1 $msg] - } else { - set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] - close $s2 - } - close $s1 - set result -} $conflictResult - -test tlsIO-11.7 {server with several clients} {socket doTestsWithRemoteServer} { - sendCertValues - sendCommand { - set socket10_9_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - close $s - } else { - puts $s $l - } - } - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - fconfigure $s1 -buffering line - set s2 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - fconfigure $s2 -buffering line - set s3 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - fconfigure $s3 -buffering line - for {set i 0} {$i < 100} {incr i} { - puts $s1 hello,s1 - gets $s1 - puts $s2 hello,s2 - gets $s2 - puts $s3 hello,s3 - gets $s3 - } - close $s1 - close $s2 - close $s3 - sendCommand {close $socket10_9_test_server} - set i -} 100 - -test tlsIO-11.8 {client with several servers} {socket doTestsWithRemoteServer} { - sendCertValues - sendCommand { - tls::init -certfile $serverCert -cafile $caCert -keyfile $serverKey - set s1 [tls::socket -server "accept 4003" 4003] - set s2 [tls::socket -server "accept 4004" 4004] - set s3 [tls::socket -server "accept 4005" 4005] - proc handshake {s mp} { - if {[eof $s]} { - close $s - } elseif {[catch {tls::handshake $s} result]} { - # Some errors are normal. - } elseif {$result == 1} { - # Handshake complete - fileevent $s readable "" - puts $s $mp - close $s - } - } - proc accept {mp s a p} { - # These have to accept non-blocking, because the handshaking - # order isn't deterministic - fconfigure $s -blocking 0 -buffering line - fileevent $s readable [list handshake $s $mp] - } - } - tls::init -certfile $clientCert -cafile $caCert -keyfile $clientKey - set s1 [tls::socket $remoteServerIP 4003] - set s2 [tls::socket $remoteServerIP 4004] - set s3 [tls::socket $remoteServerIP 4005] - set l "" - lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ - [gets $s3] [gets $s3] [eof $s3] - close $s1 - close $s2 - close $s3 - sendCommand { - close $s1 - close $s2 - close $s3 - } - set l -} {4003 {} 1 4004 {} 1 4005 {} 1} - -test tlsIO-11.9 {accept callback error} {socket doTestsWithRemoteServer} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - proc accept {s a p} {expr 10 / 0} - proc bgerror args { - global x - set x $args - } - sendCertValues - if {[catch {sendCommand { - set peername [fconfigure $callerSocket -peername] - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [lindex $peername 0] 8836] - close $s - }} msg]} { - close $s - error $msg - } - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - rename bgerror {} - set x -} {{divide by zero}} - -test tlsIO-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { - sendCertValues - sendCommand { - set socket10_12_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - proc accept {s a p} {close $s} - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - set p [fconfigure $s -peername] - set n [fconfigure $s -sockname] - set l "" - lappend l [lindex $p 2] [llength $p] [llength $p] - close $s - sendCommand {close $socket10_12_test_server} - set l -} {8836 3 3} - -test tlsIO-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { - # remote equivalent of 9.1 - sendCertValues - sendCommand { - set socket_test_server [tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] - proc handshake {s} { - if {[eof $s]} { - close $s - } elseif {[catch {tls::handshake $s} result]} { - # Some errors are normal. - } elseif {$result == 1} { - # Handshake complete - fileevent $s writable "" - after 100 writesome $s - } - } - proc accept {s a p} { - fconfigure $s -translation "auto lf" - fileevent $s writable [list handshake $s] - } - proc writesome {s} { - for {set i 0} {$i < 100} {incr i} { - puts $s "line $i from remote server" - } - close $s - } - } - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - # Get the buffering corrected - fconfigure $c -buffering line - # Put a byte into the client pipe to trigger TLS handshaking - puts $c a - fileevent $c readable [list readlittle $c] - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - sendCommand {close $socket_test_server} - list $spurious $len -} {0 2690} - -test tlsIO-11.12 {testing EOF stickyness} {unexplainedFailure socket doTestsWithRemoteServer} { - # remote equivalent of 9.3 - # HOBBS: never worked correctly - set counter 0 - set done 0 - proc count_up {s} { - global counter done after_id - set l [gets $s] - if {[eof $s]} { - incr counter - if {$counter > 9} { - set done {EOF is sticky} - after cancel $after_id - close $s - } - } - } - proc timed_out {} { - global c done - set done {timed_out, EOF is not sticky} - close $c - } - sendCertValues - sendCommand { - set socket10_14_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - proc accept {s a p} { - tls::handshake $s - after 100 close $s - } - } - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8836] - fileevent $c readable "count_up $c" - set after_id [after 1000 timed_out] - vwait done - sendCommand {close $socket10_14_test_server} - set done -} {EOF is sticky} - -test tlsIO-11.13 {testing async write, async flush, async close} \ - {socket doTestsWithRemoteServer} { - proc readit {s} { - global count done - set l [read $s] - incr count [string length $l] - if {[eof $s]} { - close $s - set done 1 - } - } - sendCertValues - sendCommand { - set firstblock [string repeat a 31] - set secondblock [string repeat b 65535] - set l [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8845] - proc accept {s a p} { - tls::handshake $s - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ - -buffering line - fileevent $s readable "readable $s" - } - proc readable {s} { - set l [gets $s] - fileevent $s readable {} - after 1000 respond $s - } - proc respond {s} { - global firstblock - puts -nonewline $s $firstblock - after 1000 writedata $s - } - proc writedata {s} { - global secondblock - puts -nonewline $s $secondblock - close $s - } - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8845] - fconfigure $s -blocking 0 -translation lf -buffering line - set count 0 - puts $s hello - fileevent $s readable "readit $s" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - sendCommand {close $l} - set count -} 65566 - -proc getdata {type file} { - # Read handler on the accepted socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x "read failed, error was $data" - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x "$type socket was inherited" - } else { - set x "$type socket was not inherited" - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } - return -} - -test tlsIO-12.1 {testing inheritance of server sockets} {socket exec} { - makeFile {} script1 - makeFile {} script2 - - # Script1 is just a 10 second delay. If the server socket - # is inherited, it will be held open for 10 seconds - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - # Script2 creates the server socket, launches script1, - # waits a second, and exits. The server socket will now - # be closed unless script1 inherited it. - - set f [open script2 w] - puts $f [list set tclsh $::tcltest::tcltest] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f "set f \[tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828\]" - puts $f { - proc accept { file addr port } { - close $file - } - exec $tclsh script1 & - close $f - after 1000 exit - vwait forever - } - close $f - - # Launch script2 and wait 5 seconds - - exec $::tcltest::tcltest script2 & - after 5000 { set ok_to_proceed 1 } - vwait ok_to_proceed - - # If we can still connect to the server, the socket got inherited. - - if {[catch {tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8828} msg]} { - set x {server socket was not inherited} - } else { - close $msg - set x {server socket was inherited} - } - - set x -} {server socket was not inherited} - -test tlsIO-12.2 {testing inheritance of client sockets} {socket exec} { - makeFile {} script1 - makeFile {} script2 - - # Script1 is just a 10 second delay. If the server socket - # is inherited, it will be held open for 10 seconds - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - # Script2 opens the client socket and writes to it. It then - # launches script1 and exits. If the child process inherited the - # client socket, the socket will still be open. - - set f [open script2 w] - puts $f [list set tclsh $::tcltest::tcltest] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 8829\]" - puts $f { - exec $tclsh script1 & - puts $f testing - flush $f - after 1000 exit - vwait forever - } - close $f - - # Create the server socket - - set server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8829] - proc accept { file host port } { - # When the client connects, establish the read handler - global server - close $server - fconfigure $file -blocking 0 - fileevent $file readable [list do_handshake $file readable \ - [list getdata client] -buffering line] - return - } - - # If the socket doesn't hit end-of-file in 5 seconds, the - # script1 process must have inherited the client. - - set failed 0 - after 5000 [list set failed 1] - - # Launch the script2 process - - exec $::tcltest::tcltest script2 & - - vwait x - if {!$failed} { - vwait failed - } - set x -} {client socket was not inherited} - -test tlsIO-12.3 {testing inheritance of accepted sockets} \ - {socket exec unixOnly} { - makeFile {} script1 - makeFile {} script2 - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - set f [open script2 w] - puts $f [list set tclsh $::tcltest::tcltest] - puts $f { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - } - puts $f "set f \[tls::socket -server accept \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey 8930\]" - puts $f { - proc accept { file host port } { - global tclsh - fconfigure $file -buffering line - puts $file {test data on socket} - exec $tclsh script1 & - after 1000 exit - } - vwait forever - } - close $f - - # Launch the script2 process and connect to it. See how long - # the socket stays open - - exec $::tcltest::tcltest script2 & - - after 2000 set ok_to_proceed 1 - vwait ok_to_proceed - - set f [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8930] - fconfigure $f -buffering full -blocking 0 - # We need to put a byte into the read queue, otherwise the - # TLS handshake doesn't finish - puts $f a; flush $f - fileevent $f readable [list getdata accepted $f] - - # If the socket is still open after 5 seconds, the script1 process - # must have inherited the accepted socket. - - set failed 0 - after 5000 set failed 1 - - vwait x - set x -} {accepted socket was not inherited} - -test tlsIO-13.1 {Testing use of shared socket between two threads} \ - {socket testthread} { - # HOBBS: never tested - removeFile script - threadReap - - makeFile { - set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] - package require tls - set f [tls::socket -server accept 8828] - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } - proc echo {s} { - global i - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - incr i - puts $s $l - } - } - set i 0 - vwait x - close $f - - # thread cleans itself up. - testthread exit - } script - - # create a thread - set serverthread [testthread create { source script } ] - update - - after 1000 - set s [tls::socket 127.0.0.1 8828] - fconfigure $s -buffering line - - catch { - puts $s "hello" - gets $s result - } - close $s - update - - after 2000 - lappend result [threadReap] - - set result - -} {hello 1} - -test tlsIO-14.1 {test tls::unimport} {socket} { - list [catch {tls::unimport} msg] $msg -} {1 {wrong # args: should be "tls::unimport channel"}} -test tlsIO-14.2 {test tls::unimport} {socket} { - list [catch {tls::unimport foo bar} msg] $msg -} {1 {wrong # args: should be "tls::unimport channel"}} -test tlsIO-14.3 {test tls::unimport} {socket} { - list [catch {tls::unimport bogus} msg] $msg -} {1 {can not find channel named "bogus"}} -test tlsIO-14.4 {test tls::unimport} {socket} { - # stdin can take different names as the "top" channel - list [catch {tls::unimport stdin} msg] \ - [string match {bad channel "*": not a TLS channel} $msg] -} {1 1} -test tlsIO-14.5 {test tls::unimport} {socket} { - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - proc accept {s a p} { - fconfigure $s -blocking 0 - fileevent $s readable [list do_handshake $s readable readlittle \ - -buffering none] - } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8831] - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8831] - # only the client gets tls::import - set res [tls::unimport $c] - list $res [catch {close $c} err] $err \ - [catch {close $s} err] $err -} {{} 0 {} 0 {}} - -test tls-bug58-1.0 {test protocol negotiation failure} {socket} { - # Following code is based on what was reported in bug #58. Prior - # to fix the program would crash with a segfault. - proc Accept {sock args} { - fconfigure $sock -blocking 0; - fileevent $sock readable [list Handshake $sock] - } - proc Handshake {sock} { - set ::done HAND - catch {tls::handshake $sock} msg - set ::done $msg - } - # NOTE: when doing an in-process client/server test, both sides need - # to be non-blocking for the TLS handshake - - # Server - Only accept TLS 1 or higher - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 1 -tls1.2 1 \ - -server Accept 8831] - # Client - Only propose SSL3 - set c [tls::socket -async \ - -cafile $caCert \ - -request 0 -require 0 -ssl2 0 -ssl3 1 -tls1 0 -tls1.1 0 -tls1.2 0 \ - [info hostname] 8831] - fconfigure $c -blocking 0 - puts $c a ; flush $c - after 5000 [list set ::done timeout] - vwait ::done - set ::done -} {handshake failed: wrong version number} - -# cleanup -if {[string match sock* $commandSocket] == 1} { - puts $commandSocket exit - flush $commandSocket -} -catch {close $commandSocket} -catch {close $remoteProcChan} -::tcltest::cleanupTests -flush stdout -return |