Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,86 @@ +2000-07-26 Jeff Hobbs + + * tests/tlsIO.test: updated comments, fixed a pcCrash case that + was due to debug assertion in Windows SSL. + + * tls.c (ImportObjCmd): removed unnecessary use of 'bio' arg. + (Tls_Init): check return value of SSL_library_init. Also lots of + whitespace cleanup (more like Tcl Eng style guide), but not all + code was cleaned up. + + * tlsBIO.c: minor whitespace cleanup + + * tlsIO.c: minor whitespace cleanup. + (TlsInputProc, TlsOutputProc): Added ERR_clear_error before calls + to BIO_read or BIO_write, because we could otherwise end up + pulling an error off the stack that didn't belong to us. Also + cleanup up excessive use of gotos. + +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 + +2000-07-13 Jeff Hobbs + + * tests/tlsIO.test: enabled tests 2.10, 7.[1245] (there is no 3), + which now pass. Added some comments to other failing tests. + +2000-07-11 Jeff Hobbs + + * tlsIO.c: changed all the channel procs to start with Tls* for + better parity when comparing with Transform channel procs. + Rewrote TlsWatchProc, added TlsNotifyProc according to the new + channel design, which also leaves TlsChannelHandler unused. + + * tlsBIO.c (BioCtrl): changed BIO_CTRL_FLUSH case to use + Tcl_WriteRaw instead of Tcl_Flush (to operate on correct channel + in the stack instead of starting at the top again). Would + otherwise cause a recursive stack bomb when implicit handshaking + took effect. + + * tests/tlsIO.test: removed changes made to test suite (all tests + that ran before now pass correctly), and changed some accept proc + args to reflect that a sock is an arg, not a file. + +2000-07-10 Jeff Hobbs + + * tlsBIO.c (BioWrite, BioRead): changed Tcl_Read/Write to + Tcl_ReadRaw/TclWriteRaw. + + * tls.c: added use of Tcl_GetTopChannel after Tcl_GetChannel and + got return value from Tcl_StackChannel. + + * tests/tlsIO.test: added some handshaking that shouldn't be + necessary, but we crash otherwise (needs more testing). + + * tlsIO.c: added support for "corrected" stacked channels. All + the above channels are in TCL_CHANNEL_VERSION_2 #ifdefs. + 2000-06-05 Scott Stanton * Makefile.in: Fixed broken test target. * tlsInt.h: 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: configure.in ================================================================== --- configure.in +++ configure.in @@ -32,11 +32,11 @@ #-------------------------------------------------------------------- PACKAGE=tls MAJOR_VERSION=1 -MINOR_VERSION=3 +MINOR_VERSION=4 PATCHLEVEL= VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} Index: pkgIndex.tcl.in ================================================================== --- pkgIndex.tcl.in +++ pkgIndex.tcl.in @@ -1,9 +1,9 @@ -# pkgIndex.tcl - -# A new manually generated "pkgIndex.tcl" file for tls to replace the original -# which didn't include the commands from "tls.tcl". +# pkgIndex.tcl - +# +# A new manually generated "pkgIndex.tcl" file for tls to +# replace the original which didn't include the commands from "tls.tcl". # -# Al Borr 12/99, last revised Jan 11/00. -package ifneeded tls 1.3 "[list load [file join $dir @RELPATH@ @tls_LIB_FILE@] ] ; [list source [file join $dir tls.tcl] ]" +package ifneeded tls 1.4 "[list load [file join $dir @RELPATH@ @tls_LIB_FILE@] ] ; [list source [file join $dir tls.tcl] ]" 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 2000/06/08 00:06:40 aborr Exp $ +# RCS: @(#) $Id: tlsIO.test,v 1.14.2.5 2000/07/26 23:11:46 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"}} @@ -311,14 +348,14 @@ 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 {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file] $port" - close $file + puts "[gets $sock] $port" + close $sock set x done } puts ready vwait x after cancel $timer @@ -350,14 +387,14 @@ 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 {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file] $addr" - close $file + puts "[gets $sock] $addr" + close $sock set x done } puts ready vwait x after cancel $timer @@ -387,14 +424,14 @@ 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 {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file]" - close $file + puts "[gets $sock]" + close $sock set x done } puts ready vwait x after cancel $timer @@ -423,14 +460,14 @@ 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 {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file]" - close $file + puts "[gets $sock]" + close $sock set x done } puts ready vwait x after cancel $timer @@ -562,25 +599,16 @@ 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)}} - -test tlsIO-2.10 {close on accept, accepted socket lives} {socket knownBug} { +} {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} { @@ -602,46 +630,55 @@ vwait done after cancel $timer set done } 1 -test tlsIO-2.11 {detecting new data} {socket knownBug} { +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} { +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 { package require tls set timer [after 2000 "set x timed_out"] @@ -761,10 +798,11 @@ 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 { package require tls gets stdin @@ -804,11 +842,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 @@ -865,26 +903,29 @@ close $msg } set x } {couldn't open socket: not owner} -test tlsIO-6.1 {accept callback error} {unexplainedFailure socket stdio pcCrash} { +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 { package require tls gets stdin - tls::socket 127.0.0.1 8848 } + 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 8848] + 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 @@ -891,19 +932,18 @@ close $s rename bgerror {} set x } {{divide by zero}} -# bug report #5812 fconfigure doesn't return value for '-peername' - -test tlsIO-7.1 {testing socket specific options} {knownBug socket stdio} { +test tlsIO-7.1 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { package require tls } - puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820" + puts $f [list tls::socket -server accept \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820] puts $f { proc accept args { global x set x done } @@ -925,13 +965,11 @@ 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} -# bug report #5812 fconfigure doesn't return value for '-sockname' - -test tlsIO-7.2 {testing socket specific options} {knownBug socket stdio} { +test tlsIO-7.2 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { package require tls } @@ -971,11 +1009,11 @@ llength $l } 12 # bug report #5812 fconfigure doesn't return value for '-sockname' -test tlsIO-7.4 {testing socket specific options} {knownBug socket} { +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 @@ -994,68 +1032,67 @@ 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} {knownBug socket unixOrPc} { +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 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. +test tlsIO-8.1 {testing -async flag on sockets} {socket} { + # HOBBS: still fails post-rewrite + # 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} { - # 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 @@ -1070,19 +1107,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 @@ -1089,64 +1130,69 @@ close $s list $spurious $len } {0 50} test tlsIO-9.2 {testing async write, fileevents, flush on close} {socket} { - 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 - set count -} 65566 + close $s + list $count $done +} {65566 1} -test tlsIO-9.3 {testing EOF stickyness} {unexplainedHang socket} { - # 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 @@ -1169,22 +1215,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} @@ -1191,38 +1238,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 \ @@ -1232,26 +1268,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 } @@ -1267,10 +1296,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]}]} { @@ -1281,23 +1311,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 @@ -1321,21 +1342,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 } @@ -1385,19 +1399,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] @@ -1433,43 +1444,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 @@ -1480,31 +1488,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 } @@ -1514,21 +1516,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 \ @@ -1540,27 +1536,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" } @@ -1585,19 +1584,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] @@ -1613,29 +1618,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 @@ -1650,33 +1649,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 {} @@ -1693,12 +1680,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 @@ -1705,14 +1692,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] @@ -1725,33 +1711,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. @@ -1762,19 +1743,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] @@ -1787,15 +1765,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 @@ -1804,23 +1781,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} { @@ -1848,79 +1824,78 @@ 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 + {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 [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} { @@ -1935,19 +1910,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 @@ -2006,6 +1978,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 2000/06/06 01:34:11 welch Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.3 2000/07/26 22:15:07 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 @@ -217,30 +219,32 @@ *------------------------------------------------------------------- */ static int VerifyCallback(int ok, X509_STORE_CTX *ctx) { - SSL *ssl = (SSL*)X509_STORE_CTX_get_app_data(ctx); - X509 *cert = X509_STORE_CTX_get_current_cert(ctx); - State *statePtr = (State*)SSL_get_app_data(ssl); Tcl_Obj *cmdPtr; - int depth = X509_STORE_CTX_get_error_depth(ctx); - int err = X509_STORE_CTX_get_error(ctx); char *errStr; + SSL *ssl = (SSL*)X509_STORE_CTX_get_app_data(ctx); + X509 *cert = X509_STORE_CTX_get_current_cert(ctx); + State *statePtr = (State*)SSL_get_app_data(ssl); + int depth = X509_STORE_CTX_get_error_depth(ctx); + int err = X509_STORE_CTX_get_error(ctx); dprintf(stderr, "Verify: %d\n", ok); - if (!ok) + if (!ok) { errStr = (char*)X509_verify_cert_error_string(err); - else + } else { errStr = (char *)0; + } if (statePtr->callback == (Tcl_Obj*)NULL) { - if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) + if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) { return ok; - else + } else { return 1; + } } cmdPtr = Tcl_DuplicateObj(statePtr->callback); Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, Tcl_NewStringObj( "verify", -1)); @@ -303,11 +307,11 @@ Tls_Error(State *statePtr, char *msg) { Tcl_Obj *cmdPtr; if (msg && *msg) { - Tcl_SetErrorCode( statePtr->interp, "SSL", msg, (char *)NULL); + Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL); } else { msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL); } statePtr->err = msg; @@ -319,30 +323,30 @@ Tcl_BackgroundError( statePtr->interp); return; } cmdPtr = Tcl_DuplicateObj(statePtr->callback); - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( "error", -1)); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( msg, -1) ); - - Tcl_Preserve( (ClientData) statePtr->interp); - Tcl_Preserve( (ClientData) statePtr); - - Tcl_IncrRefCount( cmdPtr); + Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, + Tcl_NewStringObj("error", -1)); + + Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, + Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1)); + + Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, + Tcl_NewStringObj(msg, -1)); + + Tcl_Preserve((ClientData) statePtr->interp); + Tcl_Preserve((ClientData) statePtr); + + Tcl_IncrRefCount(cmdPtr); if (Tcl_GlobalEvalObj(statePtr->interp, cmdPtr) != TCL_OK) { - Tcl_BackgroundError( statePtr->interp); + Tcl_BackgroundError(statePtr->interp); } - Tcl_DecrRefCount( cmdPtr); + Tcl_DecrRefCount(cmdPtr); - Tcl_Release( (ClientData) statePtr); - Tcl_Release( (ClientData) statePtr->interp); + Tcl_Release((ClientData) statePtr); + Tcl_Release((ClientData) statePtr->interp); } /* *------------------------------------------------------------------- * @@ -455,18 +459,16 @@ #else ctx = SSL_CTX_new(TLSv1_method()); break; #endif } if (ctx == NULL) { - Tcl_AppendResult(interp, REASON(), - (char *) NULL); + Tcl_AppendResult(interp, REASON(), (char *) NULL); return TCL_ERROR; } ssl = SSL_new(ctx); if (ssl == NULL) { - Tcl_AppendResult(interp, REASON(), - (char *) NULL); + Tcl_AppendResult(interp, REASON(), (char *) NULL); SSL_CTX_free(ctx); return TCL_ERROR; } objPtr = Tcl_NewListObj( 0, NULL); @@ -538,32 +540,41 @@ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); +#endif 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; } /* @@ -590,23 +601,22 @@ Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel chan; /* The channel to set a mode on. */ - BIO *bio; State *statePtr; /* client state for ssl socket */ - SSL_CTX *ctx = NULL; - Tcl_Obj *script = NULL; + SSL_CTX *ctx = NULL; + Tcl_Obj *script = NULL; int idx; - int flags = TLS_TCL_INIT; - int server = 0; /* is connection incoming or outgoing? */ - char *key = NULL; - char *cert = NULL; - char *ciphers = NULL; - char *CAfile = NULL; - char *CAdir = NULL; - char *model = NULL; + int flags = TLS_TCL_INIT; + int server = 0; /* is connection incoming or outgoing? */ + char *key = NULL; + char *cert = NULL; + char *ciphers = NULL; + char *CAfile = NULL; + char *CAdir = NULL; + char *model = NULL; #if defined(NO_SSL2) int ssl2 = 0; #else int ssl2 = 1; #endif @@ -630,10 +640,16 @@ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); +#endif for (idx = 2; idx < objc; idx++) { char *opt = Tcl_GetStringFromObj(objv[idx], NULL); if (opt[0] != '-') @@ -656,78 +672,97 @@ OPTBAD( "option", "-cafile, -cadir, -certfile, -cipher, -command, -keyfile, -model, -require, -request, -ssl2, -ssl3, -server, or -tls1"); return TCL_ERROR; } - if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; + if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; - if (verify == 0) verify = SSL_VERIFY_NONE; + if (verify == 0) verify = SSL_VERIFY_NONE; proto |= (ssl2 ? TLS_PROTO_SSL2 : 0); proto |= (ssl3 ? TLS_PROTO_SSL3 : 0); proto |= (tls1 ? TLS_PROTO_TLS1 : 0); /* reset to NULL if blank string provided */ - if (cert && !*cert) cert = NULL; - if (key && !*key) key = NULL; - if (ciphers && !*ciphers) ciphers = NULL; - if (CAfile && !*CAfile) CAfile = NULL; - if (CAdir && !*CAdir) CAdir = NULL; + if (cert && !*cert) cert = NULL; + if (key && !*key) key = NULL; + if (ciphers && !*ciphers) ciphers = NULL; + if (CAfile && !*CAfile) CAfile = NULL; + if (CAdir && !*CAdir) CAdir = NULL; if (model != NULL) { int mode; /* Get the "model" context */ - chan = Tcl_GetChannel( interp, model, &mode); - if (chan == (Tcl_Channel)0) { + chan = Tcl_GetChannel(interp, model, &mode); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); +#endif if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { - Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), - "\": not a TLS channel", NULL); + 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); ctx = statePtr->ctx; } else { - if ((ctx = CTX_Init( interp, proto, key, cert, CAdir, CAfile, ciphers)) + if ((ctx = CTX_Init(interp, proto, key, cert, CAdir, CAfile, ciphers)) == (SSL_CTX*)0) { return TCL_ERROR; } } /* new SSL state */ - statePtr = (State *) Tcl_Alloc((unsigned) sizeof(State)); - statePtr->self = (Tcl_Channel)NULL; - statePtr->timer = (Tcl_TimerToken)NULL; - - statePtr->flags = flags; - statePtr->watchMask = 0; - statePtr->mode = 0; - - statePtr->interp = interp; - statePtr->callback = (Tcl_Obj *)0; - - statePtr->vflags = verify; - statePtr->ssl = (SSL*)0; - statePtr->ctx = ctx; - statePtr->bio = (BIO*)0; - statePtr->p_bio = (BIO*)0; - - statePtr->err = ""; - + statePtr = (State *) Tcl_Alloc((unsigned) sizeof(State)); + statePtr->self = (Tcl_Channel)NULL; + statePtr->timer = (Tcl_TimerToken)NULL; + + statePtr->flags = flags; + statePtr->watchMask = 0; + statePtr->mode = 0; + + statePtr->interp = interp; + statePtr->callback = (Tcl_Obj *)0; + + statePtr->vflags = verify; + statePtr->ssl = (SSL*)0; + statePtr->ctx = ctx; + statePtr->bio = (BIO*)0; + statePtr->p_bio = (BIO*)0; + + statePtr->err = ""; + + /* + * We need to make sure that the channel works in binary (for the + * encryption not to get goofed up). + * We only want to adjust the buffering in pre-v2 channels, where + * each channel in the stack maintained its own buffers. + */ Tcl_SetChannelOption(interp, chan, "-translation", "binary"); +#ifndef TCL_CHANNEL_VERSION_2 Tcl_SetChannelOption(interp, chan, "-buffering", "none"); +#endif #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2 statePtr->parent = chan; - statePtr->self = Tcl_ReplaceChannel( interp, - Tls_ChannelType(), (ClientData) statePtr, - (TCL_READABLE | TCL_WRITABLE), statePtr->parent); + statePtr->self = Tcl_ReplaceChannel(interp, + Tls_ChannelType(), (ClientData) statePtr, + (TCL_READABLE | TCL_WRITABLE), statePtr->parent); +#else +#ifdef TCL_CHANNEL_VERSION_2 + statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); #else statePtr->self = chan; Tcl_StackChannel( interp, Tls_ChannelType(), (ClientData) statePtr, - (TCL_READABLE | TCL_WRITABLE), chan); + (TCL_READABLE | TCL_WRITABLE), chan); +#endif #endif if (statePtr->self == (Tcl_Channel) NULL) { /* * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. */ @@ -735,14 +770,14 @@ return TCL_ERROR; } /* allocate script */ if (script) { - char * tmp = Tcl_GetStringFromObj(script, NULL); + char *tmp = Tcl_GetStringFromObj(script, NULL); if (tmp && *tmp) { statePtr->callback = Tcl_DuplicateObj(script); - Tcl_IncrRefCount( statePtr->callback); + Tcl_IncrRefCount(statePtr->callback); } } /* This is only needed because of a bug in OpenSSL, where the * ssl->verify_callback is not referenced!!! (Must be done * *before* SSL_new() is called! @@ -754,13 +789,12 @@ */ statePtr->ssl = SSL_new(statePtr->ctx); if (!statePtr->ssl) { /* SSL library error */ - Tcl_AppendResult(interp, - "couldn't construct ssl session: ", REASON(), - (char *) NULL); + Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), + (char *) NULL); Tls_Free((char *) statePtr); return TCL_ERROR; } /* @@ -773,23 +807,23 @@ * The following is broken - we need is to set the * verify_mode, but the library ignores the verify_callback!!! */ /*SSL_set_verify(statePtr->ssl, verify, VerifyCallback);*/ - SSL_CTX_set_info_callback( statePtr->ctx, InfoCallback); + SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback); /* Create Tcl_Channel BIO Handler */ - statePtr->p_bio = bio = BIO_new_tcl( statePtr, BIO_CLOSE); - statePtr->bio = BIO_new(BIO_f_ssl()); + statePtr->p_bio = BIO_new_tcl(statePtr, BIO_CLOSE); + statePtr->bio = BIO_new(BIO_f_ssl()); if (server) { statePtr->flags |= TLS_TCL_SERVER; SSL_set_accept_state(statePtr->ssl); } else { SSL_set_connect_state(statePtr->ssl); } - SSL_set_bio(statePtr->ssl, bio, bio); + SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio); BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_CLOSE); /* * End of SSL Init */ @@ -939,11 +973,11 @@ #if 0 Tcl_DStringFree(&ds); Tcl_DStringFree(&ds1); /* Don't currently care if this fails */ Tcl_AppendResult(interp, "SSL default verify paths: ", - REASON(), (char *) NULL); + REASON(), (char *) NULL); SSL_CTX_free(ctx); return (SSL_CTX *)0; #endif } SSL_CTX_set_client_CA_list(ctx, SSL_load_client_CA_file( F2N(CAfile, &ds) )); @@ -984,32 +1018,39 @@ Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } channelName = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel( interp, channelName, &mode); - if (chan == (Tcl_Channel)0) { + chan = Tcl_GetChannel(interp, channelName, &mode); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); +#endif 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); - peer = SSL_get_peer_certificate(statePtr->ssl); - if (peer) - objPtr = Tls_NewX509Obj( interp, peer); - else - objPtr = Tcl_NewListObj( 0, NULL); + statePtr = (State *) Tcl_GetChannelInstanceData(chan); + peer = SSL_get_peer_certificate(statePtr->ssl); + if (peer) { + objPtr = Tls_NewX509Obj(interp, peer); + } else { + objPtr = Tcl_NewListObj(0, NULL); + } ciphers = (char*)SSL_get_cipher(statePtr->ssl); if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) { - Tcl_ListObjAppendElement( interp, objPtr, - Tcl_NewStringObj( "cipher", -1) ); - Tcl_ListObjAppendElement( interp, objPtr, - Tcl_NewStringObj( SSL_get_cipher(statePtr->ssl), -1) ); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("cipher", -1)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1)); } Tcl_SetObjResult( interp, objPtr); return TCL_OK; } @@ -1057,25 +1098,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; - } } /* *------------------------------------------------------------------- * @@ -1099,29 +1143,31 @@ #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 2 if (!Tcl_InitStubs(interp, TCL_VERSION, 0)) { return TCL_ERROR; } #endif + if (SSL_library_init() != 1) { + Tcl_AppendResult(interp, "could not initialize SSL library", NULL); + return TCL_ERROR; + } SSL_load_error_strings(); ERR_load_crypto_strings(); - SSL_library_init(); - - Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd , (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - - Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd , (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - - Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd , (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - - Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd , (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); + + Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); return Tcl_PkgProvide(interp, PACKAGE, VERSION); } - /* *------------------------------------------------------* * * Tls_SafeInit -- 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 2000/01/20 01:51:39 aborr Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.4 2000/07/26 22:15:07 hobbs Exp $ * * Provides BIO layer to interface openssl to Tcl. */ #include "tlsInt.h" @@ -36,14 +36,14 @@ State *statePtr; int flags; { BIO *bio; - bio = BIO_new(&BioMethods); - bio->ptr = (char*)statePtr; - bio->init = 1; - bio->shutdown = flags; + bio = BIO_new(&BioMethods); + bio->ptr = (char*)statePtr; + bio->init = 1; + bio->shutdown = flags; return bio; } BIO_METHOD * @@ -56,30 +56,35 @@ BioWrite (bio, buf, bufLen) BIO *bio; char *buf; int bufLen; { - Tcl_Channel chan = Tls_GetParent((State*)bio->ptr); + Tcl_Channel chan = Tls_GetParent((State*)(bio->ptr)); int ret; dprintf(stderr,"\nBioWrite(0x%x, , %d) [0x%x]", bio, bufLen, chan); - ret = Tcl_Write( chan, buf, bufLen); +#ifdef TCL_CHANNEL_VERSION_2 + ret = Tcl_WriteRaw(chan, buf, bufLen); +#else + ret = Tcl_Write(chan, buf, bufLen); +#endif dprintf(stderr,"\n[0x%x] BioWrite(%d) -> %d [%d.%d]", chan, bufLen, ret, - Tcl_Eof( chan), Tcl_GetErrno()); + Tcl_Eof(chan), Tcl_GetErrno()); BIO_clear_flags(bio, BIO_FLAGS_WRITE|BIO_FLAGS_SHOULD_RETRY); if (ret == 0) { - if (!Tcl_Eof( chan)) { + if (!Tcl_Eof(chan)) { BIO_set_retry_write(bio); ret = -1; } } - if (BIO_should_read(bio)) + if (BIO_should_read(bio)) { BIO_set_retry_read(bio); + } return ret; } static int BioRead (bio, buf, bufLen) @@ -92,34 +97,39 @@ dprintf(stderr,"\nBioRead(0x%x, , %d) [0x%x]", bio, bufLen, chan); if (buf == NULL) return 0; - ret = Tcl_Read( chan, buf, bufLen); +#ifdef TCL_CHANNEL_VERSION_2 + ret = Tcl_ReadRaw(chan, buf, bufLen); +#else + ret = Tcl_Read(chan, buf, bufLen); +#endif dprintf(stderr,"\n[0x%x] BioRead(%d) -> %d [%d.%d]", chan, bufLen, ret, - Tcl_Eof(chan), Tcl_GetErrno()); + Tcl_Eof(chan), Tcl_GetErrno()); BIO_clear_flags(bio, BIO_FLAGS_READ|BIO_FLAGS_SHOULD_RETRY); if (ret == 0) { - if (!Tcl_Eof( chan)) { + if (!Tcl_Eof(chan)) { BIO_set_retry_read(bio); ret = -1; } } - if (BIO_should_write(bio)) + if (BIO_should_write(bio)) { BIO_set_retry_write(bio); + } return ret; } static int BioPuts (bio, str) BIO *bio; char *str; { - return BioWrite( bio, str, strlen(str)); + return BioWrite(bio, str, strlen(str)); } static long BioCtrl (bio, cmd, num, ptr) BIO *bio; @@ -144,84 +154,91 @@ 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); + 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"); - if (Tcl_Flush( chan) == TCL_OK) - ret=1; - else - ret=-1; + if ( +#ifdef TCL_CHANNEL_VERSION_2 + Tcl_WriteRaw(chan, "", 0) >= 0 +#else + Tcl_Flush(chan) == TCL_OK +#endif + ) { + ret = 1; + } else { + ret = -1; + } break; default: - ret=0; + ret = 0; break; } return(ret); } 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 2000/06/05 18:09:54 welch Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.4 2000/07/26 22:15:07 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 @@ -30,51 +30,75 @@ /* * Forward declarations */ -static int BlockModeProc _ANSI_ARGS_((ClientData instanceData, int mode)); -static int CloseProc _ANSI_ARGS_ ((ClientData instanceData, Tcl_Interp *interp)); -static int InputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int bufSize, int *errorCodePtr)); -static int OutputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCodePtr)); -static int GetOptionProc _ANSI_ARGS_ ((ClientData instanceData, - Tcl_Interp *interp, char *optionName, Tcl_DString *dsPtr)); -static void WatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); -static int GetHandleProc _ANSI_ARGS_ ((ClientData instanceData, - int direction, ClientData *handlePtr)); -static void ChannelHandler _ANSI_ARGS_ ((ClientData clientData, int mask)); -static void ChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData)); +static int TlsBlockModeProc _ANSI_ARGS_((ClientData instanceData, + int mode)); +static int TlsCloseProc _ANSI_ARGS_ ((ClientData instanceData, + Tcl_Interp *interp)); +static int TlsInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int bufSize, int *errorCodePtr)); +static int TlsOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCodePtr)); +static int TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + Tcl_DString *dsPtr)); +static void TlsWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); +static int TlsGetHandleProc _ANSI_ARGS_ ((ClientData instanceData, + int direction, ClientData *handlePtr)); +static int TlsNotifyProc _ANSI_ARGS_ ((ClientData instanceData, + int mask)); +static void TlsChannelHandler _ANSI_ARGS_ ((ClientData clientData, + int mask)); +static void TlsChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData)); /* * This structure describes the channel type structure for TCP socket * based IO: */ - +#ifdef TCL_CHANNEL_VERSION_2 +static Tcl_ChannelType tlsChannelType = { + "tls", /* Type name. */ + 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. */ + TlsGetHandleProc, /* Get file handle out of channel. */ + NULL, /* Close2Proc. */ + TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ + NULL, /* FlushProc. */ + TlsNotifyProc, /* handlerProc. */ +}; +#else static Tcl_ChannelType tlsChannelType = { "tls", /* Type name. */ - BlockModeProc, /* Set blocking/nonblocking mode.*/ - CloseProc, /* Close proc. */ - InputProc, /* Input proc. */ - OutputProc, /* Output proc. */ + TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ + TlsCloseProc, /* Close proc. */ + TlsInputProc, /* Input proc. */ + TlsOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ - GetOptionProc, /* Get option proc. */ - WatchProc, /* Initialize notifier. */ - GetHandleProc, /* Get file handle out of channel. */ + TlsGetOptionProc, /* Get option proc. */ + TlsWatchProc, /* Initialize notifier. */ + TlsGetHandleProc, /* Get file handle out of channel. */ }; +#endif Tcl_ChannelType *Tls_ChannelType() { return &tlsChannelType; } /* *------------------------------------------------------------------- * - * BlockModeProc -- + * TlsBlockModeProc -- * * This procedure is invoked by the generic IO level * to set blocking and nonblocking modes * Results: * 0 if successful, errno when failed. @@ -84,11 +108,11 @@ * *------------------------------------------------------------------- */ static int -BlockModeProc(ClientData instanceData, /* Socket state. */ +TlsBlockModeProc(ClientData instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { State *statePtr = (State *) instanceData; @@ -96,18 +120,22 @@ if (mode == TCL_MODE_NONBLOCKING) { statePtr->flags |= TLS_TCL_ASYNC; } else { statePtr->flags &= ~(TLS_TCL_ASYNC); } +#ifdef TCL_CHANNEL_VERSION_2 + return 0; +#else return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr), "-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1"); +#endif } /* *------------------------------------------------------------------- * - * CloseProc -- + * TlsCloseProc -- * * This procedure is invoked by the generic IO level to perform * channel-type-specific cleanup when a SSL socket based channel * is closed. * @@ -120,39 +148,36 @@ * Closes the socket of the channel. * *------------------------------------------------------------------- */ static int -CloseProc(ClientData instanceData, /* The socket to close. */ +TlsCloseProc(ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* For error reporting - unused. */ { State *statePtr = (State *) instanceData; - dprintf(stderr,"\nCloseProc(0x%x)", statePtr); + 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". */ Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - ChannelHandler, (ClientData) statePtr); - - if (statePtr->timer != (Tcl_TimerToken)NULL) { - Tcl_DeleteTimerHandler (statePtr->timer); - statePtr->timer = (Tcl_TimerToken)NULL; - } + TlsChannelHandler, (ClientData) statePtr); +#endif Tls_Clean(statePtr); - Tcl_EventuallyFree( (ClientData)statePtr, Tls_Free); + Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); return TCL_OK; } /* *------------------------------------------------------------------- * - * InputProc -- + * TlsInputProc -- * * This procedure is invoked by the generic IO level * to read input from a SSL socket based channel. * * Results: @@ -165,15 +190,15 @@ * *------------------------------------------------------------------- */ static int -InputProc(ClientData instanceData, /* Socket state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCodePtr) /* Where to store error code. */ +TlsInputProc(ClientData instanceData, /* Socket state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available + * in the buffer? */ + int *errorCodePtr) /* Where to store error code. */ { State *statePtr = (State *) instanceData; int bytesRead; /* How many bytes were read? */ *errorCodePtr = 0; @@ -187,43 +212,52 @@ } } if (statePtr->flags & TLS_TCL_INIT) { statePtr->flags &= ~(TLS_TCL_INIT); } + /* + * We need to clear the SSL error stack now because we sometimes reach + * this function with leftover errors in the stack. If BIO_read + * returns -1 and intends EAGAIN, there is a leftover error, it will be + * misconstrued as an error, not EAGAIN. + * + * Alternatively, we may want to handle the <0 return codes from + * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO + * functions play with the retry flags though, and this seems to work + * correctly. Similar fix in TlsOutputProc. - hobbs + */ + ERR_clear_error(); bytesRead = BIO_read(statePtr->bio, buf, bufSize); dprintf(stderr,"\nBIO_read -> %d", bytesRead); if (bytesRead < 0) { int err = SSL_get_error(statePtr->ssl, bytesRead); if (err == SSL_ERROR_SSL) { Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, bytesRead)); *errorCodePtr = ECONNABORTED; - goto input; } else if (BIO_should_retry(statePtr->bio)) { dprintf(stderr,"RE! "); *errorCodePtr = EAGAIN; - goto input; - } - if (Tcl_GetErrno() == ECONNRESET) { - /* Soft EOF */ - bytesRead = 0; - goto input; } else { *errorCodePtr = Tcl_GetErrno(); - goto input; + if (*errorCodePtr == ECONNRESET) { + /* Soft EOF */ + *errorCodePtr = 0; + bytesRead = 0; + } } } -input: + input: dprintf(stderr, "\nInput(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr); return bytesRead; } /* *------------------------------------------------------------------- * - * OutputProc -- + * TlsOutputProc -- * * This procedure is invoked by the generic IO level * to write output to a SSL socket based channel. * * Results: @@ -235,21 +269,21 @@ * *------------------------------------------------------------------- */ static int -OutputProc(ClientData instanceData, /* Socket state. */ - char *buf, /* The data buffer. */ +TlsOutputProc(ClientData instanceData, /* Socket state. */ + char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { State *statePtr = (State *) instanceData; int written, err; *errorCodePtr = 0; - dprintf(stderr,"\nBIO_write(%d)", toWrite); + dprintf(stderr,"\nBIO_write(0x%x, %d)", statePtr, toWrite); if (!SSL_is_init_finished(statePtr->ssl)) { written = Tls_WaitForConnect(statePtr, errorCodePtr); if (written <= 0) { goto output; @@ -262,57 +296,71 @@ dprintf(stderr, "zero-write\n"); BIO_flush(statePtr->bio); written = 0; goto output; } else { + /* + * We need to clear the SSL error stack now because we sometimes reach + * this function with leftover errors in the stack. If BIO_write + * returns -1 and intends EAGAIN, there is a leftover error, it will be + * misconstrued as an error, not EAGAIN. + * + * Alternatively, we may want to handle the <0 return codes from + * BIO_write specially (as advised in the RSA docs). TLS's lower level + * BIO functions play with the retry flags though, and this seems to + * work correctly. Similar fix in TlsInputProc. - hobbs + */ + ERR_clear_error(); written = BIO_write(statePtr->bio, buf, toWrite); - dprintf(stderr,"\nBIO_write(%d) -> [%d]", toWrite, written); + dprintf(stderr,"\nBIO_write(0x%x, %d) -> [%d]", + statePtr, toWrite, written); } - if (written < 0 || written == 0) { + if (written <= 0) { switch ((err = SSL_get_error(statePtr->ssl, written))) { - case SSL_ERROR_NONE: - if (written <= 0) { - written = 0; - goto output; - } - break; - case SSL_ERROR_WANT_WRITE: - dprintf(stderr,"write W BLOCK\n"); - break; - case SSL_ERROR_WANT_READ: - dprintf(stderr,"write R BLOCK\n"); - break; - case SSL_ERROR_WANT_X509_LOOKUP: - dprintf(stderr,"write X BLOCK\n"); - break; - case SSL_ERROR_ZERO_RETURN: - dprintf(stderr,"closed\n"); - written = 0; - goto output; - case SSL_ERROR_SYSCALL: - *errorCodePtr = Tcl_GetErrno(); - dprintf(stderr,"[%d] syscall errr: %d\n", written, Tcl_GetErrno()); - written = -1; - goto output; - case SSL_ERROR_SSL: - Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written)); - *errorCodePtr = ECONNABORTED; - written = -1; - goto output; - default: - dprintf(stderr,"unknown err: %d\n", err); - } - } -output: + case SSL_ERROR_NONE: + if (written < 0) { + written = 0; + } + break; + case SSL_ERROR_WANT_WRITE: + dprintf(stderr," write W BLOCK"); + break; + case SSL_ERROR_WANT_READ: + dprintf(stderr," write R BLOCK"); + break; + case SSL_ERROR_WANT_X509_LOOKUP: + dprintf(stderr," write X BLOCK"); + break; + case SSL_ERROR_ZERO_RETURN: + dprintf(stderr," closed\n"); + written = 0; + break; + case SSL_ERROR_SYSCALL: + *errorCodePtr = Tcl_GetErrno(); + dprintf(stderr," [%d] syscall errr: %d", + written, *errorCodePtr); + written = -1; + break; + case SSL_ERROR_SSL: + Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written)); + *errorCodePtr = ECONNABORTED; + written = -1; + break; + default: + dprintf(stderr," unknown err: %d\n", err); + break; + } + } + output: dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written); return written; } /* *------------------------------------------------------------------- * - * GetOptionProc -- + * TlsGetOptionProc -- * * Computes an option value for a SSL socket based channel, or a * list of all options and their values. * * Note: This code is based on code contributed by John Haxby. @@ -326,19 +374,39 @@ * None. * *------------------------------------------------------------------- */ static int -GetOptionProc(ClientData instanceData, /* Socket state. */ +TlsGetOptionProc(ClientData instanceData, /* Socket state. */ Tcl_Interp *interp, /* For errors - can be NULL. */ char *optionName, /* Name of the option to * retrieve the value for, or * NULL to get all options and * their values. */ Tcl_DString *dsPtr) /* Where to store the computed value * initialized by caller. */ { +#ifdef TCL_CHANNEL_VERSION_2 + State *statePtr = (State *) instanceData; + Tcl_Channel downChan = Tls_GetParent(statePtr); + Tcl_DriverGetOptionProc *getOptionProc; + + getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); + if (getOptionProc != NULL) { + return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), + interp, optionName, dsPtr); + } else if (optionName == (char*) NULL) { + /* + * Request is query for all options, this is ok. + */ + return TCL_OK; + } + /* + * Request for a specific option has to fail, we don't have any. + */ + return TCL_ERROR; +#else State *statePtr = (State *) instanceData; size_t len = 0; if (optionName != (char *) NULL) { len = strlen(optionName); @@ -355,16 +423,17 @@ return TCL_OK; } } #endif return TCL_OK; +#endif } /* *------------------------------------------------------------------- * - * WatchProc -- + * TlsWatchProc -- * * Initialize the notifier to watch Tcl_Files from this channel. * * Results: * None. @@ -375,17 +444,52 @@ * *------------------------------------------------------------------- */ static void -WatchProc(ClientData instanceData, /* The socket state. */ +TlsWatchProc(ClientData instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed * combination of TCL_READABLE, * TCL_WRITABLE and TCL_EXCEPTION. */ { State *statePtr = (State *) instanceData; +#ifdef TCL_CHANNEL_VERSION_2 + Tcl_Channel downChan; + + statePtr->watchMask = mask; + + /* No channel handlers any more. We will be notified automatically + * about events on the channel below via a call to our + * 'TransformNotifyProc'. But we have to pass the interest down now. + * We are allowed to add additional 'interest' to the mask if we want + * to. But this transformation has no such interest. It just passes + * the request down, unchanged. + */ + + downChan = Tls_GetParent(statePtr); + + (Tcl_GetChannelType(downChan)) + ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); + + /* + * Management of the internal timer. + */ + + if (statePtr->timer != (Tcl_TimerToken) NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + } + if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { + /* + * There is interest in readable events and we actually have + * data waiting, so generate a timer to flush that. + */ + statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, + TlsChannelHandlerTimer, (ClientData) statePtr); + } +#else if (mask == statePtr->watchMask) return; if (statePtr->watchMask) { /* @@ -392,27 +496,28 @@ * Remove event handler to underlying channel, this could * be because we are closing for real, or being "unstacked". */ Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - ChannelHandler, (ClientData) statePtr); + TlsChannelHandler, (ClientData) statePtr); } statePtr->watchMask = mask; if (statePtr->watchMask) { /* * Setup active monitor for events on underlying Channel. */ Tcl_CreateChannelHandler(Tls_GetParent(statePtr), - statePtr->watchMask, ChannelHandler, (ClientData) statePtr); + statePtr->watchMask, TlsChannelHandler, (ClientData) statePtr); } +#endif } /* *------------------------------------------------------------------- * - * GetHandleProc -- + * TlsGetHandleProc -- * * Called from Tcl_GetChannelFile to retrieve o/s file handler * from the SSL socket based channel. * * Results: @@ -422,23 +527,70 @@ * None. * *------------------------------------------------------------------- */ static int -GetHandleProc(ClientData instanceData, /* The socket state. */ +TlsGetHandleProc(ClientData instanceData, /* The socket state. */ int direction, /* Which Tcl_File to retrieve? */ ClientData *handlePtr) /* Where to store the handle. */ { State *statePtr = (State *) instanceData; - return Tcl_GetChannelHandle (Tls_GetParent(statePtr), direction, handlePtr); + return Tcl_GetChannelHandle(Tls_GetParent(statePtr), direction, handlePtr); +} + +/* + *------------------------------------------------------------------- + * + * TlsNotifyProc -- + * + * Handler called by Tcl to inform us of activity + * on the underlying channel. + * + * Results: + * None. + * + * Side effects: + * May process the incoming event by itself. + * + *------------------------------------------------------------------- + */ + +static int +TlsNotifyProc(instanceData, mask) + ClientData instanceData; /* The state of the notified transformation */ + int mask; /* The mask of occuring events */ +{ + State *statePtr = (State *) instanceData; + + /* + * An event occured in the underlying channel. This + * transformation doesn't process such events thus returns the + * incoming mask unchanged. + */ + + if (statePtr->timer != (Tcl_TimerToken) NULL) { + /* + * Delete an existing timer. It was not fired, yet we are + * here, so the channel below generated such an event and we + * don't have to. The renewal of the interest after the + * execution of channel handlers will eventually cause us to + * recreate the timer (in WatchProc). + */ + + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + } + + return mask; } +#ifndef TCL_CHANNEL_VERSION_2 /* *------------------------------------------------------* * - * ChannelHandler -- + * TlsChannelHandler -- * * ------------------------------------------------* * Handler called by Tcl as a result of * Tcl_CreateChannelHandler - to inform us of activity * on the underlying channel. @@ -453,13 +605,13 @@ * *------------------------------------------------------* */ static void -ChannelHandler (clientData, mask) -ClientData clientData; -int mask; +TlsChannelHandler (clientData, mask) + ClientData clientData; + int mask; { State *statePtr = (State *) clientData; dprintf(stderr, "HANDLER(0x%x)\n", mask); Tcl_Preserve( (ClientData)statePtr); @@ -501,41 +653,42 @@ if (statePtr->timer != (Tcl_TimerToken)NULL) { Tcl_DeleteTimerHandler(statePtr->timer); statePtr->timer = (Tcl_TimerToken)NULL; } - if ((mask & TCL_READABLE) && Tcl_InputBuffered (statePtr->self) > 0) { + if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { /* * Data is waiting, flush it out in short time */ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, - ChannelHandlerTimer, (ClientData) statePtr); + TlsChannelHandlerTimer, (ClientData) statePtr); } Tcl_Release( (ClientData)statePtr); } +#endif /* *------------------------------------------------------* * - * ChannelHandlerTimer -- + * TlsChannelHandlerTimer -- * * ------------------------------------------------* * Called by the notifier (-> timer) to flush out * information waiting in channel buffers. * ------------------------------------------------* * * Sideeffects: - * As of 'ChannelHandler'. + * As of 'TlsChannelHandler'. * * Result: * None. * *------------------------------------------------------* */ static void -ChannelHandlerTimer (clientData) +TlsChannelHandlerTimer (clientData) ClientData clientData; /* Transformation to query */ { State *statePtr = (State *) clientData; int mask = 0; @@ -578,18 +731,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! "); @@ -604,11 +759,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(); @@ -622,10 +778,13 @@ Tcl_Channel Tls_GetParent( statePtr ) State *statePtr; { +#ifdef TCL_CHANNEL_VERSION_2 + return Tcl_GetStackedChannel(statePtr->self); +#else #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2 return statePtr->parent; #else /* The reason for the existence of this procedure is * the fact that stacking a transform over another @@ -640,29 +799,31 @@ * It walks the chain of Channel structures until it * finds the one pointing having 'ctrl' as instanceData * and then returns the superceding channel to that. (AK) */ - Tcl_Channel self = statePtr->self; - Tcl_Channel next; - - while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { - next = Tcl_GetStackedChannel (self); - if (next == (Tcl_Channel) NULL) { - /* 09/24/1999 Unstacking bug, found by Matt Newman . - * - * We were unable to find the channel structure for this - * transformation in the chain of stacked channel. This - * means that we are currently in the process of unstacking - * it *and* there were some bytes waiting which are now - * flushed. In this situation the pointer to the channel - * itself already refers to the parent channel we have to - * write the bytes into, so we return that. - */ - return statePtr->self; - } - self = next; - } - - return Tcl_GetStackedChannel (self); + Tcl_Channel self = statePtr->self; + Tcl_Channel next; + + while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { + next = Tcl_GetStackedChannel (self); + if (next == (Tcl_Channel) NULL) { + /* 09/24/1999 Unstacking bug, + * found by Matt Newman . + * + * We were unable to find the channel structure for this + * transformation in the chain of stacked channel. This + * means that we are currently in the process of unstacking + * it *and* there were some bytes waiting which are now + * flushed. In this situation the pointer to the channel + * itself already refers to the parent channel we have to + * write the bytes into, so we return that. + */ + return statePtr->self; + } + self = next; + } + + return Tcl_GetStackedChannel (self); +#endif #endif }