Check-in [2f852e2ef6]
Bounty program for improvements to Tcl and certain Tcl packages.
Overview
Comment: * tests/simpleClient.tcl: * tests/simpleServer.tcl: added simple client/server test scripts that use test certs and can do simple stress tests.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 2f852e2ef62669b918fac046b734867d3103a225
User & Date: hobbs on 2000-08-15 17:05:10
Other Links: manifest | tags
Context
2000-08-15
18:45
* tests/all.tcl: added catch around ::tcltest::normalizePath because it doesn't exist in pre-8.3 tcltest. check-in: a0a66662a3 user: hobbs tags: trunk
17:05
* tests/simpleClient.tcl: * tests/simpleServer.tcl: added simple client/server test scripts that use test certs and can do simple stress tests. check-in: 2f852e2ef6 user: hobbs tags: trunk
00:02
* tlsInt.h: * tlsIO.c: * tlsBIO.c: * tls.c: changed around to only working with 8.2.0+ (8.3.2+ preferred), with runtime checks for pre- and post-io-rewrite. check-in: 33ea0b5a9d user: hobbs tags: trunk
Changes

Modified ChangeLog from [90bb6e0e94] to [00d4c60b28].

            1  +2000-08-15  Jeff Hobbs  <[email protected]>
            2  +
            3  +	* tests/simpleClient.tcl: 
            4  +	* tests/simpleServer.tcl: added simple client/server test scripts
            5  +	that use test certs and can do simple stress tests.
            6  +
     1      7   2000-08-14  Jeff Hobbs  <[email protected]>
     2      8   
     3      9   	* tlsInt.h:
     4     10   	* tlsIO.c:
     5     11   	* tlsBIO.c:
     6     12   	* tls.c: changed around to only working with 8.2.0+ (8.3.2+
     7     13   	preferred), with runtime checks for pre- and post-io-rewrite.

Added tests/simpleClient.tcl version [3d5b5fbeb8].

            1  +#!/bin/sh
            2  +# The next line is executed by /bin/sh, but not tcl \
            3  +exec tclsh8.3 "$0" ${1+"[email protected]"}
            4  +
            5  +package require tls
            6  +
            7  +set dir			[file join [file dirname [info script]] ../tests/certs]
            8  +set OPTS(-cafile)	[file join $dir cacert.pem]
            9  +set OPTS(-cert)		[file join $dir client.pem]
           10  +set OPTS(-key)		[file join $dir ckey.pem]
           11  +
           12  +set OPTS(-host)		localhost
           13  +set OPTS(-port)		2468
           14  +set OPTS(-debug)	1
           15  +set OPTS(-count)	8
           16  +set OPTS(-parallel)	1
           17  +
           18  +foreach {key val} $argv {
           19  +    if {![info exists OPTS($key)]} {
           20  +	puts stderr "Usage: $argv0 ?options?\
           21  +		\n\t-debug     boolean   Debugging on or off ($OPTS(-debug))\
           22  +		\n\t-cafile    file      Cert. Auth. File ($OPTS(-cafile))\
           23  +		\n\t-client    file      Client Cert ($OPTS(-cert))\
           24  +		\n\t-ckey      file      Client Key ($OPTS(-key))\
           25  +		\n\t-count     num       No of sync. connections to make per client ($OPTS(-count))\
           26  +		\n\t-parallel  num       No of parallel clients to run ($OPTS(-parallel))\
           27  +		\n\t-host      hostname  Server hostname ($OPTS(-host))\
           28  +		\n\t-port      num       Server port ($OPTS(-port))"
           29  +	exit
           30  +    }
           31  +    set OPTS($key) $val
           32  +}
           33  +
           34  +if {$OPTS(-parallel) > 1} {
           35  +    # If they wanted parallel, we just spawn ourselves several times
           36  +    # with the right args.
           37  +
           38  +    set cmd	[info nameofexecutable]
           39  +    set script	[info script]
           40  +    for {set i 0} {$i < $OPTS(-parallel)} {incr i} {
           41  +	eval [list exec $cmd $script] [array get OPTS] [list -parallel 0] &
           42  +    }
           43  +    exit
           44  +}
           45  +
           46  +# Local handler for any background errors.
           47  +proc bgerror {msg} { puts "BGERROR: $msg" }
           48  +
           49  +# debugging helper code
           50  +proc shortstr {str} {
           51  +    return "[string replace $str 10 end ...] [string length $str]b"
           52  +}
           53  +proc dputs {msg} { if {$::OPTS(-debug)} { puts stderr $msg ; flush stderr } }
           54  +
           55  +set OPTS(openports)	0
           56  +
           57  +# Define what we want to feed down the pipe
           58  +set megadata [string repeat [string repeat A 76]\n 1000]
           59  +
           60  +proc drain {chan} {
           61  +    global OPTS
           62  +    if {[catch {read $chan} data]} {
           63  +	#dputs "EOF $chan ([shortstr $data])"
           64  +	incr OPTS(openports) -1
           65  +	catch {close $chan}
           66  +	return
           67  +    }
           68  +    #if {$data != ""} { dputs "got $chan ([shortstr $data])" }
           69  +    if {[string match *CLOSE\n $data]} {
           70  +	dputs "CLOSE $chan"
           71  +	incr OPTS(openports) -1
           72  +	close $chan
           73  +	return
           74  +    } elseif {[eof $chan]} {
           75  +	# client gone or finished
           76  +	dputs "EOF $chan"
           77  +	incr OPTS(openports) -1
           78  +	close $chan
           79  +	return
           80  +    }
           81  +}
           82  +
           83  +proc feed {sock} {
           84  +    dputs "feed $sock ([shortstr $::megadata])"
           85  +    puts $sock $::megadata
           86  +    flush $sock
           87  +    puts $sock CLOSE
           88  +    flush $sock
           89  +    fileevent $sock writable {}
           90  +}
           91  +
           92  +proc go {} {
           93  +    global OPTS
           94  +    for {set num $OPTS(-count)} {$num > 0} {incr num -1} {
           95  +	set sock [tls::socket $OPTS(-host) $OPTS(-port)]
           96  +	incr OPTS(openports)
           97  +	fconfigure $sock -blocking 0 -buffersize 4096
           98  +	fileevent $sock writable [list feed $sock ]
           99  +	fileevent $sock readable [list drain $sock]
          100  +	dputs "created $sock"
          101  +    }
          102  +    while {1} {
          103  +	# Make sure to wait until all our sockets close down.
          104  +	vwait OPTS(openports)
          105  +	if {$OPTS(openports) == 0} {
          106  +	    exit 0
          107  +	}
          108  +    }
          109  +}
          110  +
          111  +tls::init -cafile $OPTS(-cafile) -certfile $OPTS(-cert) -keyfile $OPTS(-key)
          112  +
          113  +go

Added tests/simpleServer.tcl version [86951f40b8].

            1  +#!/bin/sh
            2  +# The next line is executed by /bin/sh, but not tcl \
            3  +exec tclsh8.3 "$0" ${1+"[email protected]"}
            4  +
            5  +package require tls
            6  +
            7  +set dir			[file join [file dirname [info script]] ../tests/certs]
            8  +set OPTS(-cafile)	[file join $dir cacert.pem]
            9  +set OPTS(-cert)		[file join $dir server.pem]
           10  +set OPTS(-key)		[file join $dir skey.pem]
           11  +
           12  +set OPTS(-port)	2468
           13  +set OPTS(-debug) 1
           14  +set OPTS(-require) 1
           15  +
           16  +foreach {key val} $argv {
           17  +    if {![info exists OPTS($key)]} {
           18  +	puts stderr "Usage: $argv0 ?options?\
           19  +		\n\t-debug    boolean  Debugging on or off ($OPTS(-debug))\
           20  +		\n\t-cafile   file     Cert. Auth. File ($OPTS(-cafile))\
           21  +		\n\t-cert     file     Server Cert ($OPTS(-cert))\
           22  +		\n\t-key      file     Server Key ($OPTS(-key))\
           23  +		\n\t-require  boolean  Require Certification ($OPTS(-require))\
           24  +		\n\t-port     num      Port to listen on ($OPTS(-port))"
           25  +	exit
           26  +    }
           27  +    set OPTS($key) $val
           28  +}
           29  +
           30  +# Catch  any background errors.
           31  +proc bgerror {msg} { puts stderr "BGERROR: $msg" }
           32  +
           33  +# debugging helper code
           34  +proc shortstr {str} {
           35  +    return "[string replace $str 10 end ...] [string length $str]b"
           36  +}
           37  +proc dputs {msg} { if {$::OPTS(-debug)} { puts stderr $msg ; flush stderr } }
           38  +
           39  +# As a response we just echo the data sent to us.
           40  +#
           41  +proc respond {chan} {
           42  +    if {[catch {read $chan} data]} {
           43  +	#dputs "EOF $chan ([shortstr $data)"
           44  +	catch {close $chan}
           45  +	return
           46  +    }
           47  +    #if {$data != ""} { dputs "got $chan ([shortstr $data])" }
           48  +    if {[eof $chan]} {
           49  +	# client gone or finished
           50  +	dputs "EOF $chan"
           51  +	close $chan		;#  release the port
           52  +	return
           53  +    }
           54  +    puts -nonewline $chan $data
           55  +    flush $chan
           56  +    #dputs "sent $chan ([shortstr $data])"
           57  +}
           58  +
           59  +# Once connection is established, we need to ensure handshake.
           60  +#
           61  +proc handshake {s cmd} {
           62  +    if {[eof $s]} {
           63  +	dputs "handshake eof $s"
           64  +	close $s
           65  +    } elseif {[catch {tls::handshake $s} result]} {
           66  +	# Some errors are normal.  Specifically, I (hobbs) believe that
           67  +	# TLS throws EAGAINs when it may not need to (or is inappropriate).
           68  +	dputs "handshake error $s: $result"
           69  +    } elseif {$result == 1} {
           70  +	# Handshake complete
           71  +	dputs "handshake complete $s"
           72  +	fileevent $s readable [list $cmd $s]
           73  +    }
           74  +}
           75  +
           76  +# Callback proc to accept a connection from a client.
           77  +#
           78  +proc accept { chan ip port } {
           79  +    dputs "[info level 0] [fconfigure $chan]"
           80  +    fconfigure $chan -blocking 0
           81  +    fileevent $chan readable [list handshake $chan respond]
           82  +}
           83  +
           84  +tls::init -cafile $OPTS(-cafile) -certfile $OPTS(-cert) -keyfile $OPTS(-key)
           85  +set chan [tls::socket -server accept -require $OPTS(-require) $OPTS(-port)]
           86  +
           87  +puts "Server waiting connection on $chan ($OPTS(-port))"
           88  +puts [fconfigure $chan]
           89  +
           90  +vwait __forever__