Index: ChangeLog
==================================================================
--- ChangeLog
+++ ChangeLog
@@ -1,5 +1,86 @@
+2000-07-26 Jeff Hobbs <hobbs@scriptics.com>
+
+ * 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 <hobbs@scriptics.com>
+
+ * 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 <hobbs@scriptics.com>
+
+ * pkgIndex.tcl.in:
+ * configure.in: updated version to 1.4
+
+2000-07-13 Jeff Hobbs <hobbs@scriptics.com>
+
+ * 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 <hobbs@scriptics.com>
+
+ * 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 <hobbs@scriptics.com>
+
+ * 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 <stanton@ajubasolutions.com>
* 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 <matt@novadigm.com>
*
- * $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 <matt@novadigm.com>
#
-# $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 <matt@novadigm.com>
*
- * $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, <buf>, %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, <buf>, %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 <matt@novadigm.com>
*
- * $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 <matt@sensus.org>.
- *
- * 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 <matt@sensus.org>.
+ *
+ * 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
}