Index: aclocal/tcl.m4 ================================================================== --- aclocal/tcl.m4 +++ aclocal/tcl.m4 @@ -1,10 +1,10 @@ dnl Tcl M4 Routines dnl Find a runnable Tcl AC_DEFUN([TCLEXT_FIND_TCLSH_PROG], [ - AC_CACHE_CHECK([runnable tclsh], [tcl_cv_tclsh_native_path], [ + AC_CACHE_CHECK([for runnable tclsh], [tcl_cv_tclsh_native_path], [ dnl Try to find a runnable tclsh if test -z "$TCLCONFIGPATH"; then TCLCONFIGPATH=/dev/null/null fi @@ -50,22 +50,24 @@ TCLCONFIGPATH="$withval" ], [ if test "$cross_compiling" = 'no'; then TCLEXT_FIND_TCLSH_PROG - tclConfigCheckDir="`echo 'puts [[tcl::pkgconfig get libdir,runtime]]' | "$TCLSH_PROG" 2>/dev/null`" + tclConfigCheckDir0="`echo 'puts [[tcl::pkgconfig get libdir,runtime]]' | "$TCLSH_PROG" 2>/dev/null`" + tclConfigCheckDir1="`echo 'puts [[tcl::pkgconfig get scriptdir,runtime]]' | "$TCLSH_PROG" 2>/dev/null`" else - tclConfigCheckDir=/dev/null/null + tclConfigCheckDir0=/dev/null/null + tclConfigCheckDir1=/dev/null/null fi if test "$cross_compiling" = 'no'; then dirs="/usr/$host_alias/lib /usr/lib /usr/lib64 /usr/local/lib /usr/local/lib64" else dirs='' fi - for dir in "$tclConfigCheckDir" $dirs; do + for dir in "$tclConfigCheckDir0" "$tclConfigCheckDir1" $dirs; do if test -f "$dir/tclConfig.sh"; then TCLCONFIGPATH="$dir" break fi Index: aclocal/tcltls_openssl.m4 ================================================================== --- aclocal/tcltls_openssl.m4 +++ aclocal/tcltls_openssl.m4 @@ -117,17 +117,17 @@ dnl Verify that basic functionality is there AC_LANG_PUSH(C) AC_MSG_CHECKING([if a basic OpenSSL program works]) AC_LINK_IFELSE([AC_LANG_PROGRAM([ #include +#include #if (SSLEAY_VERSION_NUMBER >= 0x0907000L) # include #endif ], [ - (void)SSL_library_init(); + SSL_library_init(); SSL_load_error_strings(); - OPENSSL_config(NULL); ])], [ AC_MSG_RESULT([yes]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([Unable to compile a basic program using OpenSSL]) Index: autogen.sh ================================================================== --- autogen.sh +++ autogen.sh @@ -11,10 +11,11 @@ urls=( http://chiselapp.com/user/rkeene/repository/autoconf/doc/trunk/tcl.m4 http://chiselapp.com/user/rkeene/repository/autoconf/doc/trunk/shobj.m4 http://chiselapp.com/user/rkeene/repository/autoconf/doc/trunk/versionscript.m4 + 'http://git.savannah.gnu.org/gitweb/?p=autoconf-archive.git;a=blob_plain;f=m4/ax_check_compile_flag.m4' ) localFiles=( aclocal/tcltls_openssl.m4 ) Index: configure.in ================================================================== --- configure.in +++ configure.in @@ -106,26 +106,58 @@ tcltls_debug='true' fi ]) if test "$tcltls_debug" = 'true'; then AC_DEFINE(TCLEXT_TCLTLS_DEBUG, [1], [Enable debugging build]) + AX_CHECK_COMPILE_FLAG([-fcheck-pointer-bounds], [CFLAGS="$CFLAGS -fcheck-pointer-bounds"]) + AX_CHECK_COMPILE_FLAG([-fsanitize=address], [CFLAGS="$CFLAGS -fsanitize=address"]) + AX_CHECK_COMPILE_FLAG([-fsanitize=undefined], [CFLAGS="$CFLAGS -fsanitize=undefined"]) +else + dnl If we are not doing debugging disable some of the more annoying warnings + AX_CHECK_COMPILE_FLAG([-Wno-unused-value], [CFLAGS="$CFLAGS -Wno-unused-value"]) + AX_CHECK_COMPILE_FLAG([-Wno-unused-parameter], [CFLAGS="$CFLAGS -Wno-unused-parameter"]) + AX_CHECK_COMPILE_FLAG([-Wno-deprecated-declarations], [CFLAGS="$CFLAGS -Wno-deprecated-declarations"]) fi dnl Find "xxd" so we can build the tls.tcl.h file AC_CHECK_PROG([XXD], [xxd], [xxd], [__xxd__not__found]) dnl Find "pkg-config" since we need to use it AC_CHECK_TOOL([PKGCONFIG], [pkg-config], [false]) + +dnl Determine if we have been asked to use a fast path if possible +tcltls_ssl_fastpath='yes' +AC_ARG_ENABLE([ssl-fastpath], AS_HELP_STRING([--disable-ssl-fast-path], [disable using the underlying file descriptor for talking directly to the SSL library]), [ + if test "$enableval" = 'no'; then + tcltls_ssl_fastpath='no' + fi +]) + +if test "$tcltls_ssl_fastpath" = 'yes'; then + AC_DEFINE(TCLTLS_SSL_USE_FASTPATH, [1], [Define this to enable using the underlying file descriptor for talking directly to the SSL library]) +fi dnl Determine if we have been asked to statically link to the SSL library TCLEXT_TLS_STATIC_SSL='no' AC_ARG_ENABLE([static-ssl], AS_HELP_STRING([--enable-static-ssl], [enable statically linking to the specified SSL library]), [ if test "$enableval" = 'yes'; then TCLEXT_TLS_STATIC_SSL='yes' fi ]) +dnl Enable compiler warnings +AX_CHECK_COMPILE_FLAG([-Wall], [CFLAGS="$CFLAGS -Wall"]) +AX_CHECK_COMPILE_FLAG([-W], [ + CFLAGS="$CFLAGS -W" + AX_CHECK_COMPILE_FLAG([-Wno-self-assign], [CFLAGS="$CFLAGS -Wno-self-assign"]) +]) + +dnl Enable hardening +AX_CHECK_COMPILE_FLAG([-fstack-protector-all], [CFLAGS="$CFLAGS -fstack-protector-all"]) +AX_CHECK_COMPILE_FLAG([-fno-strict-overflow], [CFLAGS="$CFLAGS -fno-strict-overflow"]) +AC_DEFINE([_FORTIFY_SOURCE], [2], [Enable fortification]) + dnl XXX:TODO: Automatically determine the SSL library to use dnl defaulting to OpenSSL for compatibility reasons if test "$tcltls_ssl_lib" = 'auto'; then tcltls_ssl_lib='openssl' fi Index: gen_dh_params ================================================================== --- gen_dh_params +++ gen_dh_params @@ -35,13 +35,12 @@ return 1 } gen_dh_params_fallback() { cat << \_EOF_ -DH *get_dh2048() - { - static unsigned char dh2048_p[]={ +DH *get_dh2048(void) { + static unsigned char dhp_2048[] = { 0xC1,0x51,0x58,0x69,0xFB,0xE8,0x6C,0x47,0x2B,0x86,0x61,0x4F, 0x20,0x2E,0xD3,0xFC,0x19,0xEE,0xB8,0xF3,0x35,0x7D,0xBA,0x86, 0x2A,0xC3,0xC8,0x6E,0xF4,0x99,0x75,0x65,0xD3,0x7A,0x9E,0xDF, 0xD4,0x1F,0x88,0xE3,0x17,0xFC,0xA1,0xED,0xA2,0xB6,0x77,0x84, 0xAA,0x08,0xF2,0x97,0x59,0x7A,0xA0,0x03,0x0D,0x3E,0x7E,0x6D, @@ -60,23 +59,41 @@ 0x09,0x8F,0xBB,0x8E,0xA0,0xD0,0x96,0xAC,0x30,0x20,0x39,0x3B, 0x8C,0x92,0x65,0x37,0x0A,0x8F,0xEC,0x72,0x8B,0x61,0x7D,0x62, 0x24,0x54,0xE9,0x1D,0x01,0x68,0x89,0xC4,0x7B,0x3C,0x48,0x62, 0x9B,0x83,0x11,0x3A,0x0B,0x0D,0xEF,0x5A,0xE4,0x7A,0xA0,0x69, 0xF4,0x54,0xB5,0x5B, - }; - static unsigned char dh2048_g[]={ + }; + static unsigned char dhg_2048[] = { 0x02, - }; - DH *dh; - - if ((dh=DH_new()) == NULL) return(NULL); - dh->p=BN_bin2bn(dh2048_p,sizeof(dh2048_p),NULL); - dh->g=BN_bin2bn(dh2048_g,sizeof(dh2048_g),NULL); - if ((dh->p == NULL) || (dh->g == NULL)) - { DH_free(dh); return(NULL); } - return(dh); - } + }; + + DH *dh = DH_new();; + BIGNUM *dhp_bn, *dhg_bn; + + if (dh == NULL) { + return NULL; + } + + dhp_bn = BN_bin2bn(dhp_2048, sizeof (dhp_2048), NULL); + dhg_bn = BN_bin2bn(dhg_2048, sizeof (dhg_2048), NULL); + +#ifdef TCLTLS_OPENSSL_PRE_1_1_API + dh->p = dhp_bn; + dh->g = dhg_bn; + + if (dhp_bn == NULL || dhg_bn == NULL) { +#else + if (dhp_bn == NULL || dhg_bn == NULL || !DH_set0_pqg(dh, dhp_bn, NULL, dhg_bn)) { +#endif + DH_free(dh); + BN_free(dhp_bn); + BN_free(dhg_bn); + return(NULL); + } + + return(dh); +} _EOF_ } # Enable support for giving the same DH params each time if [ "$1" = 'fallback' ]; then @@ -83,10 +100,14 @@ gen_dh_params_fallback && exit 0 exit 1 fi +echo "*****************************" +echo "** Generating DH Primes. **" +echo "** This will take a while. **" +echo "*****************************" gen_dh_params_openssl && exit 0 gen_dh_params_remote && exit 0 gen_dh_params_fallback && exit 0 exit 1 Index: tests/all.tcl ================================================================== --- tests/all.tcl +++ tests/all.tcl @@ -16,10 +16,11 @@ namespace import ::tcltest::* } set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] +::tcltest::configure -verbose start # We should ensure that the testsDirectory is absolute. # This was introduced in Tcl 8.3+'s tcltest, so we need a catch. catch {::tcltest::normalizePath ::tcltest::testsDirectory} Index: tests/tlsIO.test ================================================================== --- tests/tlsIO.test +++ tests/tlsIO.test @@ -166,11 +166,11 @@ 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} { + -address $remoteServerIP] 2> /dev/null" w+]} msg] == 0} { after 1000 if {[catch {set commandSocket [tls::socket -cafile $caCert \ -certfile $clientCert -keyfile $clientKey \ $remoteServerIP $remoteServerPort]} msg] == 0} { fconfigure $commandSocket -translation crlf -buffering line @@ -320,11 +320,11 @@ after cancel $timer close $f puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f x if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8828} msg]} { set x $msg } else { @@ -362,11 +362,11 @@ vwait x after cancel $timer close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f x global port if {[catch {tls::socket -myport $port \ -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8829} sock]} { @@ -402,11 +402,11 @@ vwait x after cancel $timer close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f x if {[catch {tls::socket -myaddr 127.0.0.1 \ -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8830} sock]} { set x $sock @@ -440,11 +440,11 @@ vwait x after cancel $timer close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f x if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey [info hostname] 8831} sock]} { set x $sock } else { @@ -477,11 +477,11 @@ vwait x after cancel $timer close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f x if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8832} sock]} { set x $sock } else { @@ -533,11 +533,11 @@ after cancel $timer close $f puts done } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f set s [tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8834] fconfigure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" @@ -580,11 +580,11 @@ after cancel $timer close $f puts "done $i" } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f set s [tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8835] fconfigure $s -buffering line catch { @@ -705,11 +705,11 @@ after cancel $timer close $f puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f x if {[catch {tls::socket 127.0.0.1 8828} msg]} { set x $msg } else { lappend x [gets $f] @@ -732,11 +732,11 @@ puts ready gets stdin close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+] gets $f set x [list [catch {tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ -server accept 8828} msg] \ $msg] @@ -781,11 +781,11 @@ after cancel $t3 close $s puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+] set x [gets $f] set s1 [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8828] fconfigure $s1 -buffering line @@ -796,15 +796,15 @@ set s3 [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8828] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { - puts $s1 hello,s1 + puts $s1 hello,tlsIO-3.2,s1 gets $s1 - puts $s2 hello,s2 + puts $s2 hello,tlsIO-3.2,s2 gets $s2 - puts $s3 hello,s3 + puts $s3 hello,tlsIO-3.2,s3 gets $s3 } close $s1 close $s2 close $s3 @@ -832,15 +832,15 @@ close $s puts bye gets stdin } close $f - set p1 [open "|[list $::tcltest::tcltest script]" r+] + set p1 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+] fconfigure $p1 -buffering line - set p2 [open "|[list $::tcltest::tcltest script]" r+] + set p2 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+] fconfigure $p2 -buffering line - set p3 [open "|[list $::tcltest::tcltest script]" r+] + set p3 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+] fconfigure $p3 -buffering line proc accept {s a p} { fconfigure $s -buffering line fileevent $s readable [list echo $s] } @@ -930,11 +930,11 @@ package require tls gets stdin } puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848] close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+] proc bgerror args { global x set x $args } proc accept {s a p} {expr 10 / 0} @@ -968,11 +968,11 @@ set timer [after 10000 "set x timed_out"] vwait x after cancel $timer } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f set s [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8820] set p [fconfigure $s -peername] @@ -1001,11 +1001,11 @@ set timer [after 10000 "set x timed_out"] vwait x after cancel $timer } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r] gets $f set s [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8821] set p [fconfigure $s -sockname] @@ -1451,15 +1451,15 @@ set s3 [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { - puts $s1 hello,s1 + puts $s1 hello,tlsIO-11.7,s1 gets $s1 - puts $s2 hello,s2 + puts $s2 hello,tlsIO-11.7,s2 gets $s2 - puts $s3 hello,s3 + puts $s3 hello,tlsIO-11.7,s3 gets $s3 } close $s1 close $s2 close $s3 @@ -2039,24 +2039,29 @@ set ::done $msg } # NOTE: when doing an in-process client/server test, both sides need # to be non-blocking for the TLS handshake - # Server - Only accept TLS 1 or higher + # Server - Only accept TLS 1.2 set s [tls::socket \ -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 1 -tls1.2 1 \ + -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 1 \ -server Accept 8831] - # Client - Only propose SSL3 + # Client - Only propose TLS1.0 set c [tls::socket -async \ -cafile $caCert \ - -request 0 -require 0 -ssl2 0 -ssl3 1 -tls1 0 -tls1.1 0 -tls1.2 0 \ + -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 0 -tls1.2 0 \ [info hostname] 8831] fconfigure $c -blocking 0 puts $c a ; flush $c after 5000 [list set ::done timeout] vwait ::done + switch -exact -- $::done { + "handshake failed: wrong ssl version" { + set ::done "handshake failed: wrong version number" + } + } set ::done } {handshake failed: wrong version number} # cleanup if {[string match sock* $commandSocket] == 1} { Index: tls.c ================================================================== --- tls.c +++ tls.c @@ -36,38 +36,38 @@ #define F2N( key, dsp) \ (((key) == NULL) ? (char *) NULL : \ Tcl_TranslateFileName(interp, (key), (dsp))) #define REASON() ERR_reason_error_string(ERR_get_error()) -static void InfoCallback _ANSI_ARGS_ ((CONST SSL *ssl, int where, int ret)); - -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 VersionObjCmd _ANSI_ARGS_ ((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); - -static int MiscObjCmd _ANSI_ARGS_ ((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); - -static int UnimportObjCmd _ANSI_ARGS_ ((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); - -static SSL_CTX *CTX_Init _ANSI_ARGS_((State *statePtr, int proto, char *key, +static void InfoCallback(CONST SSL *ssl, int where, int ret); + +static int CiphersObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int HandshakeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int ImportObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int StatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int VersionObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int MiscObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int UnimportObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static SSL_CTX *CTX_Init(State *statePtr, int proto, char *key, char *cert, char *CAdir, char *CAfile, char *ciphers, - char *DHparams)); + char *DHparams); -static int TlsLibInit _ANSI_ARGS_ ((void)) ; +static int TlsLibInit(int uninitialize); #define TLS_PROTO_SSL2 0x01 #define TLS_PROTO_SSL3 0x02 #define TLS_PROTO_TLS1 0x04 #define TLS_PROTO_TLS1_1 0x08 @@ -80,16 +80,10 @@ #ifndef OPENSSL_NO_DH #include "dh_params.h" #endif -/* - * Defined in Tls_Init to determine what kind of channels we are using - * (old-style 8.2.0-8.3.1 or new-style 8.3.2+). - */ -int channelTypeVersion = TLS_CHANNEL_VERSION_2; - /* * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2 * libraries instead of the current OpenSSL libraries. */ @@ -121,30 +115,42 @@ /* * Threaded operation requires locking callbacks * Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL. */ -static Tcl_Mutex locks[CRYPTO_NUM_LOCKS]; +static Tcl_Mutex *locks = NULL; +static int locksCount = 0; static Tcl_Mutex init_mx; -static void CryptoThreadLockCallback (int mode, int n, const char *file, int line); -static unsigned long CryptoThreadIdCallback (void); - -static void -CryptoThreadLockCallback(int mode, int n, const char *file, int line) -{ - if (mode & CRYPTO_LOCK) { - Tcl_MutexLock(&locks[n]); - } else { - Tcl_MutexUnlock(&locks[n]); - } -} - -static unsigned long -CryptoThreadIdCallback(void) -{ - return (unsigned long) Tcl_GetCurrentThread(); +void CryptoThreadLockCallback(int mode, int n, const char *file, int line) { + + if (mode & CRYPTO_LOCK) { + /* This debugging is turned off by default -- it's too noisy. */ + /* dprintf("Called to lock (n=%i of %i)", n, locksCount); */ + Tcl_MutexLock(&locks[n]); + } else { + /* dprintf("Called to unlock (n=%i of %i)", n, locksCount); */ + Tcl_MutexUnlock(&locks[n]); + } + + dprintf("Returning"); + + return; + file = file; + line = line; +} + +unsigned long CryptoThreadIdCallback(void) { + unsigned long ret; + + dprintf("Called"); + + ret = (unsigned long) Tcl_GetCurrentThread(); + + dprintf("Returning %lu", ret); + + return(ret); } #endif /* OPENSSL_THREADS */ #endif /* TCL_THREADS */ @@ -166,10 +172,12 @@ InfoCallback(CONST SSL *ssl, int where, int ret) { State *statePtr = (State*)SSL_get_app_data((SSL *)ssl); Tcl_Obj *cmdPtr; char *major; char *minor; + + dprintf("Called"); if (statePtr->callback == (Tcl_Obj*)NULL) return; cmdPtr = Tcl_DuplicateObj(statePtr->callback); @@ -262,11 +270,11 @@ VerifyCallback(int ok, X509_STORE_CTX *ctx) { Tcl_Obj *cmdPtr, *result; char *errStr, *string; int length; - SSL *ssl = (SSL*)X509_STORE_CTX_get_app_data(ctx); + SSL *ssl = (SSL*)X509_STORE_CTX_get_ex_data(ctx, SSL_get_ex_data_X509_STORE_CTX_idx()); 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); @@ -352,10 +360,12 @@ void Tls_Error(State *statePtr, char *msg) { Tcl_Obj *cmdPtr; + dprintf("Called"); + if (msg && *msg) { Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL); } else { msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL); } @@ -410,19 +420,24 @@ */ static int PasswordCallback(char *buf, int size, int verify) { return -1; + buf = buf; + size = size; + verify = verify; } #else static int PasswordCallback(char *buf, int size, int verify, void *udata) { State *statePtr = (State *) udata; Tcl_Interp *interp = statePtr->interp; Tcl_Obj *cmdPtr; int result; + + dprintf("Called"); if (statePtr->password == NULL) { if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) == TCL_OK) { char *ret = (char *) Tcl_GetStringResult(interp); @@ -453,10 +468,11 @@ strncpy(buf, ret, (size_t) size); return (int)strlen(ret); } else { return -1; } + verify = verify; } #endif /* *------------------------------------------------------------------- @@ -491,10 +507,12 @@ SSL_CTX *ctx = NULL; SSL *ssl = NULL; STACK_OF(SSL_CIPHER) *sk; char *cp, buf[BUFSIZ]; int index, verbose = 0; + + dprintf("Called"); if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?"); return TCL_ERROR; } @@ -586,10 +604,11 @@ SSL_free(ssl); SSL_CTX_free(ctx); Tcl_SetObjResult( interp, objPtr); return TCL_OK; + clientData = clientData; } /* *------------------------------------------------------------------- * @@ -616,56 +635,62 @@ { Tcl_Channel chan; /* The channel to set a mode on. */ State *statePtr; /* client state for ssl socket */ int ret = 1; + dprintf("Called"); + if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); 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); if (!SSL_is_init_finished(statePtr->ssl)) { int err = 0; + dprintf("Calling Tls_WaitForConnect"); ret = Tls_WaitForConnect(statePtr, &err); + dprintf("Tls_WaitForConnect returned: %i", ret); + if ((statePtr->flags & TLS_TCL_ASYNC) && err == EAGAIN) { dprintf("Async set and err = EAGAIN"); ret = 0; } + if (ret < 0) { CONST char *errStr = statePtr->err; Tcl_ResetResult(interp); Tcl_SetErrno(err); if (!errStr || *errStr == 0) { errStr = Tcl_PosixError(interp); } - Tcl_AppendResult(interp, "handshake failed: ", errStr, - (char *) NULL); + Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL); + dprintf("Returning TCL_ERROR with handshake failed: %s", errStr); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); return TCL_OK; + clientData = clientData; } /* *------------------------------------------------------------------- * @@ -735,25 +760,26 @@ int tls1_2 = 1; #endif int proto = 0; int verify = 0, require = 0, request = 1; + dprintf("Called"); + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?"); return TCL_ERROR; } chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); for (idx = 2; idx < objc; idx++) { char *opt = Tcl_GetStringFromObj(objv[idx], NULL); if (opt[0] != '-') @@ -836,16 +862,15 @@ chan = Tcl_GetChannel(interp, model, &mode); if (chan == (Tcl_Channel) NULL) { Tls_Free((char *) statePtr); return TCL_ERROR; } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); Tls_Free((char *) statePtr); return TCL_ERROR; @@ -866,22 +891,14 @@ * 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"); - if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { - Tcl_SetChannelOption(interp, chan, "-buffering", "none"); - } - - if (channelTypeVersion == TLS_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_SetChannelOption(interp, chan, "-blocking", "true"); + dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan)); + statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); + dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self)); if (statePtr->self == (Tcl_Channel) NULL) { /* * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. */ Tls_Free((char *) statePtr); @@ -921,11 +938,11 @@ SSL_set_verify(statePtr->ssl, verify, VerifyCallback); SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback); /* Create Tcl_Channel BIO Handler */ - statePtr->p_bio = BIO_new_tcl(statePtr, BIO_CLOSE); + statePtr->p_bio = BIO_new_tcl(statePtr, BIO_NOCLOSE); statePtr->bio = BIO_new(BIO_f_ssl()); if (server) { statePtr->flags |= TLS_TCL_SERVER; SSL_set_accept_state(statePtr->ssl); @@ -936,13 +953,15 @@ BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE); /* * End of SSL Init */ + dprintf("Returning %s", Tcl_GetChannelName(statePtr->self)); Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), TCL_VOLATILE); return TCL_OK; + clientData = clientData; } /* *------------------------------------------------------------------- * @@ -966,10 +985,12 @@ int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel chan; /* The channel to set a mode on. */ + dprintf("Called"); + if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } @@ -976,16 +997,14 @@ chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - } + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; @@ -994,10 +1013,11 @@ if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) { return TCL_ERROR; } return TCL_OK; + clientData = clientData; } /* *------------------------------------------------------------------- * @@ -1027,10 +1047,12 @@ SSL_CTX *ctx = NULL; Tcl_DString ds; Tcl_DString ds1; int off = 0; const SSL_METHOD *method; + + dprintf("Called"); if (!proto) { Tcl_AppendResult(interp, "no valid protocol selected", NULL); return (SSL_CTX *)0; } @@ -1277,10 +1299,12 @@ Tcl_Obj *objPtr; Tcl_Channel chan; char *channelName, *ciphers; int mode; + dprintf("Called"); + switch (objc) { case 2: channelName = Tcl_GetStringFromObj(objv[1], NULL); break; @@ -1297,16 +1321,14 @@ chan = Tcl_GetChannel(interp, channelName, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - } + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; } @@ -1335,10 +1357,11 @@ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1)); } Tcl_SetObjResult( interp, objPtr); return TCL_OK; + clientData = clientData; } /* *------------------------------------------------------------------- * @@ -1358,15 +1381,20 @@ Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *objPtr; + + dprintf("Called"); objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1); Tcl_SetObjResult(interp, objPtr); return TCL_OK; + clientData = clientData; + objc = objc; + objv = objv; } /* *------------------------------------------------------------------- * @@ -1388,10 +1416,12 @@ Tcl_Obj *CONST objv[]; { static CONST84 char *commands [] = { "req", NULL }; enum command { C_REQ, C_DUMMY }; int cmd; + + dprintf("Called"); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); return TCL_ERROR; } @@ -1525,10 +1555,11 @@ break; default: break; } return TCL_OK; + clientData = clientData; } /* *------------------------------------------------------------------- * @@ -1547,10 +1578,12 @@ */ void Tls_Free( char *blockPtr ) { State *statePtr = (State *)blockPtr; + + dprintf("Called"); Tls_Clean(statePtr); ckfree(blockPtr); } @@ -1570,17 +1603,16 @@ * Side effects: * Frees all the state * *------------------------------------------------------------------- */ -void -Tls_Clean(State *statePtr) -{ +void Tls_Clean(State *statePtr) { + dprintf("Called"); + /* * we're assuming here that we're single-threaded */ - if (statePtr->timer != (Tcl_TimerToken) NULL) { Tcl_DeleteTimerHandler(statePtr->timer); statePtr->timer = NULL; } @@ -1605,10 +1637,12 @@ } if (statePtr->password) { Tcl_DecrRefCount(statePtr->password); statePtr->password = NULL; } + + dprintf("Returning"); } /* *------------------------------------------------------------------- * @@ -1623,84 +1657,51 @@ * create the ssl command, initialise ssl context * *------------------------------------------------------------------- */ -int -Tls_Init(Tcl_Interp *interp) /* Interpreter in which the package is - * to be made available. */ -{ - const char tlsTclInitScript[] = { +int Tls_Init(Tcl_Interp *interp) { + const char tlsTclInitScript[] = { #include "tls.tcl.h" - }; - - int major, minor, patchlevel, release; - - /* - * The original 8.2.0 stacked channel implementation (and the patch - * that preceded it) had problems with scalability and robustness. - * These were address in 8.3.2 / 8.4a2, so we now require that as a - * minimum for TLS 1.4+. We only support 8.2+ now (8.3.2+ preferred). - */ - if ( + , 0x00 + }; + + dprintf("Called"); + + /* + * We only support Tcl 8.4 or newer + */ + if ( #ifdef USE_TCL_STUBS - Tcl_InitStubs(interp, "8.2", 0) + Tcl_InitStubs(interp, "8.4", 0) #else - Tcl_PkgRequire(interp, "Tcl", "8.2", 0) -#endif - == NULL) { - return TCL_ERROR; - } - - /* - * Get the version so we can runtime switch on available functionality. - * TLS should really only be used in 8.3.2+, but the other works for - * some limited functionality, so an attempt at support is made. - */ - Tcl_GetVersion(&major, &minor, &patchlevel, &release); - if ((major > 8) || ((major == 8) && ((minor > 3) || ((minor == 3) && - (release == TCL_FINAL_RELEASE) && (patchlevel >= 2))))) { - /* 8.3.2+ */ - channelTypeVersion = TLS_CHANNEL_VERSION_2; - } else { - /* 8.2.0 - 8.3.1 */ - channelTypeVersion = TLS_CHANNEL_VERSION_1; - } - - if (TlsLibInit() != TCL_OK) { - Tcl_AppendResult(interp, "could not initialize SSL library", NULL); - return TCL_ERROR; - } - - 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::unimport", UnimportObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - - Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - - Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - - Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - - if (interp) { - Tcl_Eval(interp, tlsTclInitScript); - } - - return Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION); -} - + Tcl_PkgRequire(interp, "Tcl", "8.4", 0) +#endif + == NULL) { + return TCL_ERROR; + } + + if (TlsLibInit(0) != TCL_OK) { + Tcl_AppendResult(interp, "could not initialize SSL library", NULL); + return TCL_ERROR; + } + + 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::unimport", UnimportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + if (interp) { + Tcl_Eval(interp, tlsTclInitScript); + } + + return(Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION)); +} + /* *------------------------------------------------------* * * Tls_SafeInit -- * @@ -1716,17 +1717,15 @@ * A standard Tcl error code. * *------------------------------------------------------* */ -int -Tls_SafeInit (Tcl_Interp* interp) -{ - return Tls_Init (interp); +int Tls_SafeInit(Tcl_Interp *interp) { + dprintf("Called"); + return(Tls_Init(interp)); } - /* *------------------------------------------------------* * * TlsLibInit -- * @@ -1740,71 +1739,106 @@ * Result: * none * *------------------------------------------------------* */ -static int TlsLibInit (void) { - static int initialized = 0; - int i; - char rnd_seed[16] = "GrzSlplKqUdnnzP!"; /* 16 bytes */ - int status=TCL_OK; - - if (initialized) { - return status; - } - initialized = 1; - -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - size_t num_locks; - - Tcl_MutexLock(&init_mx); -#endif - - if (CRYPTO_set_mem_functions((void *(*)(size_t))Tcl_Alloc, - (void *(*)(void *, size_t))Tcl_Realloc, - (void(*)(void *))Tcl_Free) == 0) { - /* Not using Tcl's mem functions ... not critical */ - } - -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - /* should we consider allocating mutexes? */ - num_locks = CRYPTO_num_locks(); - if (num_locks > CRYPTO_NUM_LOCKS) { - status=TCL_ERROR; - goto done; - } - - CRYPTO_set_locking_callback(CryptoThreadLockCallback); - CRYPTO_set_id_callback(CryptoThreadIdCallback); -#endif - - if (SSL_library_init() != 1) { - status=TCL_ERROR; - goto done; - } - SSL_load_error_strings(); - ERR_load_crypto_strings(); - - /* - * Seed the random number generator in the SSL library, - * using the do/while construct because of the bug note in the - * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1 - * - * The crux of the problem is that Solaris 7 does not have a - * /dev/random or /dev/urandom device so it cannot gather enough - * entropy from the RAND_seed() when TLS initializes and refuses - * to go further. Earlier versions of OpenSSL carried on regardless. - */ - srand((unsigned int) time((time_t *) NULL)); - do { - for (i = 0; i < 16; i++) { - rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0)); - } - RAND_seed(rnd_seed, sizeof(rnd_seed)); - } while (RAND_status() != 1); -done: - +static int TlsLibInit(int uninitialize) { + static int initialized = 0; + int status = TCL_OK; +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + size_t num_locks; +#endif + + if (uninitialize) { + if (!initialized) { + dprintf("Asked to uninitialize, but we are not initialized"); + + return(TCL_OK); + } + + dprintf("Asked to uninitialize"); + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexLock(&init_mx); + + CRYPTO_set_locking_callback(NULL); + CRYPTO_set_id_callback(NULL); + + if (locks) { + free(locks); + locks = NULL; + locksCount = 0; + } +#endif + initialized = 0; + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexUnlock(&init_mx); +#endif + + return(TCL_OK); + } + + if (initialized) { + dprintf("Called, but using cached value"); + return(status); + } + + dprintf("Called"); + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexLock(&init_mx); +#endif + initialized = 1; + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + num_locks = CRYPTO_num_locks(); + locksCount = num_locks; + locks = malloc(sizeof(*locks) * num_locks); + memset(locks, 0, sizeof(*locks) * num_locks); + + CRYPTO_set_locking_callback(CryptoThreadLockCallback); + CRYPTO_set_id_callback(CryptoThreadIdCallback); +#endif + + if (SSL_library_init() != 1) { + status = TCL_ERROR; + goto done; + } + + SSL_load_error_strings(); + ERR_load_crypto_strings(); + + BIO_new_tcl(NULL, 0); + +#if 0 + /* + * XXX:TODO: Remove this code and replace it with a check + * for enough entropy and do not try to create our own + * terrible entropy + */ + /* + * Seed the random number generator in the SSL library, + * using the do/while construct because of the bug note in the + * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1 + * + * The crux of the problem is that Solaris 7 does not have a + * /dev/random or /dev/urandom device so it cannot gather enough + * entropy from the RAND_seed() when TLS initializes and refuses + * to go further. Earlier versions of OpenSSL carried on regardless. + */ + srand((unsigned int) time((time_t *) NULL)); + do { + for (i = 0; i < 16; i++) { + rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0)); + } + RAND_seed(rnd_seed, sizeof(rnd_seed)); + } while (RAND_status() != 1); +#endif + +done: #if defined(OPENSSL_THREADS) && defined(TCL_THREADS) Tcl_MutexUnlock(&init_mx); #endif - return status; + + return(status); } Index: tls.h ================================================================== --- tls.h +++ tls.h @@ -16,24 +16,14 @@ * */ #ifndef _TLS_H #define _TLS_H -#include /* Internal definitions for Tcl. */ - -#ifdef TCL_STORAGE_CLASS -# undef TCL_STORAGE_CLASS -#endif -#ifdef BUILD_tls -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# define TCL_STORAGE_CLASS DLLIMPORT -#endif +#include /* - * Forward declarations + * Initialization routines -- our entire public C API. */ - -EXTERN int Tls_Init _ANSI_ARGS_ ((Tcl_Interp *)); -EXTERN int Tls_SafeInit _ANSI_ARGS_ ((Tcl_Interp *)); +int Tls_Init(Tcl_Interp *interp); +int Tls_SafeInit(Tcl_Interp *interp); #endif /* _TLS_H */ Index: tlsBIO.c ================================================================== --- tlsBIO.c +++ tlsBIO.c @@ -4,239 +4,322 @@ * Provides BIO layer to interface openssl to Tcl. */ #include "tlsInt.h" +#ifdef TCLTLS_OPENSSL_PRE_1_1_API +#define BIO_get_data(bio) ((bio)->ptr) +#define BIO_get_init(bio) ((bio)->init) +#define BIO_get_shutdown(bio) ((bio)->shutdown) +#define BIO_set_data(bio, val) (bio)->ptr = (val) +#define BIO_set_init(bio, val) (bio)->init = (val) +#define BIO_set_shutdown(bio, val) (bio)->shutdown = (val) + +/* XXX: This assumes the variable being assigned to is BioMethods */ +#define BIO_meth_new(type_, name_) (BIO_METHOD *)Tcl_Alloc(sizeof(BIO_METHOD)); \ + memset(BioMethods, 0, sizeof(BIO_METHOD)); \ + BioMethods->type = type_; \ + BioMethods->name = name_; +#define BIO_meth_set_write(bio, val) (bio)->bwrite = val; +#define BIO_meth_set_read(bio, val) (bio)->bread = val; +#define BIO_meth_set_puts(bio, val) (bio)->bputs = val; +#define BIO_meth_set_ctrl(bio, val) (bio)->ctrl = val; +#define BIO_meth_set_create(bio, val) (bio)->create = val; +#define BIO_meth_set_destroy(bio, val) (bio)->destroy = val; +#endif + /* * Forward declarations */ -static int BioWrite _ANSI_ARGS_ ((BIO *h, CONST char *buf, int num)); -static int BioRead _ANSI_ARGS_ ((BIO *h, char *buf, int num)); -static int BioPuts _ANSI_ARGS_ ((BIO *h, CONST char *str)); -static long BioCtrl _ANSI_ARGS_ ((BIO *h, int cmd, long arg1, void *ptr)); -static int BioNew _ANSI_ARGS_ ((BIO *h)); -static int BioFree _ANSI_ARGS_ ((BIO *h)); - -BIO * -BIO_new_tcl(statePtr, flags) - State *statePtr; - int flags; -{ - BIO *bio; - static BIO_METHOD BioMethods = { - .type = BIO_TYPE_TCL, - .name = "tcl", - .bwrite = BioWrite, - .bread = BioRead, - .bputs = BioPuts, - .ctrl = BioCtrl, - .create = BioNew, - .destroy = BioFree, - }; - - bio = BIO_new(&BioMethods); - bio->ptr = (char*)statePtr; - bio->init = 1; - bio->shutdown = flags; - - return bio; -} - -static int -BioWrite (bio, buf, bufLen) - BIO *bio; - CONST char *buf; - int bufLen; -{ - Tcl_Channel chan = Tls_GetParent((State*)(bio->ptr)); - int ret; - - dprintf("BioWrite(%p, , %d) [%p]", - (void *) bio, bufLen, (void *) chan); - - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - ret = Tcl_WriteRaw(chan, buf, bufLen); - } else { - ret = Tcl_Write(chan, buf, bufLen); - } - - dprintf("[%p] BioWrite(%d) -> %d [%d.%d]", - (void *) chan, bufLen, ret, Tcl_Eof(chan), Tcl_GetErrno()); - - BIO_clear_flags(bio, BIO_FLAGS_WRITE|BIO_FLAGS_SHOULD_RETRY); - - if (ret == 0) { - if (!Tcl_Eof(chan)) { - BIO_set_retry_write(bio); - ret = -1; - } - } - if (BIO_should_read(bio)) { - BIO_set_retry_read(bio); - } - return ret; -} - -static int -BioRead (bio, buf, bufLen) - BIO *bio; - char *buf; - int bufLen; -{ - Tcl_Channel chan = Tls_GetParent((State*)bio->ptr); - int ret = 0; - int tclEofChan; - - dprintf("BioRead(%p, , %d) [%p]", (void *) bio, bufLen, (void *) chan); - - if (buf == NULL) return 0; - - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - ret = Tcl_ReadRaw(chan, buf, bufLen); - } else { - ret = Tcl_Read(chan, buf, bufLen); - } - - tclEofChan = Tcl_Eof(chan); - - dprintf("[%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", - (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno()); - - BIO_clear_flags(bio, BIO_FLAGS_READ|BIO_FLAGS_SHOULD_RETRY); - - if (ret == 0) { - if (!tclEofChan) { - dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set -- ret == -1 now"); - BIO_set_retry_read(bio); - ret = -1; - } else { - dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is set"); - } - } else { - dprintf("Got non-zero from Tcl_Read or Tcl_ReadRaw == ret == %i", ret); - } - if (BIO_should_write(bio)) { - BIO_set_retry_write(bio); - } - - dprintf("BioRead(%p, , %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret); - - return ret; -} - -static int -BioPuts (bio, str) - BIO *bio; - CONST char *str; -{ - return BioWrite(bio, str, (int) strlen(str)); -} - -static long -BioCtrl (bio, cmd, num, ptr) - BIO *bio; - int cmd; - long num; - void *ptr; -{ - Tcl_Channel chan = Tls_GetParent((State*)bio->ptr); - long ret = 1; - int *ip; - - dprintf("BioCtrl(%p, 0x%x, 0x%x, %p)", - (void *) bio, (unsigned int) cmd, (unsigned int) num, - (void *) ptr); - - switch (cmd) { - case BIO_CTRL_RESET: - num = 0; - case BIO_C_FILE_SEEK: - case BIO_C_FILE_TELL: - ret = 0; - break; - case BIO_CTRL_INFO: - ret = 1; - break; - case BIO_C_SET_FD: - BioFree(bio); - /* Sets State* */ - 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; - } else { - ret = -1; - } - break; - case BIO_CTRL_GET_CLOSE: - ret = bio->shutdown; - break; - case BIO_CTRL_SET_CLOSE: - bio->shutdown = (int)num; - break; - case BIO_CTRL_EOF: - dprintf("BIO_CTRL_EOF"); - ret = Tcl_Eof(chan); - break; - case BIO_CTRL_PENDING: - ret = (Tcl_InputBuffered(chan) ? 1 : 0); - dprintf("BIO_CTRL_PENDING(%d)", (int) ret); - break; - case BIO_CTRL_WPENDING: - ret = 0; - break; - case BIO_CTRL_DUP: - break; - case BIO_CTRL_FLUSH: - dprintf("BIO_CTRL_FLUSH"); - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1); - } else { - ret = ((Tcl_Flush(chan) == TCL_OK) ? 1 : -1); - } - break; - default: - ret = 0; - break; - } - return(ret); -} - -static int -BioNew (bio) - BIO *bio; -{ - bio->init = 0; - bio->num = 0; - bio->ptr = NULL; - bio->flags = 0; - - return 1; -} - -static int -BioFree (bio) - BIO *bio; -{ - 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; - } - return 1; +static int BioWrite _ANSI_ARGS_((BIO *h, CONST char *buf, int num)); +static int BioRead _ANSI_ARGS_((BIO *h, char *buf, int num)); +static int BioPuts _ANSI_ARGS_((BIO *h, CONST char *str)); +static long BioCtrl _ANSI_ARGS_((BIO *h, int cmd, long arg1, void *ptr)); +static int BioNew _ANSI_ARGS_((BIO *h)); +static int BioFree _ANSI_ARGS_((BIO *h)); + +BIO *BIO_new_tcl(State *statePtr, int flags) { + BIO *bio; + static BIO_METHOD *BioMethods = NULL; +#ifdef TCLTLS_SSL_USE_FASTPATH + Tcl_Channel parentChannel; + const Tcl_ChannelType *parentChannelType; + void *parentChannelFdIn_p, *parentChannelFdOut_p; + int parentChannelFdIn, parentChannelFdOut, parentChannelFd; + int validParentChannelFd; + int tclGetChannelHandleRet; +#endif + + dprintf("BIO_new_tcl() called"); + + if (BioMethods == NULL) { + BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl"); + BIO_meth_set_write(BioMethods, BioWrite); + BIO_meth_set_read(BioMethods, BioRead); + BIO_meth_set_puts(BioMethods, BioPuts); + BIO_meth_set_ctrl(BioMethods, BioCtrl); + BIO_meth_set_create(BioMethods, BioNew); + BIO_meth_set_destroy(BioMethods, BioFree); + } + + if (statePtr == NULL) { + dprintf("Asked to setup a NULL state, just creating the initial configuration"); + + return(NULL); + } + +#ifdef TCLTLS_SSL_USE_FASTPATH + /* + * If the channel can be mapped back to a file descriptor, just use the file descriptor + * with the SSL library since it will likely be optimized for this. + */ + parentChannel = Tls_GetParent(statePtr, 0); + parentChannelType = Tcl_GetChannelType(parentChannel); + + validParentChannelFd = 0; + if (strcmp(parentChannelType->typeName, "tcp") == 0) { + tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, (ClientData) &parentChannelFdIn_p); + if (tclGetChannelHandleRet == TCL_OK) { + tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, (ClientData) &parentChannelFdOut_p); + if (tclGetChannelHandleRet == TCL_OK) { + parentChannelFdIn = PTR2INT(parentChannelFdIn_p); + parentChannelFdOut = PTR2INT(parentChannelFdOut_p); + if (parentChannelFdIn == parentChannelFdOut) { + parentChannelFd = parentChannelFdIn; + validParentChannelFd = 1; + } + } + } + } + + if (validParentChannelFd) { + dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn); + bio = BIO_new_socket(parentChannelFd, flags); + statePtr->flags |= TLS_TCL_FASTPATH; + return(bio); + } + + dprintf("Falling back to Tcl I/O for this channel"); +#endif + + bio = BIO_new(BioMethods); + BIO_set_data(bio, statePtr); + BIO_set_shutdown(bio, flags); + BIO_set_init(bio, 1); + + return(bio); +} + +static int BioWrite(BIO *bio, CONST char *buf, int bufLen) { + Tcl_Channel chan; + int ret; + int tclEofChan, tclErrno; + + chan = Tls_GetParent((State *) BIO_get_data(bio), 0); + + dprintf("[chan=%p] BioWrite(%p, , %d)", (void *)chan, (void *) bio, bufLen); + + ret = Tcl_WriteRaw(chan, buf, bufLen); + + tclEofChan = Tcl_Eof(chan); + tclErrno = Tcl_GetErrno(); + + dprintf("[chan=%p] BioWrite(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno()); + + BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY); + + if (tclEofChan && ret <= 0) { + dprintf("Got %i from Tcl_WriteRaw, and EOF is set; ret = -1", ret); + Tcl_SetErrno(ECONNRESET); + ret = -1; + } else if (ret == 0) { + dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0"); + dprintf("Setting retry read flag"); + BIO_set_retry_read(bio); + } else if (ret < 0) { + dprintf("We got some kind of I/O error"); + + if (tclErrno == EAGAIN) { + dprintf("It's EAGAIN"); + ret = 0; + } else { + dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno); + Tcl_SetErrno(ECONNRESET); + ret = -1; + } + } else { + dprintf("Successfully wrote some data"); + } + + if (ret != -1) { + if (BIO_should_read(bio)) { + dprintf("Setting should retry read flag"); + + BIO_set_retry_read(bio); + } + } + + return(ret); +} + +static int BioRead(BIO *bio, char *buf, int bufLen) { + Tcl_Channel chan; + int ret = 0; + int tclEofChan, tclErrno; + + chan = Tls_GetParent((State *) BIO_get_data(bio), 0); + + dprintf("[chan=%p] BioRead(%p, , %d)", (void *) chan, (void *) bio, bufLen); + + if (buf == NULL) { + return 0; + } + + ret = Tcl_ReadRaw(chan, buf, bufLen); + + tclEofChan = Tcl_Eof(chan); + tclErrno = Tcl_GetErrno(); + + dprintf("[chan=%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, tclErrno); + + BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY); + + if (tclEofChan && ret <= 0) { + dprintf("Got %i from Tcl_Read or Tcl_ReadRaw, and EOF is set; ret = -1", ret); + Tcl_SetErrno(ECONNRESET); + ret = -1; + } else if (ret == 0) { + dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0"); + dprintf("Setting retry read flag"); + BIO_set_retry_read(bio); + } else if (ret < 0) { + dprintf("We got some kind of I/O error"); + + if (tclErrno == EAGAIN) { + dprintf("It's EAGAIN"); + ret = 0; + } else { + dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno); + Tcl_SetErrno(ECONNRESET); + ret = -1; + } + } else { + dprintf("Successfully read some data"); + } + + if (ret != -1) { + if (BIO_should_write(bio)) { + dprintf("Setting should retry write flag"); + + BIO_set_retry_write(bio); + } + } + + dprintf("BioRead(%p, , %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret); + + return(ret); +} + +static int BioPuts(BIO *bio, CONST char *str) { + dprintf("BioPuts(%p, ) called", bio, str); + + return BioWrite(bio, str, (int) strlen(str)); +} + +static long BioCtrl(BIO *bio, int cmd, long num, void *ptr) { + Tcl_Channel chan; + long ret = 1; + + chan = Tls_GetParent((State *) BIO_get_data(bio), 0); + + dprintf("BioCtrl(%p, 0x%x, 0x%x, %p)", (void *) bio, (unsigned int) cmd, (unsigned int) num, (void *) ptr); + + switch (cmd) { + case BIO_CTRL_RESET: + dprintf("Got BIO_CTRL_RESET"); + num = 0; + case BIO_C_FILE_SEEK: + dprintf("Got BIO_C_FILE_SEEK"); + case BIO_C_FILE_TELL: + dprintf("Got BIO_C_FILE_TELL"); + ret = 0; + break; + case BIO_CTRL_INFO: + dprintf("Got BIO_CTRL_INFO"); + ret = 1; + break; + case BIO_C_SET_FD: + dprintf("Unsupported call: BIO_C_SET_FD"); + ret = -1; + break; + case BIO_C_GET_FD: + dprintf("Unsupported call: BIO_C_GET_FD"); + ret = -1; + break; + case BIO_CTRL_GET_CLOSE: + dprintf("Got BIO_CTRL_CLOSE"); + ret = BIO_get_shutdown(bio); + break; + case BIO_CTRL_SET_CLOSE: + dprintf("Got BIO_SET_CLOSE"); + BIO_set_shutdown(bio, num); + break; + case BIO_CTRL_EOF: + dprintf("Got BIO_CTRL_EOF"); + ret = Tcl_Eof(chan); + break; + case BIO_CTRL_PENDING: + dprintf("Got BIO_CTRL_PENDING"); + ret = ((chan) ? 1 : 0); + dprintf("BIO_CTRL_PENDING(%d)", (int) ret); + break; + case BIO_CTRL_WPENDING: + dprintf("Got BIO_CTRL_WPENDING"); + ret = 0; + break; + case BIO_CTRL_DUP: + dprintf("Got BIO_CTRL_DUP"); + break; + case BIO_CTRL_FLUSH: + dprintf("Got BIO_CTRL_FLUSH"); + ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1); + dprintf("BIO_CTRL_FLUSH returning value %li", ret); + break; + default: + dprintf("Got unknown control command (%i)", cmd); + ret = -2; + break; + } + + return(ret); +} + +static int BioNew(BIO *bio) { + dprintf("BioNew(%p) called", bio); + + BIO_set_init(bio, 0); + BIO_set_data(bio, NULL); + BIO_clear_flags(bio, -1); + + return(1); +} + +static int BioFree(BIO *bio) { + if (bio == NULL) { + return(0); + } + + dprintf("BioFree(%p) called", bio); + + if (BIO_get_shutdown(bio)) { + if (BIO_get_init(bio)) { + /*shutdown(bio->num, 2) */ + /*closesocket(bio->num) */ + } + + BIO_set_init(bio, 0); + BIO_clear_flags(bio, -1); + } + + return(1); } Index: tlsIO.c ================================================================== --- tlsIO.c +++ tlsIO.c @@ -20,70 +20,27 @@ #include "tlsInt.h" /* * Forward declarations */ - -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, - CONST char *buf, int toWrite, int *errorCodePtr)); -static int TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData, - Tcl_Interp *interp, CONST84 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. These are what the structures should look like, but we - * have to build them up at runtime to be correct depending on whether - * we are loaded into an 8.2.0-8.3.1 or 8.3.2+ Tcl interpreter. - */ -#ifdef TLS_STATIC_STRUCTURES_NOT_USED -static Tcl_ChannelType tlsChannelType2 = { - "tls", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2+) */ - 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. */ -}; - -static Tcl_ChannelType tlsChannelType1 = { - "tls", /* Type name. */ - TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ - 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. */ -}; -#else -static Tcl_ChannelType *tlsChannelType = NULL; +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, CONST char *buf, int toWrite, int *errorCodePtr)); +static int TlsGetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, CONST84 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)); +#if 0 +static void TlsChannelHandler _ANSI_ARGS_((ClientData clientData, int mask)); #endif +static void TlsChannelHandlerTimer _ANSI_ARGS_((ClientData clientData)); + +/* + * TLS Channel Type + */ +static Tcl_ChannelType *tlsChannelType = NULL; /* *------------------------------------------------------------------- * * Tls_ChannelType -- @@ -96,134 +53,69 @@ * Side effects: * None. * *------------------------------------------------------------------- */ -Tcl_ChannelType *Tls_ChannelType() -{ - /* - * Initialize the channel type if necessary - */ - if (tlsChannelType == NULL) { - /* - * Allocation of a new channeltype structure is not easy, because of - * the various verson of the core and subsequent changes to the - * structure. The main challenge is to allocate enough memory for - * odern versions even if this extyension is compiled against one - * of the older variant! - * - * (1) Versions before stubs (8.0.x) are simple, because they are - * supported only if the extension is compiled against exactly - * that version of the core. - * - * (2) With stubs we just determine the difference between the older - * and modern variant and overallocate accordingly if compiled - * against an older variant. - */ - - unsigned int size = sizeof(Tcl_ChannelType); /* Base size */ - - /* - * Size of a procedure pointer. We assume that all procedure - * pointers are of the same size, regardless of exact type - * (arguments and return values). - * - * 8.2. First version containing close2proc. Baseline. - * 8.3.2 Three additional vectors. Moved blockMode, new flush- and - * handlerProc's. - * - * => Compilation against earlier version has to overallocate three - * procedure pointers. - */ - -#ifdef EMULATE_CHANNEL_VERSION_2 - size += 3 * procPtrSize; -#endif - - tlsChannelType = (Tcl_ChannelType *) ckalloc(size); - memset((VOID *) tlsChannelType, 0, size); - - /* - * Common elements of the structure (no changes in location or name) - * close2Proc, seekProc, setOptionProc stay NULL. - */ - - tlsChannelType->typeName = "tls"; - tlsChannelType->closeProc = TlsCloseProc; - tlsChannelType->inputProc = TlsInputProc; - tlsChannelType->outputProc = TlsOutputProc; - tlsChannelType->getOptionProc = TlsGetOptionProc; - tlsChannelType->watchProc = TlsWatchProc; - tlsChannelType->getHandleProc = TlsGetHandleProc; - - /* - * blockModeProc is a twister. We have to make some runtime-choices, - * depending on the version we compiled against. - */ - -#ifdef EMULATE_CHANNEL_VERSION_2 - /* - * We are compiling against an 8.3.1- core. We have to create some - * definitions for the new elements as the compiler does not know them - * by name. - */ - - if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { - /* - * The 'version' element of 8.3.2 is in the the place of the - * blockModeProc. For 8.2.0-8.3.1 we have to set our blockModeProc - * into this place. - */ - tlsChannelType->blockModeProc = TlsBlockModeProc; - } else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ { - /* - * For the 8.3.2 core we present ourselves as a version 2 - * driver. This means a special value in version (ex - * blockModeProc), blockModeProc in a different place and of - * course usage of the handlerProc. The last two have to - * referenced with pointer magic because they aren't defined - * otherwise. - */ - - tlsChannelType->blockModeProc = - (Tcl_DriverBlockModeProc*) TLS_CHANNEL_VERSION_2; - (*((Tcl_DriverBlockModeProc**)(&(tlsChannelType->close2Proc)+1))) - = TlsBlockModeProc; - (*((TlsDriverHandlerProc**)(&(tlsChannelType->close2Proc)+3))) - = TlsNotifyProc; - } -#else - /* - * Compiled against 8.3.2+. Direct access to all elements possible. Use - * channelTypeVersion information to select the values to use. - */ - - if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { - /* - * The 'version' element of 8.3.2 is in the the place of the - * blockModeProc. For the original patch in 8.1.x and the firstly - * included (8.2) we have to set our blockModeProc into this - * place. - */ - tlsChannelType->version = (Tcl_ChannelTypeVersion)TlsBlockModeProc; - } else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ { - /* - * For the 8.3.2 core we present ourselves as a version 2 - * driver. This means a special value in version (ex - * blockModeProc), blockModeProc in a different place and of - * course usage of the handlerProc. - */ - - tlsChannelType->version = TCL_CHANNEL_VERSION_2; - tlsChannelType->blockModeProc = TlsBlockModeProc; - tlsChannelType->handlerProc = TlsNotifyProc; - } -#endif - } - return tlsChannelType; -} - +Tcl_ChannelType *Tls_ChannelType(void) { + unsigned int size; + + /* + * Initialize the channel type if necessary + */ + if (tlsChannelType == NULL) { + /* + * Allocation of a new channeltype structure is not easy, because of + * the various verson of the core and subsequent changes to the + * structure. The main challenge is to allocate enough memory for + * modern versions even if this extsension is compiled against one + * of the older variant! + * + * (1) Versions before stubs (8.0.x) are simple, because they are + * supported only if the extension is compiled against exactly + * that version of the core. + * + * (2) With stubs we just determine the difference between the older + * and modern variant and overallocate accordingly if compiled + * against an older variant. + */ + size = sizeof(Tcl_ChannelType); /* Base size */ + + tlsChannelType = (Tcl_ChannelType *) ckalloc(size); + memset((VOID *) tlsChannelType, 0, size); + + /* + * Common elements of the structure (no changes in location or name) + * close2Proc, seekProc, setOptionProc stay NULL. + */ + + tlsChannelType->typeName = "tls"; + tlsChannelType->closeProc = TlsCloseProc; + tlsChannelType->inputProc = TlsInputProc; + tlsChannelType->outputProc = TlsOutputProc; + tlsChannelType->getOptionProc = TlsGetOptionProc; + tlsChannelType->watchProc = TlsWatchProc; + tlsChannelType->getHandleProc = TlsGetHandleProc; + + /* + * Compiled against 8.3.2+. Direct access to all elements possible. Use + * channelTypeVersion information to select the values to use. + */ + + /* + * For the 8.3.2 core we present ourselves as a version 2 + * driver. This means a special value in version (ex + * blockModeProc), blockModeProc in a different place and of + * course usage of the handlerProc. + */ + tlsChannelType->version = TCL_CHANNEL_VERSION_2; + tlsChannelType->blockModeProc = TlsBlockModeProc; + tlsChannelType->handlerProc = TlsNotifyProc; + } + + return(tlsChannelType); +} + /* *------------------------------------------------------------------- * * TlsBlockModeProc -- * @@ -235,32 +127,22 @@ * Side effects: * Sets the device into blocking or nonblocking mode. * *------------------------------------------------------------------- */ - -static int -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; - - if (mode == TCL_MODE_NONBLOCKING) { - statePtr->flags |= TLS_TCL_ASYNC; - } else { - statePtr->flags &= ~(TLS_TCL_ASYNC); - } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - return 0; - } else { - return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr), - "-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1"); - } -} - +static int TlsBlockModeProc(ClientData instanceData, int mode) { + State *statePtr = (State *) instanceData; + + if (mode == TCL_MODE_NONBLOCKING) { + statePtr->flags |= TLS_TCL_ASYNC; + } else { + statePtr->flags &= ~(TLS_TCL_ASYNC); + } + + return(0); +} + /* *------------------------------------------------------------------- * * TlsCloseProc -- * @@ -276,33 +158,26 @@ * Side effects: * Closes the socket of the channel. * *------------------------------------------------------------------- */ -static int -TlsCloseProc(ClientData instanceData, /* The socket to close. */ - Tcl_Interp *interp) /* For error reporting - unused. */ -{ - State *statePtr = (State *) instanceData; - - dprintf("TlsCloseProc(%p)", (void *) statePtr); - - if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { - /* - * Remove event handler to underlying channel, this could - * be because we are closing for real, or being "unstacked". - */ - - Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - TlsChannelHandler, (ClientData) statePtr); - } - - Tls_Clean(statePtr); - Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); - return TCL_OK; -} - +static int TlsCloseProc(ClientData instanceData, Tcl_Interp *interp) { + State *statePtr = (State *) instanceData; + + dprintf("TlsCloseProc(%p)", (void *) statePtr); + + Tls_Clean(statePtr); + Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); + + dprintf("Returning TCL_OK"); + + return(TCL_OK); + + /* Interp is unused. */ + interp = interp; +} + /* *------------------------------------------------------------------- * * TlsInputProc -- * @@ -318,88 +193,86 @@ * Reads input from the input device of the channel. * *------------------------------------------------------------------- */ -static int -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; - - dprintf("BIO_read(%d)", bufSize); - - if (statePtr->flags & TLS_TCL_CALLBACK) { - /* don't process any bytes while verify callback is running */ - dprintf("Callback is running, reading 0 bytes"); - - bytesRead = 0; - goto input; - } - - if (!SSL_is_init_finished(statePtr->ssl)) { - bytesRead = Tls_WaitForConnect(statePtr, errorCodePtr); - if (bytesRead <= 0) { - dprintf("Got an error (bytesRead = %i)", bytesRead); - - if (*errorCodePtr == ECONNRESET) { - dprintf("Got connection reset"); - /* Soft EOF */ - *errorCodePtr = 0; - bytesRead = 0; - } - goto input; - } - } - - 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("BIO_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; - } else if (BIO_should_retry(statePtr->bio)) { - dprintf("RE! "); - *errorCodePtr = EAGAIN; - } else { - *errorCodePtr = Tcl_GetErrno(); - if (*errorCodePtr == ECONNRESET) { - /* Soft EOF */ - *errorCodePtr = 0; - bytesRead = 0; - } - } - } - input: - dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr); - return bytesRead; -} - +static int TlsInputProc(ClientData instanceData, char *buf, int bufSize, int *errorCodePtr) { + State *statePtr = (State *) instanceData; + int bytesRead; + int tlsConnect; + int err; + + *errorCodePtr = 0; + + dprintf("BIO_read(%d)", bufSize); + + if (statePtr->flags & TLS_TCL_CALLBACK) { + /* don't process any bytes while verify callback is running */ + dprintf("Callback is running, reading 0 bytes"); + return(0); + } + + dprintf("Calling Tls_WaitForConnect"); + tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr); + if (tlsConnect < 0) { + dprintf("Got an error (bytesRead = %i)", bytesRead); + + if (*errorCodePtr == ECONNRESET) { + dprintf("Got connection reset"); + /* Soft EOF */ + *errorCodePtr = 0; + bytesRead = 0; + } + + return(0); + } + + 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("BIO_read -> %d", bytesRead); + + err = SSL_get_error(statePtr->ssl, bytesRead); + + if (BIO_should_retry(statePtr->bio)) { + dprintf("I/O failed, will retry based on EAGAIN"); + *errorCodePtr = EAGAIN; + } + + switch (err) { + case SSL_ERROR_NONE: + dprintBuffer(buf, bytesRead); + break; + case SSL_ERROR_SSL: + Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, bytesRead)); + *errorCodePtr = ECONNABORTED; + break; + case SSL_ERROR_SYSCALL: + dprintf("I/O error reading, treating it as EOF"); + *errorCodePtr = 0; + bytesRead = 0; + break; + } + + dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr); + return(bytesRead); +} + /* *------------------------------------------------------------------- * * TlsOutputProc -- * @@ -414,47 +287,51 @@ * Writes output on the output device of the channel. * *------------------------------------------------------------------- */ -static int -TlsOutputProc(ClientData instanceData, /* Socket state. */ - CONST 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("BIO_write(%p, %d)", (void *) statePtr, toWrite); - - if (statePtr->flags & TLS_TCL_CALLBACK) { - /* don't process any bytes while verify callback is running */ - written = -1; - *errorCodePtr = EAGAIN; - goto output; - } - - if (!SSL_is_init_finished(statePtr->ssl)) { +static int TlsOutputProc(ClientData instanceData, CONST char *buf, int toWrite, int *errorCodePtr) { + State *statePtr = (State *) instanceData; + int written, err; + + *errorCodePtr = 0; + + dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite); + dprintBuffer(buf, toWrite); + + if (statePtr->flags & TLS_TCL_CALLBACK) { + dprintf("Don't process output while callbacks are running") + written = -1; + *errorCodePtr = EAGAIN; + return(-1); + } + + dprintf("Calling Tls_WaitForConnect"); written = Tls_WaitForConnect(statePtr, errorCodePtr); - if (written <= 0) { - dprintf("Tls_WaitForConnect returned %i (err = %i)", written, *errorCodePtr); - - goto output; - } - } - if (statePtr->flags & TLS_TCL_INIT) { - statePtr->flags &= ~(TLS_TCL_INIT); - } - if (toWrite == 0) { - dprintf("zero-write"); - BIO_flush(statePtr->bio); - written = 0; - goto output; - } else { + if (written < 0) { + dprintf("Tls_WaitForConnect returned %i (err = %i)", written, *errorCodePtr); + + return(-1); + } + + if (toWrite == 0) { + dprintf("zero-write"); + err = BIO_flush(statePtr->bio); + + if (err <= 0) { + dprintf("Flushing failed"); + + *errorCodePtr = EIO; + written = 0; + return(-1); + } + + written = 0; + *errorCodePtr = 0; + return(0); + } + /* * 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. @@ -464,54 +341,51 @@ * 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("BIO_write(%p, %d) -> [%d]", - (void *) statePtr, toWrite, written); - } - if (written <= 0) { - switch ((err = SSL_get_error(statePtr->ssl, written))) { - case SSL_ERROR_NONE: - if (written < 0) { - written = 0; - } - break; - case SSL_ERROR_WANT_WRITE: - dprintf(" write W BLOCK"); - break; - case SSL_ERROR_WANT_READ: - dprintf(" write R BLOCK"); - break; - case SSL_ERROR_WANT_X509_LOOKUP: - dprintf(" write X BLOCK"); - break; - case SSL_ERROR_ZERO_RETURN: - dprintf(" closed"); - written = 0; - break; - case SSL_ERROR_SYSCALL: - *errorCodePtr = Tcl_GetErrno(); - dprintf(" [%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(" unknown err: %d", err); - break; - } - } - output: - dprintf("Output(%d) -> %d", toWrite, written); - return written; -} - + dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written); + + err = SSL_get_error(statePtr->ssl, written); + switch (err) { + case SSL_ERROR_NONE: + if (written < 0) { + written = 0; + } + break; + case SSL_ERROR_WANT_WRITE: + dprintf(" write W BLOCK"); + break; + case SSL_ERROR_WANT_READ: + dprintf(" write R BLOCK"); + break; + case SSL_ERROR_WANT_X509_LOOKUP: + dprintf(" write X BLOCK"); + break; + case SSL_ERROR_ZERO_RETURN: + dprintf(" closed"); + written = 0; + break; + case SSL_ERROR_SYSCALL: + *errorCodePtr = Tcl_GetErrno(); + dprintf(" [%d] syscall errr: %d", written, *errorCodePtr); + written = -1; + break; + case SSL_ERROR_SSL: + Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written)); + *errorCodePtr = ECONNABORTED; + written = -1; + break; + default: + dprintf(" unknown err: %d", err); + break; + } + + dprintf("Output(%d) -> %d", toWrite, written); + return(written); +} + /* *------------------------------------------------------------------- * * TlsGetOptionProc -- * @@ -538,50 +412,28 @@ Tcl_DString *dsPtr) /* Where to store the computed value * initialized by caller. */ { State *statePtr = (State *) instanceData; - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - 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 { -#if 0 - size_t len = 0; - - if (optionName != (char *) NULL) { - len = strlen(optionName); - } - if ((len == 0) || ((len > 1) && (optionName[1] == 'c') && - (strncmp(optionName, "-cipher", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-cipher"); - } - Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl)); - if (len) { - return TCL_OK; - } - } -#endif - return TCL_OK; - } -} - + Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + 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; +} + /* *------------------------------------------------------------------- * * TlsWatchProc -- * @@ -601,20 +453,36 @@ TlsWatchProc(ClientData instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed * combination of TCL_READABLE, * TCL_WRITABLE and TCL_EXCEPTION. */ { + Tcl_Channel downChan; State *statePtr = (State *) instanceData; dprintf("TlsWatchProc(0x%x)", mask); /* Pretend to be dead as long as the verify callback is running. * Otherwise that callback could be invoked recursively. */ - if (statePtr->flags & TLS_TCL_CALLBACK) { return; } + if (statePtr->flags & TLS_TCL_CALLBACK) { + dprintf("Callback is on-going, doing nothing"); + return; + } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - Tcl_Channel downChan; + dprintFlags(statePtr); + + downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + + if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { + dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here"); + + dprintf("Unregistering interest in the lower channel"); + (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), 0); + + statePtr->watchMask = 0; + + return; + } statePtr->watchMask = mask; /* No channel handlers any more. We will be notified automatically * about events on the channel below via a call to our @@ -622,57 +490,36 @@ * 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); + dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan); (Tcl_GetChannelType(downChan)) ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); /* * Management of the internal timer. */ if (statePtr->timer != (Tcl_TimerToken) NULL) { + dprintf("A timer was found, deleting it"); 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. */ + dprintf("Creating a new timer since data appears to be waiting"); statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); } - } else { - if (mask == statePtr->watchMask) - return; - - if (statePtr->watchMask) { - /* - * Remove event handler to underlying channel, this could - * be because we are closing for real, or being "unstacked". - */ - - Tcl_DeleteChannelHandler(Tls_GetParent(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, TlsChannelHandler, - (ClientData) statePtr); - } - } -} - +} + /* *------------------------------------------------------------------- * * TlsGetHandleProc -- * @@ -685,20 +532,16 @@ * Side effects: * None. * *------------------------------------------------------------------- */ -static int -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); -} - +static int TlsGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr) { + State *statePtr = (State *) instanceData; + + return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr)); +} + /* *------------------------------------------------------------------- * * TlsNotifyProc -- * @@ -712,52 +555,54 @@ * 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; - } - - if (statePtr->flags & TLS_TCL_CALLBACK) { - return 0; - } - - if (statePtr->flags & TLS_TCL_INIT - && !SSL_is_init_finished(statePtr->ssl)) { - int errorCode = 0; - if (Tls_WaitForConnect(statePtr, &errorCode) <= 0 && errorCode == EAGAIN) { - dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN"); - return 0; - } - } - - return mask; -} - +static int TlsNotifyProc(ClientData instanceData, int mask) { + State *statePtr = (State *) instanceData; + int errorCode; + + /* + * 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; + } + + if (statePtr->flags & TLS_TCL_CALLBACK) { + dprintf("Returning 0 due to callback"); + return 0; + } + + dprintf("Calling Tls_WaitForConnect"); + errorCode = 0; + if (Tls_WaitForConnect(statePtr, &errorCode) < 0) { + if (errorCode == EAGAIN) { + dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0"); + + return 0; + } + + dprintf("Tls_WaitForConnect returned an error"); + } + + dprintf("Returning %i", mask); + + return(mask); +} + +#if 0 /* *------------------------------------------------------* * * TlsChannelHandler -- * @@ -833,11 +678,12 @@ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); } Tcl_Release( (ClientData)statePtr); } - +#endif + /* *------------------------------------------------------* * * TlsChannelHandlerTimer -- * @@ -853,28 +699,38 @@ * None. * *------------------------------------------------------* */ -static void -TlsChannelHandlerTimer (clientData) -ClientData clientData; /* Transformation to query */ -{ - State *statePtr = (State *) clientData; - int mask = 0; - - statePtr->timer = (Tcl_TimerToken) NULL; - - if (BIO_wpending(statePtr->bio)) { - mask |= TCL_WRITABLE; - } - if (BIO_pending(statePtr->bio)) { - mask |= TCL_READABLE; - } - Tcl_NotifyChannel(statePtr->self, mask); -} - +static void TlsChannelHandlerTimer(ClientData clientData) { + State *statePtr = (State *) clientData; + int mask = 0; + + dprintf("Called"); + + statePtr->timer = (Tcl_TimerToken) NULL; + + if (BIO_wpending(statePtr->bio)) { + dprintf("[chan=%p] BIO writable", statePtr->self); + + mask |= TCL_WRITABLE; + } + + if (BIO_pending(statePtr->bio)) { + dprintf("[chan=%p] BIO readable", statePtr->self); + + mask |= TCL_READABLE; + } + + dprintf("Notifying ourselves"); + Tcl_NotifyChannel(statePtr->self, mask); + + dprintf("Returning"); + + return; +} + /* *------------------------------------------------------* * * Tls_WaitForConnect -- * @@ -884,144 +740,167 @@ * Result: * None. * *------------------------------------------------------* */ -int -Tls_WaitForConnect( statePtr, errorCodePtr) - State *statePtr; - int *errorCodePtr; /* Where to store error code. */ -{ - int err; - - dprintf("WaitForConnect(%p)", (void *) statePtr); - - if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { - /* - * We choose ECONNRESET over ECONNABORTED here because some server - * side code, on the wiki for example, sets up a read handler that - * does a read and if eof closes the channel. There is no catch/try - * around the reads so exceptions will result in potentially many - * dangling channels hanging around that should have been closed. - * (Backgroun: ECONNABORTED maps to a Tcl exception and - * ECONNRESET maps to graceful EOF). - */ - *errorCodePtr = ECONNRESET; - return -1; - } - - for (;;) { - /* Not initialized yet! */ - if (statePtr->flags & TLS_TCL_SERVER) { - dprintf("Calling SSL_accept()"); - err = SSL_accept(statePtr->ssl); - } else { - dprintf("Calling SSL_connect()"); - err = SSL_connect(statePtr->ssl); - } - - /*SSL_write(statePtr->ssl, (char*)&err, 0); HACK!!! */ - if (err > 0) { - dprintf("That seems to have gone okay"); - BIO_flush(statePtr->bio); - } else { - int rc = SSL_get_error(statePtr->ssl, err); - - dprintf("Got error: %i (rc = %i)", err, rc); - - if (rc == SSL_ERROR_SSL) { - Tls_Error(statePtr, - (char *)ERR_reason_error_string(ERR_get_error())); - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; - *errorCodePtr = ECONNABORTED; - return -1; - } else if (BIO_should_retry(statePtr->bio)) { - if (statePtr->flags & TLS_TCL_ASYNC) { - dprintf("E! "); - *errorCodePtr = EAGAIN; - return -1; - } else { - continue; - } - } else if (err == 0) { - if (SSL_in_init(statePtr->ssl)) { - dprintf("SSL_in_init() is true"); - } - - if (Tcl_Eof(statePtr->self)) { - dprintf("Error = 0 and EOF is set"); - - if (rc != SSL_ERROR_SYSCALL) { - dprintf("Error from some reason other than our BIO, returning 0"); - return 0; - } - } - dprintf("CR! "); - *errorCodePtr = ECONNRESET; - return -1; - } - if (statePtr->flags & TLS_TCL_SERVER) { +int Tls_WaitForConnect(State *statePtr, int *errorCodePtr) { + unsigned long backingError; + int err, rc; + int bioShouldRetry; + + dprintf("WaitForConnect(%p)", (void *) statePtr); + dprintFlags(statePtr); + + if (!(statePtr->flags & TLS_TCL_INIT)) { + dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success"); + *errorCodePtr = 0; + return(0); + } + + if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { + /* + * We choose ECONNRESET over ECONNABORTED here because some server + * side code, on the wiki for example, sets up a read handler that + * does a read and if eof closes the channel. There is no catch/try + * around the reads so exceptions will result in potentially many + * dangling channels hanging around that should have been closed. + * (Backgroun: ECONNABORTED maps to a Tcl exception and + * ECONNRESET maps to graceful EOF). + */ + *errorCodePtr = ECONNRESET; + return(-1); + } + + for (;;) { + /* Not initialized yet! */ + if (statePtr->flags & TLS_TCL_SERVER) { + dprintf("Calling SSL_accept()"); + + err = SSL_accept(statePtr->ssl); + } else { + dprintf("Calling SSL_connect()"); + + err = SSL_connect(statePtr->ssl); + } + + if (err > 0) { + dprintf("That seems to have gone okay"); + + err = BIO_flush(statePtr->bio); + + if (err <= 0) { + dprintf("Flushing the lower layers failed, this will probably terminate this session"); + } + } + + rc = SSL_get_error(statePtr->ssl, err); + + dprintf("Got error: %i (rc = %i)", err, rc); + + bioShouldRetry = 0; + if (err <= 0) { + if (rc == SSL_ERROR_WANT_CONNECT || rc == SSL_ERROR_WANT_ACCEPT || rc == SSL_ERROR_WANT_READ || rc == SSL_ERROR_WANT_WRITE) { + bioShouldRetry = 1; + } else if (BIO_should_retry(statePtr->bio)) { + bioShouldRetry = 1; + } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) { + bioShouldRetry = 1; + } + } else { + if (!SSL_is_init_finished(statePtr->ssl)) { + bioShouldRetry = 1; + } + } + + if (bioShouldRetry) { + dprintf("The I/O did not complete -- but we should try it again"); + + if (statePtr->flags & TLS_TCL_ASYNC) { + dprintf("Returning EAGAIN so that it can be retried later"); + + *errorCodePtr = EAGAIN; + + return(-1); + } else { + dprintf("Doing so now"); + + continue; + } + } + + dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though"); + break; + } + + + *errorCodePtr = EINVAL; + + switch (rc) { + case SSL_ERROR_NONE: + /* The connection is up, we are done here */ + dprintf("The connection is up"); + break; + case SSL_ERROR_ZERO_RETURN: + dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...") + return(-1); + case SSL_ERROR_SYSCALL: + backingError = ERR_get_error(); + dprintf("I/O error occured"); + + if (backingError == 0 && err == 0) { + dprintf("EOF reached") + } + + statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + *errorCodePtr = ECONNRESET; + return(-1); + case SSL_ERROR_SSL: + dprintf("Got permanent fatal SSL error, aborting immediately"); + Tls_Error(statePtr, (char *)ERR_reason_error_string(ERR_get_error())); + statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + *errorCodePtr = ECONNABORTED; + return(-1); + case SSL_ERROR_WANT_CONNECT: + case SSL_ERROR_WANT_ACCEPT: + case SSL_ERROR_WANT_X509_LOOKUP: + default: + dprintf("We got a confusing reply: %i", rc); + *errorCodePtr = Tcl_GetErrno(); + dprintf("ERR(%d, %d) ", rc, *errorCodePtr); + return(-1); + } + +#if 0 + if (statePtr->flags & TLS_TCL_SERVER) { + dprintf("This is an TLS server, checking the certificate for the peer"); + err = SSL_get_verify_result(statePtr->ssl); if (err != X509_V_OK) { - Tls_Error(statePtr, - (char *)X509_verify_cert_error_string(err)); - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; - *errorCodePtr = ECONNABORTED; - return -1; - } - } - *errorCodePtr = Tcl_GetErrno(); - dprintf("ERR(%d, %d) ", rc, *errorCodePtr); - return -1; - } - dprintf("R0! "); - return 1; - } -} - -Tcl_Channel -Tls_GetParent( statePtr ) - State *statePtr; -{ - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - return Tcl_GetStackedChannel(statePtr->self); - } else { - /* The reason for the existence of this procedure is - * the fact that stacking a transform over another - * transform will leave our internal pointer unchanged, - * and thus pointing to the new transform, and not the - * Channel structure containing the saved state of this - * transform. This is the price to pay for leaving - * Tcl_Channel references intact. The only other solution - * is an extension of Tcl_ChannelType with another driver - * procedure to notify a Channel about the (un)stacking. - * - * It walks the chain of Channel structures until it - * finds the one pointing having 'ctrl' as instanceData - * and then returns the superceding channel to that. (AK) - */ - - Tcl_Channel self = statePtr->self; - Tcl_Channel next; - - while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { - next = Tcl_GetStackedChannel (self); - if (next == (Tcl_Channel) NULL) { - /* 09/24/1999 Unstacking bug, - * found by Matt Newman . - * - * We were unable to find the channel structure for this - * transformation in the chain of stacked channel. This - * means that we are currently in the process of unstacking - * it *and* there were some bytes waiting which are now - * flushed. In this situation the pointer to the channel - * itself already refers to the parent channel we have to - * write the bytes into, so we return that. - */ - return statePtr->self; - } - self = next; - } - - return Tcl_GetStackedChannel (self); - } + dprintf("Invalid certificate, returning in failure"); + + Tls_Error(statePtr, (char *)X509_verify_cert_error_string(err)); + statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + *errorCodePtr = ECONNABORTED; + return(-1); + } + } +#endif + + dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake"); + statePtr->flags &= ~TLS_TCL_INIT; + + dprintf("Returning in success"); + *errorCodePtr = 0; + + return(0); +} + +Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) { + dprintf("Requested to get parent of channel %p", statePtr->self); + + if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) { + dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL"); + return(NULL); + } + + return(Tcl_GetStackedChannel(statePtr->self)); } Index: tlsInt.h ================================================================== --- tlsInt.h +++ tlsInt.h @@ -19,10 +19,11 @@ #define _TLSINT_H #include "tls.h" #include #include +#include #ifdef __WIN32__ #define WIN32_LEAN_AND_MEAN #include #include /* OpenSSL needs this on Windows */ @@ -42,56 +43,73 @@ # ifndef NO_SSL2 # define NO_SSL2 # endif #endif -#ifdef BSAFE -#include -#include -#include -#else #include #include #include -#endif - -#ifndef NO_TLS1_1 -# ifndef SSL_OP_NO_TLSv1_1 -# define NO_TLS1_1 -# endif -#endif - -#ifndef NO_TLS1_2 -# ifndef SSL_OP_NO_TLSv1_2 -# define NO_TLS1_2 -# endif -#endif - -#ifdef TCL_STORAGE_CLASS -# undef TCL_STORAGE_CLASS -#endif -#ifdef BUILD_tls -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# define TCL_STORAGE_CLASS DLLIMPORT -#endif - +#include + +/* + * Determine if we should use the pre-OpenSSL 1.1.0 API + */ +#undef TCLTLS_OPENSSL_PRE_1_1 +#if (defined(LIBRESSL_VERSION_NUMBER)) || OPENSSL_VERSION_NUMBER < 0x10100000L +# define TCLTLS_OPENSSL_PRE_1_1_API 1 +#endif + #ifndef ECONNABORTED #define ECONNABORTED 130 /* Software caused connection abort */ #endif #ifndef ECONNRESET #define ECONNRESET 131 /* Connection reset by peer */ #endif #ifdef TCLEXT_TCLTLS_DEBUG -#define dprintf(...) { fprintf(stderr, "%s:%i:", __func__, __LINE__); fprintf(stderr, __VA_ARGS__); fprintf(stderr, "\n"); } +#include +#define dprintf(...) { \ + char dprintfBuffer[8192], *dprintfBuffer_p; \ + dprintfBuffer_p = &dprintfBuffer[0]; \ + dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \ + dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \ + fprintf(stderr, "%s\n", dprintfBuffer); \ + } +#define dprintBuffer(bufferName, bufferLength) { \ + int dprintBufferIdx; \ + unsigned char dprintBufferChar; \ + fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \ + for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \ + dprintBufferChar = bufferName[dprintBufferIdx]; \ + if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \ + fprintf(stderr, "'%c' ", dprintBufferChar); \ + } else { \ + fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \ + }; \ + }; \ + fprintf(stderr, "}\n"); \ + } +#define dprintFlags(statePtr) { \ + char dprintfBuffer[8192], *dprintfBuffer_p; \ + dprintfBuffer_p = &dprintfBuffer[0]; \ + dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \ + if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \ + if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \ + if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \ + if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \ + if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \ + if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \ + if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \ + fprintf(stderr, "%s\n", dprintfBuffer); \ + } #else #define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); } +#define dprintBuffer(bufferName, bufferLength) /**/ +#define dprintFlags(statePtr) /**/ #endif -#define SSL_ERROR(ssl,err) \ - ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err)))) +#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err)))) /* * OpenSSL BIO Routines */ #define BIO_TYPE_TCL (19|0x0400) @@ -105,161 +123,58 @@ #define TLS_TCL_CALLBACK (1<<4) /* In a callback, prevent update * looping problem. [Bug 1652380] */ #define TLS_TCL_HANDSHAKE_FAILED (1<<5) /* Set on handshake failures and once * set, all further I/O will result * in ECONNABORTED errors. */ - +#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */ #define TLS_TCL_DELAY (5) /* * This structure describes the per-instance state * of an ssl channel. * * The SSL processing context is maintained here, in the ClientData */ typedef struct State { - Tcl_Channel self; /* this socket channel */ - Tcl_TimerToken timer; - - int flags; /* see State.flags above */ - int watchMask; /* current WatchProc mask */ - int mode; /* current mode of parent channel */ - - Tcl_Interp *interp; /* interpreter in which this resides */ - Tcl_Obj *callback; /* script called for tracing, verifying and errors */ - Tcl_Obj *password; /* script called for certificate password */ - - int vflags; /* verify flags */ - SSL *ssl; /* Struct for SSL processing */ - SSL_CTX *ctx; /* SSL Context */ - BIO *bio; /* Struct for SSL processing */ - BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */ - - char *err; -} State; - -/* - * The following definitions have to be usable for 8.2.0-8.3.1 and 8.3.2+. - * The differences between these versions: - * - * 8.0-8.1: There is no support for these in TLS 1.4 (get 1.3). This - * was the version with the original patch. - * - * 8.2.0- Changed semantics for Tcl_StackChannel (Tcl_ReplaceChannel). - * 8.3.1: Check at runtime to switch the behaviour. The patch is part - * of the core from now on. - * - * 8.3.2+: Stacked channels rewritten for better behaviour in some - * situations (closing). Some new API's, semantic changes. - * - * The following magic was adapted from Trf 2.1 (Kupries). - */ - -#define TLS_CHANNEL_VERSION_1 0x1 -#define TLS_CHANNEL_VERSION_2 0x2 -extern int channelTypeVersion; + Tcl_Channel self; /* this socket channel */ + Tcl_TimerToken timer; + + int flags; /* see State.flags above */ + int watchMask; /* current WatchProc mask */ + int mode; /* current mode of parent channel */ + + Tcl_Interp *interp; /* interpreter in which this resides */ + Tcl_Obj *callback; /* script called for tracing, verifying and errors */ + Tcl_Obj *password; /* script called for certificate password */ + + int vflags; /* verify flags */ + SSL *ssl; /* Struct for SSL processing */ + SSL_CTX *ctx; /* SSL Context */ + BIO *bio; /* Struct for SSL processing */ + BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */ + + char *err; +} State; #ifdef USE_TCL_STUBS #ifndef Tcl_StackChannel -/* - * The core we are compiling against is not patched, so supply the - * necesssary definitions here by ourselves. The form chosen for - * the procedure macros (reservedXXX) will notify us if the core - * does not have these reserved locations anymore. - * - * !! Synchronize the procedure indices in their definitions with - * the patch to tcl.decls, as they have to be the same. - */ - -/* 281 */ -typedef Tcl_Channel (tls_StackChannel) _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_ChannelType* typePtr, - ClientData instanceData, - int mask, - Tcl_Channel prevChan)); -/* 282 */ -typedef void (tls_UnstackChannel) _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Channel chan)); - -#define Tcl_StackChannel ((tls_StackChannel*) tclStubsPtr->reserved281) -#define Tcl_UnstackChannel ((tls_UnstackChannel*) tclStubsPtr->reserved282) - -#endif /* Tcl_StackChannel */ - -#ifndef Tcl_GetStackedChannel -/* - * Separate definition, available in 8.2, but not 8.1 and before ! - */ - -/* 283 */ -typedef Tcl_Channel (tls_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); - -#define Tcl_GetStackedChannel ((tls_GetStackedChannel*) tclStubsPtr->reserved283) - +#error "Unable to compile on this version of Tcl" #endif /* Tcl_GetStackedChannel */ - - -#ifndef TCL_CHANNEL_VERSION_2 -/* - * Core is older than 8.3.2. Supply the missing definitions for - * the new API's in 8.3.2. - */ -#define EMULATE_CHANNEL_VERSION_2 - -typedef struct TlsChannelTypeVersion_* TlsChannelTypeVersion; -#define TCL_CHANNEL_VERSION_2 ((TlsChannelTypeVersion) 0x2) - -typedef int (TlsDriverHandlerProc) _ANSI_ARGS_((ClientData instanceData, - int interestMask)); -/* 394 */ -typedef int (tls_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char *dst, - int bytesToRead)); -/* 395 */ -typedef int (tls_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, char *src, - int srcLen)); -/* 397 */ -typedef int (tls_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); - -/* - * Generating code for accessing these parts of the stub table when - * compiling against a core older than 8.3.2 is a hassle because even - * the 'reservedXXX' fields of the structure are not defined yet. So - * we have to write up some macros hiding some very hackish pointer - * arithmetics to get at these fields. We assume that pointer to - * functions are always of the same size. - */ - -#define STUB_BASE ((char*)(&(tclStubsPtr->tcl_UtfNcasecmp))) /* field 370 */ -#define procPtrSize (sizeof (Tcl_DriverBlockModeProc *)) -#define IDX(n) (((n)-370) * procPtrSize) -#define SLOT(n) (STUB_BASE + IDX(n)) - -#define Tcl_ReadRaw (*((tls_ReadRaw**) (SLOT(394)))) -#define Tcl_WriteRaw (*((tls_WriteRaw**) (SLOT(395)))) -#define Tcl_GetTopChannel (*((tls_GetTopChannel**)(SLOT(396)))) - -/* - * Required, easy emulation. - */ -#define Tcl_ChannelGetOptionProc(chanDriver) ((chanDriver)->getOptionProc) - -#endif /* TCL_CHANNEL_VERSION_2 */ - #endif /* USE_TCL_STUBS */ /* * Forward declarations */ - -Tcl_ChannelType *Tls_ChannelType _ANSI_ARGS_((void)); -Tcl_Channel Tls_GetParent _ANSI_ARGS_((State *statePtr)); - -Tcl_Obj* Tls_NewX509Obj _ANSI_ARGS_ (( Tcl_Interp *interp, X509 *cert)); -void Tls_Error _ANSI_ARGS_ ((State *statePtr, char *msg)); -void Tls_Free _ANSI_ARGS_ ((char *blockPtr)); -void Tls_Clean _ANSI_ARGS_ ((State *statePtr)); -int Tls_WaitForConnect _ANSI_ARGS_(( State *statePtr, - int *errorCodePtr)); - -BIO * BIO_new_tcl _ANSI_ARGS_((State* statePtr, int flags)); +Tcl_ChannelType *Tls_ChannelType(void); +Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags); + +Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert); +void Tls_Error(State *statePtr, char *msg); +void Tls_Free(char *blockPtr); +void Tls_Clean(State *statePtr); +int Tls_WaitForConnect(State *statePtr, int *errorCodePtr); + +BIO *BIO_new_tcl(State* statePtr, int flags); + +#define PTR2INT(x) ((int) ((intptr_t) (x))) #endif /* _TLSINT_H */ Index: tlsX509.c ================================================================== --- tlsX509.c +++ tlsX509.c @@ -99,12 +99,15 @@ char notBefore[BUFSIZ]; char notAfter[BUFSIZ]; char certStr[BUFSIZ]; #ifndef NO_SSL_SHA int shai; - char sha_hash[SHA_DIGEST_LENGTH*2]; + char sha_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1]; + unsigned char sha_hash_binary[SHA_DIGEST_LENGTH]; const char *shachars="0123456789ABCDEF"; + + sha_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0'; #endif certStr[0] = 0; if ((bio = BIO_new(BIO_s_mem())) == NULL) { subject[0] = 0; @@ -116,47 +119,45 @@ X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags); n = BIO_read(bio, subject, min(BIO_pending(bio), BUFSIZ - 1)); n = max(n, 0); subject[n] = 0; - BIO_flush(bio); + (void)BIO_flush(bio); X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags); n = BIO_read(bio, issuer, min(BIO_pending(bio), BUFSIZ - 1)); n = max(n, 0); issuer[n] = 0; - BIO_flush(bio); + (void)BIO_flush(bio); i2a_ASN1_INTEGER(bio, X509_get_serialNumber(cert)); n = BIO_read(bio, serial, min(BIO_pending(bio), BUFSIZ - 1)); n = max(n, 0); serial[n] = 0; - BIO_flush(bio); + (void)BIO_flush(bio); if (PEM_write_bio_X509(bio, cert)) { n = BIO_read(bio, certStr, min(BIO_pending(bio), BUFSIZ - 1)); n = max(n, 0); certStr[n] = 0; - BIO_flush(bio); + (void)BIO_flush(bio); } BIO_free(bio); } strcpy( notBefore, ASN1_UTCTIME_tostr( X509_get_notBefore(cert) )); strcpy( notAfter, ASN1_UTCTIME_tostr( X509_get_notAfter(cert) )); #ifndef NO_SSL_SHA - for (shai=0;shaisha1_hash[shai] & 0xF0) >> 4]; - sha_hash[shai * 2 + 1]=shachars[(cert->sha1_hash[shai] & 0x0F)]; - } - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "sha1_hash", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( sha_hash, SHA_DIGEST_LENGTH*2) ); + X509_digest(cert, EVP_sha1(), sha_hash_binary, NULL); + for (shai = 0; shai < SHA_DIGEST_LENGTH; shai++) { + sha_hash_ascii[shai * 2] = shachars[(sha_hash_binary[shai] & 0xF0) >> 4]; + sha_hash_ascii[shai * 2 + 1] = shachars[(sha_hash_binary[shai] & 0x0F)]; + } + Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha_hash_ascii, SHA_DIGEST_LENGTH * 2) ); #endif Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "subject", -1) ); Tcl_ListObjAppendElement( interp, certPtr,