Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,27 @@ +2000-07-20 Jeff Hobbs + + * tests/tlsIO.test: corrected various tests to be correct for TLS + stacked channels (as opposed to the standard sockets the test + suite was adopted from). Key differences are that TLS cannot + operate in one process without all channels being non-blocking, or + the handshake will block, and handshaking must be forced in some + cases. Also, handshakes don't seem to complete unless the client + has placed at least one byte for the server to read in the channel. + + * tests/remote.tcl: corrected the finding of tests certificates + + * tlsIO.c (TlsCloseProc): removed deleting of timer handler as + that is handled by Tls_Clean. + + * tls.tcl (tls::_accept): corrected the internal _accept to + trickle callback errors to the user. + + * Makefile.in: made the install-binaries target regenerate the + pkgIndex.tcl correctly. The test target probably shouldn't screw + it up, but this is to be on the safe side. + 2000-07-17 Jeff Hobbs * pkgIndex.tcl.in: * configure.in: updated version to 1.4 Index: Makefile.in ================================================================== --- Makefile.in +++ Makefile.in @@ -10,11 +10,11 @@ # All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: Makefile.in,v 1.13 2000/06/21 21:00:56 wart Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.13.2.1 2000/07/21 05:32:56 hobbs Exp $ lib_BINARIES=$(tls_LIB_FILE) BINARIES=$(lib_BINARIES) @@ -93,10 +93,11 @@ mandir = @mandir@ includedir = @includedir@ oldincludedir = /usr/include DESTDIR = +RELPATH = @RELPATH@ pkgdatadir = $(datadir)/@PACKAGE@@VERSION@ pkglibdir = $(libdir)/@PACKAGE@@VERSION@ pkgincludedir = $(includedir)/@PACKAGE@@VERSION@ @@ -208,10 +209,13 @@ doc: install: all install-binaries install-libraries install-doc install-binaries: binaries install-lib-binaries install-bin-binaries + sed -e "s#\@RELPATH\@#$(RELPATH)#" \ + -e "s#\@tls_LIB_FILE\@#$(tls_LIB_FILE)#" \ + < $(srcdir)/pkgIndex.tcl.in > pkgIndex.tcl $(INSTALL_DATA) pkgIndex.tcl $(pkglibdir) #======================================================================== # This rule installs platform-independent files, such as header files. #======================================================================== Index: tests/remote.tcl ================================================================== --- tests/remote.tcl +++ tests/remote.tcl @@ -7,11 +7,11 @@ # Copyright (c) 1995-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: remote.tcl,v 1.4 2000/06/06 22:01:41 aborr Exp $ +# RCS: @(#) $Id: remote.tcl,v 1.4.2.1 2000/07/21 05:32:57 hobbs Exp $ # load tls package package require tls # Initialize message delimitor @@ -169,26 +169,17 @@ puts "" puts -nonewline "Type Ctrl-C to terminate--> " flush stdout } +set certsDir [file join [file dirname [info script]] certs] +set serverCert [file join $certsDir server.pem] +set caCert [file join $certsDir cacert.pem] +set serverKey [file join $certsDir skey.pem] if {[catch {set serverSocket \ - [tls::socket -myaddr $serverAddress -server __accept__ \ - -cafile [file join [pwd] certs cacert.pem] \ - -certfile [file join [pwd] certs server.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ + [tls::socket -myaddr $serverAddress -server __accept__ \ + -cafile $caCert -certfile $serverCert -keyfile $serverKey \ $serverPort]} msg]} { puts "Server on $serverAddress:$serverPort cannot start: $msg" } else { vwait __server_wait_variable__ } - - - - - - - - - - - Index: tests/tlsIO.test ================================================================== --- tests/tlsIO.test +++ tests/tlsIO.test @@ -8,11 +8,11 @@ # 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.14.2.3 2000/07/14 04:10:23 hobbs Exp $ +# RCS: @(#) $Id: tlsIO.test,v 1.14.2.4 2000/07/21 05:32:57 hobbs Exp $ # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to @@ -50,19 +50,21 @@ # % set remoteServerPort 8048 # # These variables are also settable from the environment. On Unix, you can: # # shell% setenv remoteServerIP machine.where.server.runs -# shell% senetv remoteServerPort 8048 +# 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::* } @@ -71,22 +73,24 @@ package require tls set tlsServerPort 8048 -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 skey.pem] -set clientKey [file join $certsDir ckey.pem] - -# Some tests require the testthread command +# 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 cacert.pem] +set serverKey [file join $certsDir skey.pem] +set clientKey [file join $certsDir ckey.pem] + +# 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. # @@ -103,10 +107,33 @@ 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 fconfigure $s $args } + if {$cmd == ""} { + fileevent $s $type "" + } else { + fileevent $s $type "$cmd $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 # @@ -129,30 +156,25 @@ set commandSocket "" if {$doTestsWithRemoteServer} { catch {close $commandSocket} if {[catch {set commandSocket [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP \ - $remoteServerPort]}] != 0} { + $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} { + [open "|[list $::tcltest::tcltest $remoteFile \ + -serverIsSilent -port $remoteServerPort \ + -address $remoteServerIP]" w+]} msg] == 0} { after 1000 - if {[catch {set commandSocket [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP \ - $remoteServerPort]} msg] == 0} { + 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 } @@ -211,10 +233,25 @@ } 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 skey.pem] + set clientKey [file join $certsDir ckey.pem] + } + } } 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"}} @@ -562,23 +599,14 @@ puts -nonewline $f {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] $msg] + 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 - while executing -"::socket -server {tls::_accept {-server 1} accept} 8828" - ("eval" body line 1) - invoked from within -"eval ::socket $sopts" - (procedure "tls::socket" line 62) - invoked from within -"tls::socket -server accept 8828" - (file "script" line 1)}} +} {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 \ @@ -602,45 +630,50 @@ vwait done after cancel $timer set done } 1 -test tlsIO-2.11 {detecting new data} {socket knownBug} { - # HOBBS: hung pre-rewrite, hangs post-rewrite +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 - set f [open awb.log w] - puts $f [catch {tls::handshake $sock} err] - puts $f "err: $err" - puts $f "[tls::status $sock]" - close $s + fileevent $s readable [list do_handshake $s] } - set s [tls::socket -require 0 -request 0 -server accept -certfile $serverCert -cafile $caCert \ - -keyfile $serverKey 8400] + 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 [gets $sock] - lappend result [gets $sock] + 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 [gets $sock] + lappend result c:[gets $sock] fconfigure $sock -blocking 1 close $s2 close $s close $sock set result -} {one {} two} +} {a:one b: c:two} test tlsIO-2.12 {tcp connection; no certificates specified} {socket stdio pcCrash} { removeFile script set f [open script w] puts $f { @@ -805,11 +838,11 @@ 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] + -server accept 8828] puts $p1 open puts $p2 open puts $p3 open vwait x vwait x @@ -866,11 +899,24 @@ close $msg } set x } {couldn't open socket: not owner} -test tlsIO-6.1 {accept callback error} {unexplainedFailure socket stdio pcCrash} { +if {0} { + package require tls + + proc accept {s a p} { + puts [info level 0] + expr 10 / 0 + } + set s [tls::socket -server accept 8848] + + proc bgerror args { puts "bgerror: $args" } + set s [tls::socket zamora.scriptics.com 8848] +} + +test tlsIO-6.1 {accept callback error} { socket stdio pcCrash} { # HOBBS: still fails post-rewrite removeFile script set f [open script w] puts $f { package require tls @@ -998,68 +1044,65 @@ # 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] + -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] + -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} {unexplainedHang socket} { +test tlsIO-8.1 {testing -async flag on sockets} {socket} { # HOBBS: still fails post-rewrite - # test seems to hang -- awb 6/2/2000 - # NOTE: This test may fail on some Solaris 2.4 systems. If it does, - # check that you have these patches installed (using showrev -p): - # - # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03, - # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01, - # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03, - # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01, - # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01, - # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03 - # - # If after installing these patches you are still experiencing a - # problem, please email jyl@eng.sun.com. We have not observed this - # failure on Solaris 2.5, so another option (instead of installing - # these patches) is to upgrade to Solaris 2.5. + # 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] + -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 close $s set x done } set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -async [info hostname] 8830] + -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} {unexplainedHang socket} { - # HOBBS: still fails post-rewrite - # locks up +test tlsIO-9.1 {testing spurious events} {socket} { set len 0 set spurious 0 set done 0 proc readlittle {s} { global spurious done len @@ -1074,19 +1117,23 @@ } else { incr len [string length $l] } } proc accept {s a p} { - fconfigure $s -buffering none -blocking off - fileevent $s readable [list readlittle $s] + 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] + -certfile $serverCert -cafile $caCert -keyfile $serverKey \ + -server accept 8831] set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8831] + -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 @@ -1093,68 +1140,69 @@ close $s list $spurious $len } {0 50} test tlsIO-9.2 {testing async write, fileevents, flush on close} {socket} { - # HOBBS: This hangs when I turn blocking on. - # - set firstblock "" - for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} - set secondblock "" - for {set i 0} {$i < 16} {incr i} { - set secondblock "b$secondblock$secondblock" - } - set l [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8832] + set firstblock [string repeat a 31] + set secondblock [string repeat b 65535] proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ - -buffering line - fileevent $s readable "readable $s" + 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 $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 8832] - fconfigure $s -blocking 0 -trans lf -buffering line + -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 $s hello + puts $c hello proc readit {s} { global count done - set l [read $s] - incr count [string length $l] + 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 $s readable "readit $s" + fileevent $c readable "readit $c" set done 0 set timer [after 10000 "set done timed_out"] vwait done after cancel $timer - close $l + close $s list $count $done } {65566 1} -test tlsIO-9.3 {testing EOF stickyness} {unexplainedHang socket} { - # HOBBS: still fails post-rewrite - # hangs +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 @@ -1177,22 +1225,23 @@ proc write_then_close {s} { puts $s bye close $s } proc accept {s a p} { - fconfigure $s -buffering line -translation lf - fileevent $s writable "write_then_close $s" + 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] + -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 off -buffering line -translation lf + -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 1000 timerproc] + set timer [after 2000 timerproc] vwait done close $s set count } {eof is sticky} @@ -1199,38 +1248,27 @@ 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 \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8898] + set s [tls::socket -cafile $caCert -server accept 8898] proc accept {s a p} {close $s; error} - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8898] + 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} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" + sendCertValues sendCommand { set socket9_1_test_server [tls::socket -server accept \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - 8834] + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834] proc accept {s a p} { - puts $s done tls::handshake $s + puts $s done close $s } } set s [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ @@ -1240,26 +1278,19 @@ sendCommand {close $socket9_1_test_server} set r } done test tlsIO-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" 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] + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835] proc accept {s a p} { tls::handshake $s puts $s $p close $s } @@ -1275,10 +1306,11 @@ } 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]}]} { @@ -1289,23 +1321,14 @@ } set status } ok test tlsIO-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" + sendCertValues sendCommand { - global serverCert - global caCert - global serverKey set socket10_6_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ + -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 @@ -1329,21 +1352,14 @@ sendCommand {close $socket10_6_test_server} set r } hello test tlsIO-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" + sendCertValues sendCommand { set socket10_7_test_server [tls::socket -server accept \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - 8836] + -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 } @@ -1393,19 +1409,16 @@ 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 [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey \ -server accept 8836] proc accept {s a p} { - # handshake locks up the three synchronous clients - # tls::handshake $s fconfigure $s -buffering line fileevent $s readable [list echo $s] } proc echo {s} { set l [gets $s] @@ -1441,43 +1454,40 @@ close $s3 sendCommand {close $socket10_9_test_server} set i } 100 -test tlsIO-11.8 {client with several servers} {unexplainedHang socket doTestsWithRemoteServer} { - # this one seems to hang -- awb 6/2/2000 +test tlsIO-11.8 {client with several servers} {socket doTestsWithRemoteServer} { + sendCertValues sendCommand { - set s1 [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server "accept 4003" 4003] - set s2 [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server "accept 4004" 4004] - set s3 [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server "accept 4005" 4005] + 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} { - tls::handshake $s - puts $s $mp - close $s + # 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] } } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 4003] - set s2 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 4004] - set s3 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 4005] + 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 @@ -1488,31 +1498,25 @@ close $s3 } set l } {4003 {} 1 4004 {} 1 4005 {} 1} -test tlsIO-11.9 {accept callback error} {knownBug socket doTestsWithRemoteServer} { +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 } - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" + sendCertValues if {[catch {sendCommand { set peername [fconfigure $callerSocket -peername] set s [tls::socket \ - -certfile $clientCert \ - -cafile $caCert \ - -keyfile $clientKey \ - [lindex $peername 0] 8836] + -certfile $clientCert -cafile $caCert -keyfile $clientKey \ + [lindex $peername 0] 8836] close $s }} msg]} { close $s error $msg } @@ -1522,21 +1526,15 @@ close $s rename bgerror {} set x } {{divide by zero}} -test tlsIO-11.10 {testing socket specific options} {unexplainedFailure socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" +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 \ + -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 \ @@ -1548,27 +1546,30 @@ close $s sendCommand {close $socket10_12_test_server} set l } {8836 3 3} -test tlsIO-11.11 {testing spurious events} {unexplainedHang socket doTestsWithRemoteServer} { - # hangs - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" +test tlsIO-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { + # remote equivalent of 9.1 + sendCertValues sendCommand { - set socket10_13_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - -server accept 8836] + 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} { - tls::handshake $s fconfigure $s -translation "auto lf" - after 100 writesome $s + fileevent $s writable [list handshake $s] } proc writesome {s} { for {set i 0} {$i < 100} {incr i} { puts $s "line $i from remote server" } @@ -1593,19 +1594,25 @@ } } set c [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] - fileevent $c readable "readlittle $c" + # 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 $socket10_13_test_server} + sendCommand {close $socket_test_server} list $spurious $len } {0 2690} -test tlsIO-11.12 {testing EOF stickyness} {knownBug socket doTestsWithRemoteServer} { +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] @@ -1621,29 +1628,23 @@ proc timed_out {} { global c done set done {timed_out, EOF is not sticky} close $c } - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" + sendCertValues sendCommand { set socket10_14_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ + -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] + $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 @@ -1658,33 +1659,21 @@ if {[eof $s]} { close $s set done 1 } } - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" + sendCertValues sendCommand { - set firstblock "" - for {set i 0} {$i < 5} {incr i} { - set firstblock "a$firstblock$firstblock" - } - set secondblock "" - for {set i 0} {$i < 16} {incr i} { - set secondblock "b$secondblock$secondblock" - } + set firstblock [string repeat a 31] + set secondblock [string repeat b 65535] set l [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ + -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 + -buffering line fileevent $s readable "readable $s" } proc readable {s} { set l [gets $s] fileevent $s readable {} @@ -1701,12 +1690,12 @@ close $s } } set s [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 8845] - fconfigure $s -blocking 0 -trans lf -buffering line + $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 @@ -1713,14 +1702,13 @@ after cancel $timer sendCommand {close $l} set count } 65566 -test tlsIO-12.1 {testing inheritance of server sockets} \ - {socket doTestsWithRemoteServer} { - removeFile script1 - removeFile script2 +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] @@ -1733,33 +1721,28 @@ # 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 tcltest $::tcltest::tcltest] - puts $f [list set tclsh [info nameofexecutable]] - puts $f { - package require tcltest - package require tls - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" + puts $f [list set tclsh $::tcltest::tcltest] + puts $f {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 $::tcltest::tcltest script1 & exec $tclsh script1 & close $f after 1000 exit vwait forever } close $f # Launch script2 and wait 5 seconds - # exec $::tcltest::tcltest script2 & - exec [info nameofexecutable] script2 & + 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. @@ -1770,19 +1753,16 @@ } else { close $msg set x {server socket was inherited} } - removeFile script1 - removeFile script2 set x } {server socket was not inherited} -test tlsIO-12.2 {testing inheritance of client sockets} \ - {unexplainedFailure socket doTestsWithRemoteServer} { - removeFile script1 - removeFile script2 +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] @@ -1795,15 +1775,14 @@ # 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 [info nameofexecutable]] - puts $f { - package require tls - } - puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8829 \]" + puts $f [list set tclsh $::tcltest::tcltest] + puts $f {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 @@ -1812,23 +1791,22 @@ close $f # Create the server socket set server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8829] + -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 - fileevent $file readable [list getdata $file] - fconfigure $file -buffering line -blocking 0 + fconfigure $file -blocking 0 + fileevent $file readable [list do_handshake $file readable getdata \ + -buffering line] return } proc getdata { file } { - # Read handler on the accepted socket. global x global failed set status [catch {read $file} data] if {$status != 0} { @@ -1856,79 +1834,77 @@ set failed 0 after 5000 [list set failed 1] # Launch the script2 process - exec [info nameofexecutable] script2 & + exec $::tcltest::tcltest script2 & vwait x if {!$failed} { vwait failed } - removeFile script1 - removeFile script2 set x } {client socket was not inherited} -test tlsIO-12.3 {testing inheritance of accepted sockets} \ - {hangsOnLinux socket doTestsWithRemoteServer} { - # hangs on Linux - removeFile script1 - removeFile script2 +test tlsIO-12.3 {testing inheritance of accepted sockets} {socket exec} { + 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 [info nameofexecutable]] - puts $f { - package require tls - } - puts $f "catch {set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8930 \]}" + puts $f [list set tclsh $::tcltest::tcltest] + puts $f {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 } - catch {vwait forever} + vwait forever } close $f # Launch the script2 process and connect to it. See how long # the socket stays open - exec [info nameofexecutable] script2 & + exec $::tcltest::tcltest script2 & - after 1000 set ok_to_proceed 1 + 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 $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 proc getdata { file } { - # Read handler on the client socket. global x global failed set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} + set x "read failed, error was $data" catch { close $file } } elseif {[string compare {} $data]} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { if {$failed} { @@ -1943,19 +1919,16 @@ } return } vwait x - - removeFile script1 - removeFile script2 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 { package require tls @@ -2014,6 +1987,5 @@ catch {close $commandSocket} catch {close $remoteProcChan} ::tcltest::cleanupTests flush stdout return - Index: tls.c ================================================================== --- tls.c +++ tls.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-1999 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.1 2000/07/11 04:58:46 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.2 2000/07/21 05:32:56 hobbs Exp $ * * TLS (aka SSL) Channel - can be layered on any bi-directional * Tcl_Channel (Note: Requires Trf Core Patch) * * This was built (almost) from scratch based upon observation of @@ -29,31 +29,33 @@ /* * Forward declarations */ #define F2N( key, dsp) \ - (((key) == NULL)?(char*)NULL:Tcl_TranslateFileName( interp, (key), (dsp))) + (((key) == NULL) ? (char *) NULL : \ + Tcl_TranslateFileName(interp, (key), (dsp))) #define REASON() ERR_reason_error_string(ERR_get_error()) -static int CiphersObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); - -static int HandshakeObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); - -static int ImportObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); - -static int StatusObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); +static int CiphersObjCmd _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static int HandshakeObjCmd _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static int ImportObjCmd _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static int StatusObjCmd _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static SSL_CTX *CTX_Init _ANSI_ARGS_((Tcl_Interp *interp, int proto, char *key, - char *cert, char *CAdir, char *CAfile, char *ciphers)); + char *cert, char *CAdir, char *CAfile, char *ciphers)); #define TLS_PROTO_SSL2 0x01 #define TLS_PROTO_SSL3 0x02 #define TLS_PROTO_TLS1 0x04 #define ENABLED(flag, mask) (((flag) & (mask)) == (mask)) + /* * Static data structures */ #ifndef NO_DH @@ -549,24 +551,26 @@ if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; } - statePtr = (State *)Tcl_GetChannelInstanceData( chan); + statePtr = (State *)Tcl_GetChannelInstanceData(chan); if (!SSL_is_init_finished(statePtr->ssl)) { int err; ret = Tls_WaitForConnect(statePtr, &err); if (ret < 0) { char *errStr = statePtr->err; Tcl_ResetResult(interp); Tcl_SetErrno(err); - if (!errStr || *errStr == 0) + if (!errStr || *errStr == 0) { errStr = Tcl_PosixError(interp); + } - Tcl_AppendResult(interp, "handshake failed: ", errStr, (char*)NULL); + Tcl_AppendResult(interp, "handshake failed: ", errStr, + (char *) NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); return TCL_OK; @@ -1086,25 +1090,28 @@ *------------------------------------------------------------------- */ void Tls_Clean(State *statePtr) { - /* we're assuming here that we're single-threaded */ + /* + * we're assuming here that we're single-threaded + */ + + if (statePtr->timer != (Tcl_TimerToken) NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = NULL; + } + if (statePtr->ssl) { SSL_shutdown(statePtr->ssl); SSL_free(statePtr->ssl); statePtr->ssl = NULL; } if (statePtr->callback) { Tcl_DecrRefCount(statePtr->callback); statePtr->callback = NULL; } - - if (statePtr->timer != (Tcl_TimerToken)NULL) { - Tcl_DeleteTimerHandler (statePtr->timer); - statePtr->timer = NULL; - } } /* *------------------------------------------------------------------- * Index: tls.tcl ================================================================== --- tls.tcl +++ tls.tcl @@ -1,9 +1,9 @@ # # Copyright (C) 1997-2000 Matt Newman # -# $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.tcl,v 1.2 2000/01/20 01:51:05 aborr Exp $ +# $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.tcl,v 1.2.2.1 2000/07/21 05:32:56 hobbs Exp $ # namespace eval tls { variable logcmd tclLog variable debug 0 @@ -46,26 +46,26 @@ set iopts [concat [list -server $server] ${tls::defaults}] ;# Import options for {set idx 0} {$idx < $argc} {incr idx} { set arg [lindex $args $idx] switch -glob -- $server,$arg { - 0,-myport - - *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]} - 0,-async {lappend sopts $arg} - *,-cipher - - *,-cadir - - *,-cafile - - *,-certfile - - *,-keyfile - - *,-command - - *,-request - - *,-require - - *,-ssl2 - - *,-ssl3 - - *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]} - -* {return -code error "bad option \"$arg\": must be one of $options"} - default {break} + 0,-myport - + *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]} + 0,-async {lappend sopts $arg} + *,-cipher - + *,-cadir - + *,-cafile - + *,-certfile - + *,-keyfile - + *,-command - + *,-request - + *,-require - + *,-ssl2 - + *,-ssl3 - + *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]} + -* {return -code error "bad option \"$arg\": must be one of $options"} + default {break} } } if {$server} { if {($idx + 1) != $argc} { return -code error $usage @@ -72,10 +72,11 @@ } set uid [incr ::tls::srvuid] set port [lindex $args [expr {$argc-1}]] lappend sopts $port + #set sopts [linsert $sopts 0 -server $callback] set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] } else { if {($idx + 2) != $argc} { return -code error $usage @@ -98,10 +99,26 @@ catch {close $chan} return -code error -errorinfo $info $err } return $chan } + +# tls::_accept -- +# +# This is the actual accept that TLS sockets use, which then calls +# the callback registered by tls::socket. +# +# Arguments: +# iopts tls::import opts +# callback server callback to invoke +# chan socket channel to accept/deny +# ipaddr calling IP address +# port calling port +# +# Results: +# Returns an error if the callback throws one. +# proc tls::_accept { iopts callback chan ipaddr port } { log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] set chan [eval [list tls::import $chan] $iopts] @@ -109,10 +126,11 @@ if {[catch { uplevel #0 $callback } err]} { log 1 "tls::_accept error: ${::errorInfo}" close $chan + error $err $::errorInfo $::errorCode } else { log 2 "tls::_accept - called \"$callback\" succeeded" } } # @@ -127,49 +145,50 @@ variable debug #log 2 [concat $option $args] switch -- $option { - "error" { - foreach {chan msg} $args break - - log 0 "TLS/$chan: error: $msg" - } - "verify" { - # poor man's lassign - foreach {chan depth cert rc err} $args break - - array set c $cert - - if {$rc != "1"} { - log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" - } else { - log 2 "TLS/$chan: verify/$depth: $c(subject)" - } - if {$debug > 0} { - return 1; # FORCE OK - } else { - return $rc - } - } - "info" { - # poor man's lassign - foreach {chan major minor state msg} $args break - - if {$msg != ""} { - append state ": $msg" - } - # For tracing - upvar #0 tls::$chan cb - set cb($major) $minor - - log 2 "TLS/$chan: $major/$minor: $state" - } - default { - return -code error "bad option \"$option\": must be one of error, info, or verify" - } - };#sw + "error" { + foreach {chan msg} $args break + + log 0 "TLS/$chan: error: $msg" + } + "verify" { + # poor man's lassign + foreach {chan depth cert rc err} $args break + + array set c $cert + + if {$rc != "1"} { + log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" + } else { + log 2 "TLS/$chan: verify/$depth: $c(subject)" + } + if {$debug > 0} { + return 1; # FORCE OK + } else { + return $rc + } + } + "info" { + # poor man's lassign + foreach {chan major minor state msg} $args break + + if {$msg != ""} { + append state ": $msg" + } + # For tracing + upvar #0 tls::$chan cb + set cb($major) $minor + + log 2 "TLS/$chan: $major/$minor: $state" + } + default { + return -code error "bad option \"$option\":\ + must be one of error, info, or verify" + } + } } proc tls::xhandshake {chan} { upvar #0 tls::$chan cb Index: tlsBIO.c ================================================================== --- tlsBIO.c +++ tlsBIO.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.2 2000/07/12 01:54:26 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.3 2000/07/21 05:32:57 hobbs Exp $ * * Provides BIO layer to interface openssl to Tcl. */ #include "tlsInt.h" @@ -152,42 +152,41 @@ ret = 1; break; case BIO_C_SET_FD: BioFree(bio); /* Sets State* */ - bio->ptr = *((char **)ptr); - bio->shutdown = (int)num; - bio->init = 1; + bio->ptr = *((char **)ptr); + bio->shutdown = (int)num; + bio->init = 1; break; case BIO_C_GET_FD: if (bio->init) { - ip=(int *)ptr; - if (ip != NULL) *ip=bio->num; - ret=bio->num; + ip = (int *)ptr; + if (ip != NULL) { + *ip = bio->num; + } + ret = bio->num; } else { - ret= -1; + ret = -1; } break; case BIO_CTRL_GET_CLOSE: - ret=bio->shutdown; + ret = bio->shutdown; break; case BIO_CTRL_SET_CLOSE: - bio->shutdown=(int)num; + bio->shutdown = (int)num; break; case BIO_CTRL_EOF: dprintf(stderr, "BIO_CTRL_EOF\n"); ret = Tcl_Eof( chan); break; case BIO_CTRL_PENDING: - if (Tcl_InputBuffered(chan)) - ret = 1; - else - ret = 0; + ret = (Tcl_InputBuffered(chan) ? 1 : 0); dprintf(stderr, "BIO_CTRL_PENDING(%d)\n", ret); break; case BIO_CTRL_WPENDING: - ret=0; + ret = 0; break; case BIO_CTRL_DUP: break; case BIO_CTRL_FLUSH: dprintf(stderr, "BIO_CTRL_FLUSH\n"); @@ -212,31 +211,32 @@ static int BioNew (bio) BIO *bio; { - bio->init = 0; - bio->num = 0; - bio->ptr = NULL; - bio->flags = 0; + bio->init = 0; + bio->num = 0; + bio->ptr = NULL; + bio->flags = 0; return 1; } static int BioFree (bio) BIO *bio; { - if (bio == NULL) + if (bio == NULL) { return 0; + } if (bio->shutdown) { if (bio->init) { /*shutdown(bio->num, 2) */ /*closesocket(bio->num) */ } - bio->init = 0; - bio->flags = 0; - bio->num = 0; + bio->init = 0; + bio->flags = 0; + bio->num = 0; } return 1; } Index: tlsIO.c ================================================================== --- tlsIO.c +++ tlsIO.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.2 2000/07/12 01:54:26 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.3 2000/07/21 05:32:57 hobbs Exp $ * * TLS (aka SSL) Channel - can be layered on any bi-directional * Tcl_Channel (Note: Requires Trf Core Patch) * * This was built from scratch based upon observation of OpenSSL 0.9.2B @@ -57,18 +57,18 @@ * based IO: */ #ifdef TCL_CHANNEL_VERSION_2 static Tcl_ChannelType tlsChannelType = { "tls", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* A NG channel */ - TlsCloseProc, /* Close proc. */ - TlsInputProc, /* Input proc. */ - TlsOutputProc, /* Output proc. */ + TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2/8.4a2+) */ + TlsCloseProc, /* Close proc. */ + TlsInputProc, /* Input proc. */ + TlsOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ TlsGetOptionProc, /* Get option proc. */ - TlsWatchProc, /* Initialize notifier. */ + TlsWatchProc, /* Initialize notifier. */ TlsGetHandleProc, /* Get file handle out of channel. */ NULL, /* Close2Proc. */ TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ NULL, /* FlushProc. */ TlsNotifyProc, /* handlerProc. */ @@ -75,17 +75,17 @@ }; #else static Tcl_ChannelType tlsChannelType = { "tls", /* Type name. */ TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ - TlsCloseProc, /* Close proc. */ - TlsInputProc, /* Input proc. */ - TlsOutputProc, /* Output proc. */ + TlsCloseProc, /* Close proc. */ + TlsInputProc, /* Input proc. */ + TlsOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ TlsGetOptionProc, /* Get option proc. */ - TlsWatchProc, /* Initialize notifier. */ + TlsWatchProc, /* Initialize notifier. */ TlsGetHandleProc, /* Get file handle out of channel. */ }; #endif Tcl_ChannelType *Tls_ChannelType() @@ -155,22 +155,19 @@ { State *statePtr = (State *) instanceData; dprintf(stderr,"\nTlsCloseProc(0x%x)", statePtr); +#ifndef TCL_CHANNEL_VERSION_2 /* * Remove event handler to underlying channel, this could * be because we are closing for real, or being "unstacked". */ -#ifndef TCL_CHANNEL_VERSION_2 + Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), TlsChannelHandler, (ClientData) statePtr); #endif - if (statePtr->timer != (Tcl_TimerToken)NULL) { - Tcl_DeleteTimerHandler (statePtr->timer); - statePtr->timer = (Tcl_TimerToken)NULL; - } Tls_Clean(statePtr); Tcl_EventuallyFree( (ClientData)statePtr, Tls_Free); return TCL_OK; } @@ -711,18 +708,20 @@ err = SSL_accept(statePtr->ssl); } else { err = SSL_connect(statePtr->ssl); } /*SSL_write(statePtr->ssl, (char*)&err, 0); HACK!!! */ - if (err > 0) + if (err > 0) { BIO_flush(statePtr->bio); + } if (err <= 0) { int rc = SSL_get_error(statePtr->ssl, err); if (rc == SSL_ERROR_SSL) { - Tls_Error(statePtr, (char*)ERR_reason_error_string(ERR_get_error())); + Tls_Error(statePtr, + (char *)ERR_reason_error_string(ERR_get_error())); *errorCodePtr = ECONNABORTED; return -1; } else if (BIO_should_retry(statePtr->bio)) { if (statePtr->flags & TLS_TCL_ASYNC) { dprintf(stderr,"E! "); @@ -737,11 +736,12 @@ return -1; } if (statePtr->flags & TLS_TCL_SERVER) { err = SSL_get_verify_result(statePtr->ssl); if (err != X509_V_OK) { - Tls_Error(statePtr, (char*)X509_verify_cert_error_string(err)); + Tls_Error(statePtr, + (char *)X509_verify_cert_error_string(err)); *errorCodePtr = ECONNABORTED; return -1; } } *errorCodePtr = Tcl_GetErrno();