Index: Makefile.in ================================================================== --- Makefile.in +++ Makefile.in @@ -292,11 +292,12 @@ #======================================================================== test: binaries libraries $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) \ -load "package ifneeded $(PACKAGE_NAME) $(PACKAGE_VERSION) \ - [list load `@CYGPATH@ $(PKG_LIB_FILE)` [string totitle $(PACKAGE_NAME)]]" + [list load $(PKG_LIB_FILE) [string totitle $(PACKAGE_NAME)]]; \ + source $(srcdir)/library/$(PACKAGE_NAME).tcl}" shell: binaries libraries @$(TCLSH) $(SCRIPT) gdb: @@ -305,11 +306,12 @@ gdb-test: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(GDB) \ --args $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` \ $(TESTFLAGS) -singleproc 1 \ -load "package ifneeded $(PACKAGE_NAME) $(PACKAGE_VERSION) \ - [list load `@CYGPATH@ $(PKG_LIB_FILE)` [string totitle $(PACKAGE_NAME)]]" + [list load $(PKG_LIB_FILE) [string totitle $(PACKAGE_NAME)]]; \ + source $(srcdir)/library/$(PACKAGE_NAME).tcl}" valgrind: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) \ `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) @@ -369,11 +371,11 @@ # In the following lines, $(srcdir) refers to the toplevel directory # containing your extension. If your sources are in a subdirectory, # you will have to modify the paths to reflect this: # # sample.$(OBJEXT): $(srcdir)/generic/sample.c -# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@ +# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@ # # Setting the VPATH variable to a list of paths will cause the makefile # to look into these paths when resolving .c to .obj dependencies. # As necessary, add $(srcdir):$(srcdir)/compat:.... #======================================================================== Index: README.txt ================================================================== --- README.txt +++ README.txt @@ -14,10 +14,19 @@ This extension works by creating a layered TCL Channel on top of an existing bi-directional channel created by the TLS socket command. All existing socket functionality is supported in addition to several new options. Both client and server modes are supported. + +Features +======== + +The package provides: +- Encrypted TCP communications layered on TCL channels. +- Status of encrypted channels. +- View X.509 certificate contents. + Documentation ============= See the doc directory for the full usage documentation. Index: acinclude.m4 ================================================================== --- acinclude.m4 +++ acinclude.m4 @@ -208,13 +208,13 @@ ] ) AC_MSG_CHECKING([for OpenSSL pkgconfig]) AC_MSG_RESULT($opensslpkgconfigdir) - dnl Use pkg-config to find OpenSSL if not already found + dnl Use pkg-config to find OpenSSL if not already found if test -n "$PKG_CONFIG" -a -z "$openssldir" -a -z "$opensslincludedir" -a -z "$openssllibdir"; then - USE_PKG_CONFIG=`"${PKG_CONFIG}" --list-all | grep openssl` + USE_PKG_CONFIG=`"${PKG_CONFIG}" --list-all | grep openssl | uniq` dnl Use pkg-config to find the library names if test -n "$USE_PKG_CONFIG"; then dnl Temporarily update PKG_CONFIG_PATH PKG_CONFIG_PATH_SAVE="${PKG_CONFIG_PATH}" @@ -227,25 +227,24 @@ export PKG_CONFIG_PATH fi pkgConfigExtraArgs='' if test "$SHARED_BUILD" == "0" -o "$TCLEXT_TLS_STATIC_SSL" == 'yes'; then + # Skip since sometimes will include extra libraries pkgConfigExtraArgs='--static' + pkgConfigExtraArgs='' fi - if test -z "$TCLTLS_SSL_LIBS"; then - TCLTLS_SSL_LIBS="$SSL_LIBS_PATH `${PKG_CONFIG} openssl --libs $pkgConfigExtraArgs`" || AC_MSG_ERROR([Unable to get OpenSSL Configuration]) - if test "${TCLEXT_TLS_STATIC_SSL}" == 'yes'; then - TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic" - fi - fi if test -z "$TCLTLS_SSL_CFLAGS"; then TCLTLS_SSL_CFLAGS="`"${PKG_CONFIG}" openssl --cflags-only-other $pkgConfigExtraArgs`" || AC_MSG_ERROR([Unable to get OpenSSL Configuration]) fi if test -z "$TCLTLS_SSL_INCLUDES"; then TCLTLS_SSL_INCLUDES="`"${PKG_CONFIG}" openssl --cflags-only-I $pkgConfigExtraArgs`" || AC_MSG_ERROR([Unable to get OpenSSL Configuration]) fi + if test -z "$TCLTLS_SSL_LIBS"; then + TCLTLS_SSL_LIBS="`${PKG_CONFIG} openssl --libs $pkgConfigExtraArgs`" || AC_MSG_ERROR([Unable to get OpenSSL Configuration]) + fi PKG_CONFIG_PATH="${PKG_CONFIG_PATH_SAVE}" fi fi dnl Use fall-back settings for OpenSSL include and library paths @@ -256,19 +255,39 @@ if test -f /usr/include/openssl/ssl.h; then TCLTLS_SSL_INCLUDES="-I/usr/include" fi fi if test -z "$TCLTLS_SSL_LIBS"; then - if test "$TCLEXT_TLS_STATIC_SSL" == 'no'; then - TCLTLS_SSL_LIBS="$SSL_LIBS_PATH -lssl -lcrypto" - else - # Linux and Solaris - TCLTLS_SSL_LIBS="$SSL_LIBS_PATH -Wl,-Bstatic -lssl -lcrypto -Wl,-Bdynamic" - # HPUX: -Wl,-a,archive ... -Wl,-a,shared_archive - fi - fi + TCLTLS_SSL_LIBS="-lssl -lcrypto" + fi + + dnl Set for static libraries + if test "$TCLEXT_TLS_STATIC_SSL" == 'yes'; then + system="`uname -s`" + case $system in + AIX*) + TCLTLS_SSL_LIBS="-Wl,-bstatic $TCLTLS_SSL_LIBS -Wl,-bdynamic";; + BSD*|OpenBSD*) + TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic";; + CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) + TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic";; + Darwin-*) + TCLTLS_SSL_LIBS="$TCLTLS_SSL_LIBS";; + HP-UX-*) + TCLTLS_SSL_LIBS="-Wl,-a,archive $TCLTLS_SSL_LIBS -Wl,-a,shared_archive";; + IRIX-*) + TCLTLS_SSL_LIBS="-Wl,-B, static $TCLTLS_SSL_LIBS -Wl,-B, dynamic";; + Solaris*) + TCLTLS_SSL_LIBS="-Bstatic $TCLTLS_SSL_LIBS -Bdynamic";; + Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*) + TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic";; + esac + fi + TCLTLS_SSL_LIBS="$SSL_LIBS_PATH $TCLTLS_SSL_LIBS" + AC_MSG_CHECKING([for SSL libs]) + AC_MSG_RESULT([$TCLTLS_SSL_LIBS]) dnl Include config variables in --help list and make available to be substituted via AC_SUBST. AC_ARG_VAR([TCLTLS_SSL_CFLAGS], [C compiler flags for OpenSSL]) AC_ARG_VAR([TCLTLS_SSL_INCLUDES], [C compiler include paths for OpenSSL]) AC_ARG_VAR([TCLTLS_SSL_LIBS], [libraries to pass to the linker for OpenSSL]) ]) Index: configure ================================================================== --- configure +++ configure @@ -1,8 +1,8 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tls 2.0b1. +# Generated by GNU Autoconf 2.72 for tls 2.0b2. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, # Inc. # @@ -599,12 +599,12 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tls' PACKAGE_TARNAME='tls' -PACKAGE_VERSION='2.0b1' -PACKAGE_STRING='tls 2.0b1' +PACKAGE_VERSION='2.0b2' +PACKAGE_STRING='tls 2.0b2' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ @@ -1340,11 +1340,11 @@ # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures tls 2.0b1 to adapt to many kinds of systems. +'configure' configures tls 2.0b2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. @@ -1402,11 +1402,11 @@ _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tls 2.0b1:";; + short | recursive ) echo "Configuration of tls 2.0b2:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options @@ -1528,11 +1528,11 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tls configure 2.0b1 +tls configure 2.0b2 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -1835,11 +1835,11 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tls $as_me 2.0b1, which was +It was created by tls $as_me 2.0b2, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw _ACEOF @@ -2810,20 +2810,20 @@ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ + `ls -d /usr/lib/tcl9.1 2>/dev/null` \ `ls -d /usr/lib/tcl9.0 2>/dev/null` \ - `ls -d /usr/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/lib/tcl8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl9.1 2>/dev/null` \ `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl9.1 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.5 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" @@ -4031,12 +4031,15 @@ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TEA_PLATFORM" >&5 printf "%s\n" "$TEA_PLATFORM" >&6; } # The BUILD_$pkg is to define the correct extern storage class # handling when making this package + # To be able to sefely use the package name in a #define, it must not + # contain anything other than alphanumeric characters and underscores + SAFE_PKG_NAME=tls -printf "%s\n" "#define BUILD_${PACKAGE_NAME} /**/" >>confdefs.h +printf "%s\n" "#define BUILD_${SAFE_PKG_NAME} /**/" >>confdefs.h # Do this here as we have fully defined TEA_PLATFORM now if test "${TEA_PLATFORM}" = "windows" ; then EXEEXT=".exe" CLEANFILES="$CLEANFILES *.lib *.dll *.pdb *.exp" @@ -6567,10 +6570,11 @@ ;; ia64) MACHINE="IA64" ;; esac + do64bit_ok=yes fi if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT @@ -6577,11 +6581,11 @@ else runtime=-MD fi case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) - lflags="${lflags} -nodefaultlib:libucrt.lib" + lflags="${lflags} -nodefaultlib:ucrt.lib" vars="ucrt.lib" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib @@ -6979,15 +6983,19 @@ SHLIB_SUFFIX=".so" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - CYGWIN_*) + CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" + if test "${TEA_PLATFORM}" = "unix" -a "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$(patsubst cyg%.dll,lib%.dll,\$@).a" + else + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" + fi EXEEXT=".exe" do64bit_ok=yes CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; @@ -9047,21 +9055,28 @@ # Shared libraries and static libraries have different names. # Use the double eval to make sure any variables in the suffix is # substituted. (@@@ Might not be necessary anymore) #-------------------------------------------------------------------- - PACKAGE_LIB_PREFIX8="${PACKAGE_LIB_PREFIX}" - PACKAGE_LIB_PREFIX9="${PACKAGE_LIB_PREFIX}tcl9" + if test "$TEA_PLATFORM" = "unix"; then + PACKAGE_LIB_PREFIX8="lib" + if test "$EXEEXT" = ".exe" -a "$SHARED_BUILD" != "0"; then + PACKAGE_LIB_PREFIX9="cygtcl9" + else + PACKAGE_LIB_PREFIX9="libtcl9" + fi + else + PACKAGE_LIB_PREFIX8="" + PACKAGE_LIB_PREFIX9="tcl9" + fi if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX9}" else PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX8}" printf "%s\n" "#define TCL_MAJOR_VERSION 8" >>confdefs.h - fi - if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tk8}" != x; then printf "%s\n" "#define TK_MAJOR_VERSION 8" >>confdefs.h fi if test "${TEA_PLATFORM}" = "windows" ; then @@ -9072,10 +9087,46 @@ SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test "$GCC" = "yes"; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -static-libgcc" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the linker understands --disable-high-entropy-va" >&5 +printf %s "checking if the linker understands --disable-high-entropy-va... " >&6; } +if test ${tcl_cv_ld_high_entropy+y} +then : + printf %s "(cached) " >&6 +else case e in #( + e) + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--disable-high-entropy-va" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + tcl_cv_ld_high_entropy=yes +else case e in #( + e) tcl_cv_ld_high_entropy=no ;; +esac +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + CFLAGS=$hold_cflags ;; +esac +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_high_entropy" >&5 +printf "%s\n" "$tcl_cv_ld_high_entropy" >&6; } + if test $tcl_cv_ld_high_entropy = yes; then + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--disable-high-entropy-va" fi eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" else @@ -9103,24 +9154,24 @@ if test "${SHARED_BUILD}" = "1" ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" fi - eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" RANLIB=: else - eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then - eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" + eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" else - eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi fi # These are escaped so that only CFLAGS is picked up at configure time. # The other values will be substituted at make time. @@ -9568,11 +9619,11 @@ printf %s "checking for OpenSSL pkgconfig... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $opensslpkgconfigdir" >&5 printf "%s\n" "$opensslpkgconfigdir" >&6; } if test -n "$PKG_CONFIG" -a -z "$openssldir" -a -z "$opensslincludedir" -a -z "$openssllibdir"; then - USE_PKG_CONFIG=`"${PKG_CONFIG}" --list-all | grep openssl` + USE_PKG_CONFIG=`"${PKG_CONFIG}" --list-all | grep openssl | uniq` if test -n "$USE_PKG_CONFIG"; then PKG_CONFIG_PATH_SAVE="${PKG_CONFIG_PATH}" if test -n "$opensslpkgconfigdir"; then if ! test -f "${opensslpkgconfigdir}/openssl.pc"; then @@ -9583,25 +9634,24 @@ export PKG_CONFIG_PATH fi pkgConfigExtraArgs='' if test "$SHARED_BUILD" == "0" -o "$TCLEXT_TLS_STATIC_SSL" == 'yes'; then + # Skip since sometimes will include extra libraries pkgConfigExtraArgs='--static' + pkgConfigExtraArgs='' fi - if test -z "$TCLTLS_SSL_LIBS"; then - TCLTLS_SSL_LIBS="$SSL_LIBS_PATH `${PKG_CONFIG} openssl --libs $pkgConfigExtraArgs`" || as_fn_error $? "Unable to get OpenSSL Configuration" "$LINENO" 5 - if test "${TCLEXT_TLS_STATIC_SSL}" == 'yes'; then - TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic" - fi - fi if test -z "$TCLTLS_SSL_CFLAGS"; then TCLTLS_SSL_CFLAGS="`"${PKG_CONFIG}" openssl --cflags-only-other $pkgConfigExtraArgs`" || as_fn_error $? "Unable to get OpenSSL Configuration" "$LINENO" 5 fi if test -z "$TCLTLS_SSL_INCLUDES"; then TCLTLS_SSL_INCLUDES="`"${PKG_CONFIG}" openssl --cflags-only-I $pkgConfigExtraArgs`" || as_fn_error $? "Unable to get OpenSSL Configuration" "$LINENO" 5 fi + if test -z "$TCLTLS_SSL_LIBS"; then + TCLTLS_SSL_LIBS="`${PKG_CONFIG} openssl --libs $pkgConfigExtraArgs`" || as_fn_error $? "Unable to get OpenSSL Configuration" "$LINENO" 5 + fi PKG_CONFIG_PATH="${PKG_CONFIG_PATH_SAVE}" fi fi if test -z "$TCLTLS_SSL_CFLAGS"; then @@ -9611,18 +9661,39 @@ if test -f /usr/include/openssl/ssl.h; then TCLTLS_SSL_INCLUDES="-I/usr/include" fi fi if test -z "$TCLTLS_SSL_LIBS"; then - if test "$TCLEXT_TLS_STATIC_SSL" == 'no'; then - TCLTLS_SSL_LIBS="$SSL_LIBS_PATH -lssl -lcrypto" - else - # Linux and Solaris - TCLTLS_SSL_LIBS="$SSL_LIBS_PATH -Wl,-Bstatic -lssl -lcrypto -Wl,-Bdynamic" - # HPUX: -Wl,-a,archive ... -Wl,-a,shared_archive - fi - fi + TCLTLS_SSL_LIBS="-lssl -lcrypto" + fi + + if test "$TCLEXT_TLS_STATIC_SSL" == 'yes'; then + system="`uname -s`" + case $system in + AIX*) + TCLTLS_SSL_LIBS="-Wl,-bstatic $TCLTLS_SSL_LIBS -Wl,-bdynamic";; + BSD*|OpenBSD*) + TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic";; + CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) + TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic";; + Darwin-*) + TCLTLS_SSL_LIBS="$TCLTLS_SSL_LIBS";; + HP-UX-*) + TCLTLS_SSL_LIBS="-Wl,-a,archive $TCLTLS_SSL_LIBS -Wl,-a,shared_archive";; + IRIX-*) + TCLTLS_SSL_LIBS="-Wl,-B, static $TCLTLS_SSL_LIBS -Wl,-B, dynamic";; + Solaris*) + TCLTLS_SSL_LIBS="-Bstatic $TCLTLS_SSL_LIBS -Bdynamic";; + Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*) + TCLTLS_SSL_LIBS="-Wl,-Bstatic $TCLTLS_SSL_LIBS -Wl,-Bdynamic";; + esac + fi + TCLTLS_SSL_LIBS="$SSL_LIBS_PATH $TCLTLS_SSL_LIBS" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for SSL libs" >&5 +printf %s "checking for SSL libs... " >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLTLS_SSL_LIBS" >&5 +printf "%s\n" "$TCLTLS_SSL_LIBS" >&6; } @@ -9646,11 +9717,11 @@ PKG_INCLUDES="$PKG_INCLUDES $i" done - vars="${TCLTLS_SSL_LIBS}" + vars="${TCLTLS_SSL_LIBS} ws2_32.lib Crypt32.lib" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.[lL][iI][bB]$/-l\1/'` fi @@ -10291,11 +10362,11 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tls $as_me 2.0b1, which was +This file was extended by tls $as_me 2.0b2, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS @@ -10346,11 +10417,11 @@ ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tls config.status 2.0b1 +tls config.status 2.0b2 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation Index: configure.ac ================================================================== --- configure.ac +++ configure.ac @@ -14,11 +14,11 @@ # so you can encode the package version directly into the source files. # This will also define a special symbol for Windows (BUILD_ # so that we create the export library with the dll. #----------------------------------------------------------------------- -AC_INIT([tls],[2.0b1]) +AC_INIT([tls],[2.0b2]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. # This will define a ${TEA_PLATFORM} variable == "unix" or "windows" # as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE. @@ -171,11 +171,11 @@ if test "${TEA_PLATFORM}" = "windows" ; then if test "$GCC" = "yes"; then TEA_ADD_CFLAGS([${TCLTLS_SSL_CFLAGS} -Wno-deprecated-declarations]) TEA_ADD_INCLUDES([${TCLTLS_SSL_INCLUDES}]) - TEA_ADD_LIBS([${TCLTLS_SSL_LIBS}]) + TEA_ADD_LIBS([${TCLTLS_SSL_LIBS} ws2_32.lib Crypt32.lib]) fi else TEA_ADD_CFLAGS([${TCLTLS_SSL_CFLAGS} -Wno-deprecated-declarations]) TEA_ADD_INCLUDES([${TCLTLS_SSL_INCLUDES}]) TEA_ADD_LIBS([${TCLTLS_SSL_LIBS}]) Index: demos/README.txt ================================================================== --- demos/README.txt +++ demos/README.txt @@ -1,8 +1,11 @@ This directory contain example files for how to use the TLS package to perform common functions. These are just a few of the possibilities. +echat.tcl +Example echo chat tool. Start with -server or -client arg to set client/server mode. + gets_blocking_no_variable.tcl Download a webpage using gets, no variable arg, and blocking I/O. gets_blocking_with_variable.tcl Download a webpage using gets, variable arg, and blocking I/O. @@ -18,14 +21,14 @@ http_debug_example.tcl Download a webpage using http package with additional debug output. http_get_file.tcl -Download a webpage using the http package. +Download a file using the http package. http_get_webpage.tcl -Download a file using the http package. +Download a webpage using the http package. http_get_webpage_proxy.tcl Download a file using the http and autoproxy packages. read_blocking_webpage.tcl ADDED demos/echat.tcl Index: demos/echat.tcl ================================================================== --- /dev/null +++ demos/echat.tcl @@ -0,0 +1,308 @@ +#!/usr/bin/env tclsh +# +# Example encrypted echo chat tool +# +# Usage: +# Server: tclsh echat.tcl -server +# +# Client: tclsh echat.tcl -client +# + +package prefer latest +package require tls +package require Tk + + + +# +# Config settings +# +set host localhost +set port 9876 +set mode client +set clients [list] +set chan "" + +set certsDir [file join [file dirname [info script]] .. tests certs] +set serverCert [file join $certsDir server.pem] +set clientCert [file join $certsDir client.pem] +set caCert [file join $certsDir ca.pem] +set serverKey [file join $certsDir server.key] +set clientKey [file join $certsDir client.key] + + + +######################## + +# +# Send message +# +proc message_send {var w} { + set ch [set $var] + set msg [$w get] + log $msg sender + if {$ch ne ""} { + puts $ch $msg + } + $w delete 0 end +} + +# +# Receive message +# +proc message_receive {ch} { + set msg "" + if {[gets $ch msg] <= 0} { + if {[eof $ch]} { + close $ch + exit + } + } + if {[string length $msg] > -1} { + log $msg receiver + } +} + +# +# Connect with TLS +# +proc client_connect {ch} { + tls::import $ch -request 1 -require 0 + #tls::import $ch -certfile $::clientCert -cafile $::caCert -keyfile $::clientKey + tls::handshake $ch + set time [clock format [clock seconds]] + log [format "Client connection finished at %s" $time] local +} + +# +# Setup client +# +proc client_setup {} { + global host + global port + global chan + + set ch [socket $host $port] + fconfigure $ch -blocking 0 -buffering line -buffersize 32768 -encoding utf-8 -translation auto + if {[info tclversion] >= 9.0} { + fconfigure $ch -keepalive 1 -nodelay 1 + } + chan event $ch readable [list message_receive $ch] + after idle [list client_connect $ch] + set chan $ch + return $ch +} + +# +# Shutdown client +# +proc client_shutdown {ch} { + close $ch +} + +######################## + +# +# Add client to client list +# +proc add_client {ch} { + global clients + + if {$ch ni $clients} { + lappend clients $ch + } +} + +# +# Remove client from client list +# +proc remove_client {ch} { + global clients + + if {$ch in $clients} { + set index [lsearch $clients $ch] + set clients [lreplace $clients $index $index] + } +} + +# +# Send message +# +proc send_all {w} { + global clients + + set msg [$w get] + log $msg sender + + foreach client $clients { + if {[catch {puts $client $msg} err]} { + close $client + remove_client $client + } + } + $w delete 0 end +} + +# +# Echo received messages +# +proc echo {ch} { + global clients + + if {[gets $ch msg] <= 0} { + if {[eof $ch]} { + close $ch + remove_client $ch + return + } + } + log $msg receiver + + foreach client $clients { + if {[catch {puts $client $msg} err]} { + close $client + remove_client $client + } + } +} + +# +# Accept client connections +# +proc accept {ch addr port} { + add_client $ch + set time [clock format [clock seconds]] + + fconfigure $ch -blocking 0 -buffering line -buffersize 32768 -encoding utf-8 -translation auto + log [format "Accepted client connection from %s on port %d at %s" $addr $port $time] local + + tls::import $ch -server 1 -certfile $::serverCert -cafile $::caCert -keyfile $::serverKey + chan event $ch readable [list echo $ch] + puts $ch [format "Connected to server at %s" $time] +} + +# +# Setup server +# +proc server_setup {} { + global port + global chan + + set ch [socket -server accept $port] + fconfigure $ch -blocking 0 -buffering line -buffersize 32768 -encoding utf-8 -translation auto + if {[info tclversion] >= 9.0} { + fconfigure $ch -keepalive 1 -nodelay 1 + } + set chan $ch + return $ch +} + +# +# Shutdown server +# +proc server_shutdown {ch} { + global clients + + foreach client $clients { + close $client + } + close $ch +} + +######################## + +# +# Log message +# +proc text_update {w msg tag} { + $w insert end $msg\n $tag + $w yview moveto 1.0 +} + +# +# Create GUI +# +proc setup_gui {w mode} { + wm title $w [format "Chat %s Mode" [string totitle $mode]] + + grid columnconfigure $w 0 -weight 1 + grid rowconfigure $w 0 -weight 1 + + # Messages frame + set f [ttk::frame ${w}msgs] + grid $f -sticky nsew + grid columnconfigure $f 0 -weight 1 + grid rowconfigure $f 0 -weight 1 + + set t [text $f.text -yscrollcommand [list $f.vsb set]] + # -xscrollcommand [list $f.hsb set] + #set sh [ttk::scrollbar $f.hsb -command [list $t xview] -orient horizontal] + set sv [ttk::scrollbar $f.vsb -command [list $t yview] -orient vertical] + grid $t -row 0 -column 0 -sticky nsew + grid $sv -row 0 -column 1 -sticky nsew + #grid $sh -row 1 -column 0 -sticky nsew + interp alias {} log {} text_update $t + + # Create tags + $t tag configure sender -background lightblue -foreground black -justify right \ + -lmargin1 100 -lmargin2 100 -lmargincolor white -spacing1 15 -wrap word + $t tag configure receiver -background lightgray -foreground black -justify left \ + -rmargin 100 -rmargincolor white -spacing1 15 -wrap word + $t tag configure local -background white -foreground black -justify left \ + -spacing1 15 -wrap word + + # Send frame + set f [ttk::frame ${w}send] + grid $f -sticky nsew + grid columnconfigure $f 0 -weight 1 + grid rowconfigure $f 0 -weight 1 + + set e [ttk::entry $f.e -xscrollcommand [list $f.hsb set]] + if {$mode eq "client"} { + set cmd [list message_send ::chan $e] + } else { + set cmd [list send_all $e] + } + set b [ttk::button $f.b -command $cmd -text "Send"] + bind $e $cmd + set sh [ttk::scrollbar $f.hsb -command [list $e xview] -orient horizontal] + grid $e -row 0 -column 0 -sticky nsew + grid $b -row 0 -column 1 -sticky nsew + grid $sh -row 1 -column 0 -sticky nsew + + wm protocol $w WM_DELETE_WINDOW shutdown +} + +# +# Shutdown +# +proc shutdown {} { + global mode + + if {$mode eq "client"} { + client_shutdown $::chan + } else { + server_shutdown $::chan + } + exit +} + +# +# Start client or server +# +proc main {args} { + global mode + + if {"-client" in $args} { + set mode client + set cmd [list client_setup] + } else { + set mode server + set cmd [list server_setup] + } + setup_gui . $mode + after 1000 $cmd + vwait done +} + +main {*}$::argv Index: demos/gets_blocking_no_variable.tcl ================================================================== --- demos/gets_blocking_no_variable.tcl +++ demos/gets_blocking_no_variable.tcl @@ -2,10 +2,11 @@ # # Example 1: Blocking channel gets with no variable # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 Index: demos/gets_blocking_with_variable.tcl ================================================================== --- demos/gets_blocking_with_variable.tcl +++ demos/gets_blocking_with_variable.tcl @@ -2,10 +2,11 @@ # # Example 2: Blocking channel gets with variable # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 Index: demos/gets_nonblocking_no_variable.tcl ================================================================== --- demos/gets_nonblocking_no_variable.tcl +++ demos/gets_nonblocking_no_variable.tcl @@ -2,10 +2,11 @@ # # Example 3: Non-blocking channel gets with no variable # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 @@ -72,6 +73,6 @@ catch {close $ch} } set data "" gets_non_blocking_no_variable $host $port $path $protocol -save_file "gets_non_blocking_no_variable.txt" $data +save_file "gets_nonblocking_no_variable.txt" $data Index: demos/gets_nonblocking_with_variable.tcl ================================================================== --- demos/gets_nonblocking_with_variable.tcl +++ demos/gets_nonblocking_with_variable.tcl @@ -2,10 +2,11 @@ # # Example 4: Non-blocking channel gets with variable # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 @@ -71,7 +72,7 @@ catch {close $ch} } set data "" gets_non_blocking_with_variable $host $port $path $protocol -save_file "gets_non_blocking_with_variable.txt" $data +save_file "gets_nonblocking_with_variable.txt" $data Index: demos/gets_with_debug_data.tcl ================================================================== --- demos/gets_with_debug_data.tcl +++ demos/gets_with_debug_data.tcl @@ -2,10 +2,11 @@ # # Example 4: Non-blocking channel gets with variable # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 Index: demos/http_debug_example.tcl ================================================================== --- demos/http_debug_example.tcl +++ demos/http_debug_example.tcl @@ -2,15 +2,16 @@ # # Download webpage using HTTP package with debug output # ################################################# +package prefer latest package require Tcl 8.6- package require tls package require http -set url "https://www.tcl.tk/" +set url "https://www.tcl-lang.org/" set port 443 set protocol "http/1.1" # Register https protocol handler with http package http::register https 443 [list ::tls::socket -autoservername 1 -require 1 -alpn [list [string tolower $protocol]] \ Index: demos/http_get_file.tcl ================================================================== --- demos/http_get_file.tcl +++ demos/http_get_file.tcl @@ -2,10 +2,11 @@ # # Download file using HTTP package # ################################################# +package prefer latest package require Tcl 8.6- package require tls package require http set url "https://wiki.tcl-lang.org/sitemap.xml" Index: demos/http_get_webpage.tcl ================================================================== --- demos/http_get_webpage.tcl +++ demos/http_get_webpage.tcl @@ -2,15 +2,16 @@ # # Download webpage using HTTP package # ################################################# +package prefer latest package require Tcl 8.6- package require tls package require http -set url "https://www.tcl.tk/" +set url "https://www.tcl-lang.org/" set port 443 set protocol "http/1.1" # Register https protocol handler with http package http::register https 443 [list ::tls::socket -autoservername 1 -require 1 -alpn [list [string tolower $protocol]]] Index: demos/http_get_webpage_proxy.tcl ================================================================== --- demos/http_get_webpage_proxy.tcl +++ demos/http_get_webpage_proxy.tcl @@ -9,17 +9,18 @@ # - Do tls::import # - Start handdshaking # ################################################# +package prefer latest package require Tcl 8.6- package require tls package require http package require autoproxy autoproxy::init -set url "https://www.tcl.tk/" +set url "https://www.tcl-lang.org/" set port 443 set protocol "http/1.1" # Set these if not set by OS/Platform if 0 { Index: demos/read_blocking_webpage.tcl ================================================================== --- demos/read_blocking_webpage.tcl +++ demos/read_blocking_webpage.tcl @@ -2,10 +2,11 @@ # # Read using blocking channel # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 Index: demos/read_nonblocking_webpage.tcl ================================================================== --- demos/read_nonblocking_webpage.tcl +++ demos/read_nonblocking_webpage.tcl @@ -2,10 +2,11 @@ # # Read using blocking channel # ################################################# +package prefer latest package require Tcl 8.6- package require tls set host "www.google.com" set port 443 Index: doc/tls.html ================================================================== --- doc/tls.html +++ doc/tls.html @@ -98,11 +98,11 @@
-

tls(n) 2.0b1 tls "Tcl TLS extension"

+

tls(n) 2.0b2 tls "Tcl TLS extension"

Name

tls - binding to the OpenSSL library for encrypted socket and I/O channel communications

Description

-

This extension provides TCL script access to secure socket communications -using the Transport Layer Security (TLS) protocol. It provides a generic -binding to OpenSSL, utilizing the -Tcl_StackChannel API in TCL 8.4 and higher. -These sockets behave exactly the same as channels created using the built-in -socket command, but provide additional options for controlling -the SSL/TLS session.

+

This extension provides TCL script access to Secure Socket Layer (SSL) +communications using the Transport Layer Security (TLS) protocol. It provides a +generic binding to OpenSSL, utilizing the +Tcl_StackChannel API in TCL 8.4 or later. These sockets behave exactly +the same as channels created using the built-in socket command, but +provide additional options for controlling the SSL/TLS session.

Compatibility

This extension is compatible with OpenSSL 1.1.1 or later. It requires Tcl version 8.5 or later and will work with Tcl 9.0.

Commands

-

The following are the commands provided by the TcLTLS package. See the +

The following are the commands provided by the TcLTLS package. See Examples for example usage and the "demos" directory for more example usage.

tls::init ?-option? ?value? ?-option value ...?

Optional function to set the default options used by tls::socket. If you call tls::import directly, the values set by this command have no effect. This command supports all of the same options as the tls::socket command, -though you should limit your options to only TLS related ones.

+though you should limit your options to only the TLS related ones.

tls::socket ?-option? ?value? ?-option value ...? host port

This is a helper function that utilizes the underlying commands socket and tls::import to create the connection. It behaves the same as the -native TCL socket command, but also supports the tls:import +native TCL socket command, but also supports the tls::import command options with one additional option. It returns the channel handle id -for the new socket.

+for the new socket. Additional options are:

-autoservername bool

If true, automatically set the -servername argument to the host argument. Prior to TclTLS 2.0, the default is false. Starting in TclTLS 2.0, the default is true unless -servername is also specified.

tls::socket -server command ?-option? ?value? ?-option value ...? port
-

Same as previous, but instead creates a server socket for clients to connect to -just like the Tcl socket -server command. It returns the channel -handle id for the new socket.

+

Same as previous command, but instead creates a server socket for clients to +connect to just like the Tcl socket -server command. It returns the +channel handle id for the new socket.

tls::import channel ?-option? ?value? ?-option value ...?
+
+
tls::starttls channel ?-option? ?value? ?-option value ...?

Start TLS encryption on TCL channel channel via a stacked channel. It need not be a socket, but must provide bi-directional flow. Also sets session parameters for SSL handshake. Valid options are:

-alpn list
@@ -249,11 +254,11 @@ See Callback Options for more info.

-dhparams filename

Specifies the Diffie-Hellman (DH) parameters file.

-keyfile filename

Specifies the private key file. The default is to use the file -specified by the -certfile option.

+specified by the -certfile option.

-key string

Specifies the private key to use as a DER encoded string (PKCS#1 DER).

-model channel

Force this channel to share the same SSL_CTX structure as the specified channel, and therefore share config, callbacks, etc.

@@ -265,21 +270,22 @@
-post_handshake bool

Allow post-handshake session ticket updates. This option is new for TclTLS 1.8.

-request bool

Request a certificate from the peer during the SSL handshake. This is needed to do Certificate Validation. Starting in TclTLS 1.8, the default is -true. Starting in TclTLS 2.0, If set to false and --require is true, then this will be overridden to true. +true for client connections. Starting in TclTLS 2.0, if set to +false and -require is true, then this will be +overridden to true. See Certificate Validation for more details.

-require bool

Require a valid certificate from the peer during the SSL handshake. If this is set to true, then -request must also be set to true and a either -cadir, -cafile, -castore, or a platform default must be provided in order to validate against. The default in TclTLS 1.8 and earlier versions is false since not all platforms have certificates to validate against in a form compatible with OpenSSL. Starting in TclTLS 2.0, -the default is true. +the default is true for client connections. See Certificate Validation for more details.

-security_level integer

Specifies the security level (value from 0 to 5). The security level affects the allowed cipher suite encryption algorithms, supported ECC curves, supported signature algorithms, DH parameter sizes, certificate key sizes @@ -292,11 +298,11 @@ client connects and provides a client handshake. The default is false.

-servername hostname

Specify the peer's hostname. This is used to set the TLS Server Name Indication (SNI) extension. Set this to the expected servername in the server's certificate or one of the Subject Alternate Names (SAN). Starting in TclTLS 2.0, this will -default to the host for the tls::socket command.

+default to the host from the tls::socket command.

-session_id binary_string

Specifies the session id to resume a session. Not supported yet. This option is new for TclTLS 1.8.

-ssl2 bool

Enable use of SSL v2.The default is false. @@ -307,15 +313,15 @@ use of SSL v3 if only available via a compile time option. See the tls::protocols command for supported protocols.

-tls1 bool

Enable use of TLS v1. Starting in TclTLS 2.0, the default is false. Note: TLS 1.0 needs SHA1 to operate, which is only available in security level -0 for Open SSL 3.0+. See the -security_level option.

+0 for Open SSL 3.0+. See the -security_level option.

-tls1.1 bool

Enable use of TLS v1.1. Starting in TclTLS 2.0, the default is false. Note: TLS 1.1 needs SHA1 to operate, which is only available in security level -0 for Open SSL 3.0+. See the -security_level option.

+0 for Open SSL 3.0+. See the -security_level option.

-tls1.2 bool

Enable use of TLS v1.2. The default is true.

-tls1.3 bool

Enable use of TLS v1.3. The default is true. This is only available starting with OpenSSL 1.1.1 and TclTLS 1.7.

@@ -325,24 +331,29 @@ by TCL scripts to perform their own Certificate Validation to supplement the default validation provided by OpenSSL. The script must return a boolean true to continue the negotiation. See Callback Options for more info. This option is new for TclTLS 1.8.

-
tls::unimport channel
-

Compliment to tls::import. Used to remove the top level stacked channel -from channel. This unstacks the encryption of a regular TCL channel. An -error is thrown if TLS is not the top stacked channel type.

tls::handshake channel

Forces the TLS negotiation handshake to take place immediately, and returns 0 if handshake is still in progress (non-blocking), or 1 if the handshake was successful. If the handshake failed, an error will be returned.

-
tls::status ?-local? channel
+
tls::shutdown channel
+
+
tls::unimport channel
+
+
tls::unstack channel
+

This terminates the SSL/TLS session by sending the "close_notify" message and +removes the top level stacked channel from channel, but it does not close +the socket. It is the compliment to tls::import by ending encryption of +a TCL channel. An error is thrown if TLS is not the top stacked channel type.

+
tls::status ?-local? channel

Returns the current status of an SSL channel. The result is a list of key-value pairs describing the SSL, certificate, and certificate verification status. If the SSL handshake has not yet completed, an empty list is returned. If the --local option is specified, then the local certificate is used. Returned -values include:

+-local option is specified, then the local certificate is used. +Returned values include:

SSL Status

alpn protocol

The protocol selected after Application-Layer Protocol Negotiation (ALPN). This value is new for TclTLS 1.8.

@@ -455,11 +466,11 @@ This value is new for TclTLS 1.8.

sha256_hash hash

The SHA256 hash of the certificate as a hex string. This value is new for TclTLS 1.8.

-
tls::connection channel
+
tls::connection channel

Returns the current connection status of an SSL channel. The result is a list of key-value pairs describing the connection. This command is new for TclTLS 1.8. Returned values include:

SSL Status

@@ -526,24 +537,24 @@
master_key binary_string

Unique session master key.

session_cache_mode mode

Server cache mode (client, server, or both).

-
tls::ciphers ?protocol? ?verbose? ?supported?
+
tls::ciphers ?protocol? ?verbose? ?supported?

Without any options, it returns a list of all symmetric ciphers for use with the -cipher option. With protocol, only the ciphers supported for that protocol are returned. See the tls::protocols command for the supported protocols. If verbose is specified as true then a verbose, human readable list is returned with additional information on the cipher. If supported is specified as true, then only the ciphers supported for protocol will be listed. The supported arg is new for TclTLS 1.8.

-
tls::protocols
+
tls::protocols

Returns a list of the supported SSL/TLS protocols. Valid values are: ssl2, ssl3, tls1, tls1.1, tls1.2, and tls1.3. Exact list depends on OpenSSL version and compile time flags. This command is new for TclTLS 1.8.

-
tls::version
+
tls::version

Returns the OpenSSL version string.

Certificate Validation

PKI and Certificates

@@ -561,11 +572,11 @@ certificate and that certificate is authenticated (i.e. signed) by a Certificate Authority (CA). Users can then exchange these certificates during the TLS initialization process and check them against the root CA certificates to ensure they are valid. This is handled by OpenSSL via the -request and -require options. See the -cadir, -cadir, and --castore options for how tp specify where to find the CA certificates. +-castore options for how to specify where to find the CA certificates. Optionally, in a future release, they can also be checked against the Certificate Revocation List (CRL) of revoked certificates. Certificates can also be self-signed, but they are by default not trusted unless you add them to your certificate store.

Typically when visiting web sites, only the client needs to check the server's @@ -591,38 +602,37 @@

Specifies the Uniform Resource Identifier (URI) for the Certificate Authority (CA) store, which may be a single container or a catalog of containers. Starting with OpenSSL 3.2 on MS Windows, set to "org.openssl.winstore://" to use the built-in MS Windows Certificate Store. Starting in TclTLS 2.0, this is the default if -cadir, -cadir, and -castore are -not specified. This store only supports root certificate stores. See -Certificate Validation for more details.

+not specified. This store only supports root certificate stores.

-request bool

Request a certificate from the peer during the SSL handshake. This is needed to do Certificate Validation. Starting in TclTLS 1.8, the default is -true. Starting in TclTLS 2.0, If set to false and --require is true, then this will be overridden to true. -In addition, the client can manually inspect and accept or reject -each certificate using the -validatecommand option.

+true for client connections. Starting in TclTLS 2.0, if set to +false and -require is true, then this will be +overridden to true. In addition, the client can manually inspect and +accept or reject each certificate using the -validatecommand option.

-require bool

Require a valid certificate from the peer during the SSL handshake. If this is set to true, then -request must also be set to true and a either -cadir, -cafile, -castore, or a platform default must be provided in order to validate against. The default in TclTLS 1.8 and earlier versions is false since not all platforms have certificates to validate against in a form compatible with OpenSSL. Starting in TclTLS 2.0, -the default is true.

+the default is true for client connections.

When are command line options needed?

In TclTLS 1.8 and earlier versions, certificate validation is NOT enabled by default. This limitation is due to the lack of a common cross platform database of Certificate Authority (CA) provided certificates to validate against. Many Linux systems natively support OpenSSL and thus have these certificates installed as part of the OS, but MacOS and MS Windows do not. -Staring in TclTLS 2.0, this has been changed to require certificate validation -by default. In order to use the -require option, one of the following -must be true:

+Staring in TclTLS 2.0, the default for client connections has been changed to +require certificate validation by default. In order to use the -require +option, one of the following must be true:

  • On Linux and Unix systems with OpenSSL already installed or if the CA certificates are available in PEM format, and if they are stored in the standard locations, or if the SSL_CERT_DIR or SSL_CERT_FILE environment variables are set, then -cadir, -cadir, @@ -630,11 +640,11 @@

  • If OpenSSL is not installed in the default location, or when using Mac OS or MS Windows and OpenSSL is installed, the SSL_CERT_DIR and/or SSL_CERT_FILE environment variables or the one of the -cadir, -cadir, or -castore options must be defined.

  • On MS Windows, starting in OpenSSL 3.2, it is now possible to access the -built-in Windows Certificate Store from OpenSSL. This can utilized by +built-in Windows Certificate Store from OpenSSL. This can be utilized by setting the -castore option to "org.openssl.winstore://". In TclTLS 2.0, this is the default value if -cadir, -cadir, and -castore are not specified.

  • If OpenSSL is not installed or the CA certificates are not available in PEM format, the CA certificates must be downloaded and installed with the user @@ -750,23 +760,23 @@

    alpn channelId protocol match

    For servers, this form of callback is invoked when the client ALPN extension is received. If match is true, then protocol is the first -alpn protocol option in common to both the client and server. If not, the first client specified protocol is used. This callback is called -after the Hello and ALPN callbacks.

    -
    hello channelId servername
    +after the Hello and SNI callbacks.

    +
    hello channelId servername session_id

    For servers, this form of callback is invoked during client hello message processing. The purpose is so the server can select the appropriate certificate to present to the client, and to make other configuration adjustments relevant to that server name and its configuration. It is called before the SNI and ALPN callbacks.

    sni channelId servername

    For servers, this form of callback is invoked when the Server Name Indication (SNI) extension is received. The servername argument is the client -provided server name specified in the -servername</b> option. The +provided server name specified in the -servername option. The purpose is so when a server supports multiple names, the right certificate -can be used. It is called after the hello callback but before the ALPN +can be used. It is called after the Hello callback but before the ALPN callback.

    verify channelId depth cert status error

    This form of callback is invoked by OpenSSL when a new certificate is received from the peer. It allows the client to check the certificate verification results and choose whether to continue or not. It is called for each @@ -870,12 +880,32 @@

Special Considerations

The capabilities of this package can vary enormously based upon how the linked to OpenSSL library was configured and built. New versions may obsolete older protocol versions, add or remove ciphers, change default values, etc. -Use the tls::protocols commands to obtain the supported +Use the tls::protocols command to obtain the supported protocol versions.

+
+

Error Messages

+

Some OpsnSSl error messages have cryptic meanings. This is a list of messages +along with their true meaning.

+
+
handshake failed: certificate verify failed due to "unable to get local issuer certificate"
+

The certificates in the CA file or certificate store either do not have one or +more issuers of the certificates you are validating or they have expired. +Usually this means you need an updated CAcert file.

+
packet length too long
+

Client has tried to connect to a HTTP server on the plain-text port instead of +the SSL/TLS port.

+
unexpected eof while reading
+

The peer has closed the connection without sending the "close notify" shutdown +alert. Some servers will terminate the connection after the file or webpage has +been sent without sending the "close notify" message. In this case, it should +not result in a loss of data.

+
wrong version number
+

Client has tried to connect to a non-HTTP server on a non-TLS (i.e. plain text) port.

+

See Also

OpenSSL, http, socket

Keywords

Index: doc/tls.man ================================================================== --- doc/tls.man +++ doc/tls.man @@ -1,38 +1,37 @@ [comment {-*- tcl -*- doctools manpage}] [comment {To convert this to another documentation format use the dtplite script from tcllib: dtplite -o tls.n nroff tls.man dtplite -o tls.html html tls.man }] -[manpage_begin tls n 2.0b1] +[manpage_begin tls n 2.0b2] [category tls] [copyright {1999 Matt Newman}] [copyright {2004 Starfish Systems}] [copyright {2024 Brian O'Hagan}] [keywords tls I/O "IP Address" OpenSSL SSL TCP TLS "asynchronous I/O" bind certificate channel connection "domain name" host "https" "network address" network socket TclTLS] [moddesc {Tcl TLS extension}] [see_also http socket [uri https://www.openssl.org/ OpenSSL]] [titledesc {binding to the OpenSSL library for encrypted socket and I/O channel communications}] [require Tcl 8.5-] -[require tls 2.0b1] +[require tls 2.0b2] [description] -This extension provides TCL script access to secure socket communications -using the Transport Layer Security (TLS) protocol. It provides a generic -binding to [uri "https://www.openssl.org/" OpenSSL], utilizing the -[syscmd Tcl_StackChannel] API in TCL 8.4 and higher. -These sockets behave exactly the same as channels created using the built-in -[syscmd socket] command, but provide additional options for controlling -the SSL/TLS session. +This extension provides TCL script access to Secure Socket Layer (SSL) +communications using the Transport Layer Security (TLS) protocol. It provides a +generic binding to [uri "https://www.openssl.org/" OpenSSL], utilizing the +[syscmd Tcl_StackChannel] API in TCL 8.4 or later. These sockets behave exactly +the same as channels created using the built-in [syscmd socket] command, but +provide additional options for controlling the SSL/TLS session. [section Compatibility] This extension is compatible with OpenSSL 1.1.1 or later. It requires Tcl version 8.5 or later and will work with Tcl 9.0. [section Commands] -The following are the commands provided by the TcLTLS package. See the +The following are the commands provided by the TcLTLS package. See [sectref Examples] for example usage and the [file demos] directory for more example usage. [list_begin definitions] @@ -39,19 +38,19 @@ [call [cmd tls::init] [opt [arg -option]] [opt [arg value]] [opt [arg "-option value ..."]]] Optional function to set the default options used by [cmd tls::socket]. If you call [cmd tls::import] directly, the values set by this command have no effect. This command supports all of the same options as the [cmd tls::socket] command, -though you should limit your options to only TLS related ones. +though you should limit your options to only the TLS related ones. [call [cmd tls::socket] [opt [arg -option]] [opt [arg value]] [opt [arg "-option value ..."]] [arg host] [arg port]] This is a helper function that utilizes the underlying commands [syscmd socket] and [cmd tls::import] to create the connection. It behaves the same as the -native TCL [syscmd socket] command, but also supports the [cmd tls:import] +native TCL [syscmd socket] command, but also supports the [cmd tls::import] command options with one additional option. It returns the channel handle id -for the new socket. +for the new socket. Additional options are: [list_begin options] [opt_def -autoservername [arg bool]] If [const true], automatically set the [option -servername] argument to the @@ -61,15 +60,17 @@ [list_end] [call [cmd tls::socket] [option -server] [arg command] [opt [arg -option]] [opt [arg value]] [opt [arg "-option value ..."]] [arg port]] -Same as previous, but instead creates a server socket for clients to connect to -just like the Tcl [syscmd "socket -server"] command. It returns the channel -handle id for the new socket. +Same as previous command, but instead creates a server socket for clients to +connect to just like the Tcl [syscmd "socket -server"] command. It returns the +channel handle id for the new socket. [call [cmd tls::import] [arg channel] [opt [arg -option]] [opt [arg value]] [opt [arg "-option value ..."]]] + +[call [cmd tls::starttls] [arg channel] [opt [arg -option]] [opt [arg value]] [opt [arg "-option value ..."]]] Start TLS encryption on TCL channel [arg channel] via a stacked channel. It need not be a socket, but must provide bi-directional flow. Also sets session parameters for SSL handshake. Valid options are: @@ -134,11 +135,11 @@ [opt_def -dhparams [arg filename]] Specifies the Diffie-Hellman (DH) parameters file. [opt_def -keyfile [arg filename]] Specifies the private key file. The default is to use the file -specified by the [arg -certfile] option. +specified by the [option -certfile] option. [opt_def -key [arg string]] Specifies the private key to use as a DER encoded string (PKCS#1 DER). [opt_def -model [arg channel]] @@ -155,22 +156,23 @@ Allow post-handshake session ticket updates. This option is new for TclTLS 1.8. [opt_def -request [arg bool]] Request a certificate from the peer during the SSL handshake. This is needed to do Certificate Validation. Starting in TclTLS 1.8, the default is -[const true]. Starting in TclTLS 2.0, If set to [const false] and -[option -require] is [const true], then this will be overridden to [const true]. +[const true] for client connections. Starting in TclTLS 2.0, if set to +[const false] and [option -require] is [const true], then this will be +overridden to [const true]. See [sectref "Certificate Validation"] for more details. [opt_def -require [arg bool]] Require a valid certificate from the peer during the SSL handshake. If this is set to true, then [option -request] must also be set to true and a either [option -cadir], [option -cafile], [option -castore], or a platform default must be provided in order to validate against. The default in TclTLS 1.8 and earlier versions is [const false] since not all platforms have certificates to validate against in a form compatible with OpenSSL. Starting in TclTLS 2.0, -the default is [const true]. +the default is [const true] for client connections. See [sectref "Certificate Validation"] for more details. [opt_def -security_level [arg integer]] Specifies the security level (value from 0 to 5). The security level affects the allowed cipher suite encryption algorithms, supported ECC curves, @@ -186,11 +188,11 @@ [opt_def -servername [arg hostname]] Specify the peer's hostname. This is used to set the TLS Server Name Indication (SNI) extension. Set this to the expected servername in the server's certificate or one of the Subject Alternate Names (SAN). Starting in TclTLS 2.0, this will -default to the host for the [cmd tls::socket] command. +default to the host from the [cmd tls::socket] command. [opt_def -session_id [arg binary_string]] Specifies the session id to resume a session. Not supported yet. This option is new for TclTLS 1.8. @@ -205,16 +207,16 @@ See the [cmd tls::protocols] command for supported protocols. [opt_def -tls1 [arg bool]] Enable use of TLS v1. Starting in TclTLS 2.0, the default is [const false]. Note: TLS 1.0 needs SHA1 to operate, which is only available in security level -0 for Open SSL 3.0+. See the [arg -security_level] option. +0 for Open SSL 3.0+. See the [option -security_level] option. [opt_def -tls1.1 [arg bool]] Enable use of TLS v1.1. Starting in TclTLS 2.0, the default is [const false]. Note: TLS 1.1 needs SHA1 to operate, which is only available in security level -0 for Open SSL 3.0+. See the [arg -security_level] option. +0 for Open SSL 3.0+. See the [option -security_level] option. [opt_def -tls1.2 [arg bool]] Enable use of TLS v1.2. The default is [const true]. [opt_def -tls1.3 [arg bool]] @@ -229,29 +231,34 @@ to continue the negotiation. See [sectref "Callback Options"] for more info. This option is new for TclTLS 1.8. [list_end] -[call [cmd tls::unimport] [arg channel]] - -Compliment to [cmd tls::import]. Used to remove the top level stacked channel -from [arg channel]. This unstacks the encryption of a regular TCL channel. An -error is thrown if TLS is not the top stacked channel type. - [call [cmd tls::handshake] [arg channel]] Forces the TLS negotiation handshake to take place immediately, and returns 0 if handshake is still in progress (non-blocking), or 1 if the handshake was successful. If the handshake failed, an error will be returned. +[call [cmd tls::shutdown] [arg channel]] + +[call [cmd tls::unimport] [arg channel]] + +[call [cmd tls::unstack] [arg channel]] + +This terminates the SSL/TLS session by sending the "close_notify" message and +removes the top level stacked channel from [arg channel], but it does not close +the socket. It is the compliment to [cmd tls::import] by ending encryption of +a TCL channel. An error is thrown if TLS is not the top stacked channel type. + [call [cmd tls::status] [opt [option -local]] [arg channel]] Returns the current status of an SSL channel. The result is a list of key-value pairs describing the SSL, certificate, and certificate verification status. If the SSL handshake has not yet completed, an empty list is returned. If the -[option -local] option is specified, then the local certificate is used. Returned -values include: +[option -local] option is specified, then the local certificate is used. +Returned values include: [para] SSL Status @@ -568,11 +575,11 @@ certificate and that certificate is authenticated (i.e. signed) by a Certificate Authority (CA). Users can then exchange these certificates during the TLS initialization process and check them against the root CA certificates to ensure they are valid. This is handled by OpenSSL via the [option -request] and [option -require] options. See the [option -cadir], [option -cadir], and -[option -castore] options for how tp specify where to find the CA certificates. +[option -castore] options for how to specify where to find the CA certificates. Optionally, in a future release, they can also be checked against the Certificate Revocation List (CRL) of revoked certificates. Certificates can also be self-signed, but they are by default not trusted unless you add them to your certificate store. [para] @@ -605,29 +612,28 @@ Specifies the Uniform Resource Identifier (URI) for the Certificate Authority (CA) store, which may be a single container or a catalog of containers. Starting with OpenSSL 3.2 on MS Windows, set to "[const "org.openssl.winstore://"]" to use the built-in MS Windows Certificate Store. Starting in TclTLS 2.0, this is the default if [option -cadir], [option -cadir], and [option -castore] are -not specified. This store only supports root certificate stores. See -[sectref "Certificate Validation"] for more details. +not specified. This store only supports root certificate stores. [opt_def -request [arg bool]] Request a certificate from the peer during the SSL handshake. This is needed to do Certificate Validation. Starting in TclTLS 1.8, the default is -[const true]. Starting in TclTLS 2.0, If set to [const false] and -[option -require] is [const true], then this will be overridden to [const true]. -In addition, the client can manually inspect and accept or reject -each certificate using the [arg -validatecommand] option. +[const true] for client connections. Starting in TclTLS 2.0, if set to +[const false] and [option -require] is [const true], then this will be +overridden to [const true]. In addition, the client can manually inspect and +accept or reject each certificate using the [option -validatecommand] option. [opt_def -require [arg bool]] Require a valid certificate from the peer during the SSL handshake. If this is set to true, then [option -request] must also be set to true and a either [option -cadir], [option -cafile], [option -castore], or a platform default must be provided in order to validate against. The default in TclTLS 1.8 and earlier versions is [const false] since not all platforms have certificates to validate against in a form compatible with OpenSSL. Starting in TclTLS 2.0, -the default is [const true]. +the default is [const true] for client connections. [list_end] [subsection "When are command line options needed?"] @@ -634,13 +640,13 @@ In TclTLS 1.8 and earlier versions, certificate validation is [emph NOT] enabled by default. This limitation is due to the lack of a common cross platform database of Certificate Authority (CA) provided certificates to validate against. Many Linux systems natively support OpenSSL and thus have these certificates installed as part of the OS, but MacOS and MS Windows do not. -Staring in TclTLS 2.0, this has been changed to require certificate validation -by default. In order to use the [option -require] option, one of the following -must be true: +Staring in TclTLS 2.0, the default for client connections has been changed to +require certificate validation by default. In order to use the [option -require] +option, one of the following must be true: [list_begin itemized] [item] On Linux and Unix systems with OpenSSL already installed or if the CA @@ -655,11 +661,11 @@ [var SSL_CERT_FILE] environment variables or the one of the [option -cadir], [option -cadir], or [option -castore] options must be defined. [item] On MS Windows, starting in OpenSSL 3.2, it is now possible to access the -built-in Windows Certificate Store from OpenSSL. This can utilized by +built-in Windows Certificate Store from OpenSSL. This can be utilized by setting the [option -castore] option to "[const org.openssl.winstore://]". In TclTLS 2.0, this is the default value if [option -cadir], [option -cadir], and [option -castore] are not specified. [item] @@ -815,25 +821,25 @@ [opt_def alpn [arg "channelId protocol match"]] For servers, this form of callback is invoked when the client ALPN extension is received. If [arg match] is true, then [arg protocol] is the first [option -alpn] protocol option in common to both the client and server. If not, the first client specified protocol is used. This callback is called -after the Hello and ALPN callbacks. +after the Hello and SNI callbacks. -[opt_def hello [arg "channelId servername"]] +[opt_def hello [arg "channelId servername session_id"]] For servers, this form of callback is invoked during client hello message processing. The purpose is so the server can select the appropriate certificate to present to the client, and to make other configuration adjustments relevant to that server name and its configuration. It is called before the SNI and ALPN callbacks. [opt_def sni [arg "channelId servername"]] For servers, this form of callback is invoked when the Server Name Indication (SNI) extension is received. The [arg servername] argument is the client -provided server name specified in the [option -servername] option. The +provided server name specified in the [option -servername] option. The purpose is so when a server supports multiple names, the right certificate -can be used. It is called after the hello callback but before the ALPN +can be used. It is called after the Hello callback but before the ALPN callback. [opt_def verify [arg "channelId depth cert status error"]] This form of callback is invoked by OpenSSL when a new certificate is received from the peer. It allows the client to check the certificate verification @@ -981,9 +987,36 @@ [section "Special Considerations"] The capabilities of this package can vary enormously based upon how the linked to OpenSSL library was configured and built. New versions may obsolete older protocol versions, add or remove ciphers, change default values, etc. -Use the [cmd tls::protocols] commands to obtain the supported +Use the [cmd tls::protocols] command to obtain the supported protocol versions. + +[section "Error Messages"] + +Some OpsnSSl error messages have cryptic meanings. This is a list of messages +along with their true meaning. + +[list_begin definitions] + +[def [arg "handshake failed: certificate verify failed due to \"unable to get local issuer certificate\""]] +The certificates in the CA file or certificate store either do not have one or +more issuers of the certificates you are validating or they have expired. +Usually this means you need an updated CAcert file. + +[def [arg "packet length too long"]] +Client has tried to connect to a HTTP server on the plain-text port instead of +the SSL/TLS port. + +[def [arg "unexpected eof while reading"]] +The peer has closed the connection without sending the "close notify" shutdown +alert. Some servers will terminate the connection after the file or webpage has +been sent without sending the "close notify" message. In this case, it should +not result in a loss of data. + +[def [arg "wrong version number"]] +Client has tried to connect to a non-HTTP server on a non-TLS (i.e. plain text) port. + +[list_end] [manpage_end] Index: doc/tls.n ================================================================== --- doc/tls.n +++ doc/tls.n @@ -2,11 +2,11 @@ '\" Generated from file 'tls\&.man' by tcllib/doctools with format 'nroff' '\" Copyright (c) 1999 Matt Newman '\" Copyright (c) 2004 Starfish Systems '\" Copyright (c) 2024 Brian O'Hagan '\" -.TH "tls" n 2\&.0b1 tls "Tcl TLS extension" +.TH "tls" n 2\&.0b2 tls "Tcl TLS extension" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. @@ -276,23 +276,29 @@ .SH NAME tls \- binding to the OpenSSL library for encrypted socket and I/O channel communications .SH SYNOPSIS package require \fBTcl 8\&.5-\fR .sp -package require \fBtls 2\&.0b1\fR +package require \fBtls 2\&.0b2\fR .sp \fBtls::init\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? .sp \fBtls::socket\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? \fIhost\fR \fIport\fR .sp \fBtls::socket\fR \fB-server\fR \fIcommand\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? \fIport\fR .sp \fBtls::import\fR \fIchannel\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? .sp -\fBtls::unimport\fR \fIchannel\fR +\fBtls::starttls\fR \fIchannel\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? .sp \fBtls::handshake\fR \fIchannel\fR +.sp +\fBtls::shutdown\fR \fIchannel\fR +.sp +\fBtls::unimport\fR \fIchannel\fR +.sp +\fBtls::unstack\fR \fIchannel\fR .sp \fBtls::status\fR ?\fB-local\fR? \fIchannel\fR .sp \fBtls::connection\fR \fIchannel\fR .sp @@ -302,37 +308,36 @@ .sp \fBtls::version\fR .sp .BE .SH DESCRIPTION -This extension provides TCL script access to secure socket communications -using the Transport Layer Security (TLS) protocol\&. It provides a generic -binding to \fIOpenSSL\fR [https://www\&.openssl\&.org/], utilizing the -\fBTcl_StackChannel\fR API in TCL 8\&.4 and higher\&. -These sockets behave exactly the same as channels created using the built-in -\fBsocket\fR command, but provide additional options for controlling -the SSL/TLS session\&. +This extension provides TCL script access to Secure Socket Layer (SSL) +communications using the Transport Layer Security (TLS) protocol\&. It provides a +generic binding to \fIOpenSSL\fR [https://www\&.openssl\&.org/], utilizing the +\fBTcl_StackChannel\fR API in TCL 8\&.4 or later\&. These sockets behave exactly +the same as channels created using the built-in \fBsocket\fR command, but +provide additional options for controlling the SSL/TLS session\&. .SH COMPATIBILITY This extension is compatible with OpenSSL 1\&.1\&.1 or later\&. It requires Tcl version 8\&.5 or later and will work with Tcl 9\&.0\&. .SH COMMANDS -The following are the commands provided by the TcLTLS package\&. See the +The following are the commands provided by the TcLTLS package\&. See \fBExamples\fR for example usage and the "\fIdemos\fR" directory for more example usage\&. .TP \fBtls::init\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? Optional function to set the default options used by \fBtls::socket\fR\&. If you call \fBtls::import\fR directly, the values set by this command have no effect\&. This command supports all of the same options as the \fBtls::socket\fR command, -though you should limit your options to only TLS related ones\&. +though you should limit your options to only the TLS related ones\&. .TP \fBtls::socket\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? \fIhost\fR \fIport\fR This is a helper function that utilizes the underlying commands \fBsocket\fR and \fBtls::import\fR to create the connection\&. It behaves the same as the -native TCL \fBsocket\fR command, but also supports the \fBtls:import\fR +native TCL \fBsocket\fR command, but also supports the \fBtls::import\fR command options with one additional option\&. It returns the channel handle id -for the new socket\&. +for the new socket\&. Additional options are: .RS .TP \fB-autoservername\fR \fIbool\fR If \fBtrue\fR, automatically set the \fB-servername\fR argument to the \fIhost\fR argument\&. Prior to TclTLS 2\&.0, the default is \fBfalse\fR\&. @@ -339,15 +344,17 @@ Starting in TclTLS 2\&.0, the default is \fBtrue\fR unless \fB-servername\fR is also specified\&. .RE .TP \fBtls::socket\fR \fB-server\fR \fIcommand\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? \fIport\fR -Same as previous, but instead creates a server socket for clients to connect to -just like the Tcl \fBsocket -server\fR command\&. It returns the channel -handle id for the new socket\&. +Same as previous command, but instead creates a server socket for clients to +connect to just like the Tcl \fBsocket -server\fR command\&. It returns the +channel handle id for the new socket\&. .TP \fBtls::import\fR \fIchannel\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? +.TP +\fBtls::starttls\fR \fIchannel\fR ?\fI-option\fR? ?\fIvalue\fR? ?\fI-option value \&.\&.\&.\fR? Start TLS encryption on TCL channel \fIchannel\fR via a stacked channel\&. It need not be a socket, but must provide bi-directional flow\&. Also sets session parameters for SSL handshake\&. Valid options are: .RS .TP @@ -410,11 +417,11 @@ \fB-dhparams\fR \fIfilename\fR Specifies the Diffie-Hellman (DH) parameters file\&. .TP \fB-keyfile\fR \fIfilename\fR Specifies the private key file\&. The default is to use the file -specified by the \fI-certfile\fR option\&. +specified by the \fB-certfile\fR option\&. .TP \fB-key\fR \fIstring\fR Specifies the private key to use as a DER encoded string (PKCS#1 DER)\&. .TP \fB-model\fR \fIchannel\fR @@ -431,22 +438,23 @@ Allow post-handshake session ticket updates\&. This option is new for TclTLS 1\&.8\&. .TP \fB-request\fR \fIbool\fR Request a certificate from the peer during the SSL handshake\&. This is needed to do Certificate Validation\&. Starting in TclTLS 1\&.8, the default is -\fBtrue\fR\&. Starting in TclTLS 2\&.0, If set to \fBfalse\fR and -\fB-require\fR is \fBtrue\fR, then this will be overridden to \fBtrue\fR\&. +\fBtrue\fR for client connections\&. Starting in TclTLS 2\&.0, if set to +\fBfalse\fR and \fB-require\fR is \fBtrue\fR, then this will be +overridden to \fBtrue\fR\&. See \fBCertificate Validation\fR for more details\&. .TP \fB-require\fR \fIbool\fR Require a valid certificate from the peer during the SSL handshake\&. If this is set to true, then \fB-request\fR must also be set to true and a either \fB-cadir\fR, \fB-cafile\fR, \fB-castore\fR, or a platform default must be provided in order to validate against\&. The default in TclTLS 1\&.8 and earlier versions is \fBfalse\fR since not all platforms have certificates to validate against in a form compatible with OpenSSL\&. Starting in TclTLS 2\&.0, -the default is \fBtrue\fR\&. +the default is \fBtrue\fR for client connections\&. See \fBCertificate Validation\fR for more details\&. .TP \fB-security_level\fR \fIinteger\fR Specifies the security level (value from 0 to 5)\&. The security level affects the allowed cipher suite encryption algorithms, supported ECC curves, @@ -462,11 +470,11 @@ .TP \fB-servername\fR \fIhostname\fR Specify the peer's hostname\&. This is used to set the TLS Server Name Indication (SNI) extension\&. Set this to the expected servername in the server's certificate or one of the Subject Alternate Names (SAN)\&. Starting in TclTLS 2\&.0, this will -default to the host for the \fBtls::socket\fR command\&. +default to the host from the \fBtls::socket\fR command\&. .TP \fB-session_id\fR \fIbinary_string\fR Specifies the session id to resume a session\&. Not supported yet\&. This option is new for TclTLS 1\&.8\&. .TP @@ -481,16 +489,16 @@ See the \fBtls::protocols\fR command for supported protocols\&. .TP \fB-tls1\fR \fIbool\fR Enable use of TLS v1\&. Starting in TclTLS 2\&.0, the default is \fBfalse\fR\&. Note: TLS 1\&.0 needs SHA1 to operate, which is only available in security level -0 for Open SSL 3\&.0+\&. See the \fI-security_level\fR option\&. +0 for Open SSL 3\&.0+\&. See the \fB-security_level\fR option\&. .TP \fB-tls1\&.1\fR \fIbool\fR Enable use of TLS v1\&.1\&. Starting in TclTLS 2\&.0, the default is \fBfalse\fR\&. Note: TLS 1\&.1 needs SHA1 to operate, which is only available in security level -0 for Open SSL 3\&.0+\&. See the \fI-security_level\fR option\&. +0 for Open SSL 3\&.0+\&. See the \fB-security_level\fR option\&. .TP \fB-tls1\&.2\fR \fIbool\fR Enable use of TLS v1\&.2\&. The default is \fBtrue\fR\&. .TP \fB-tls1\&.3\fR \fIbool\fR @@ -504,26 +512,31 @@ default validation provided by OpenSSL\&. The script must return a boolean true to continue the negotiation\&. See \fBCallback Options\fR for more info\&. This option is new for TclTLS 1\&.8\&. .RE .TP -\fBtls::unimport\fR \fIchannel\fR -Compliment to \fBtls::import\fR\&. Used to remove the top level stacked channel -from \fIchannel\fR\&. This unstacks the encryption of a regular TCL channel\&. An -error is thrown if TLS is not the top stacked channel type\&. -.TP \fBtls::handshake\fR \fIchannel\fR Forces the TLS negotiation handshake to take place immediately, and returns 0 if handshake is still in progress (non-blocking), or 1 if the handshake was successful\&. If the handshake failed, an error will be returned\&. .TP +\fBtls::shutdown\fR \fIchannel\fR +.TP +\fBtls::unimport\fR \fIchannel\fR +.TP +\fBtls::unstack\fR \fIchannel\fR +This terminates the SSL/TLS session by sending the "close_notify" message and +removes the top level stacked channel from \fIchannel\fR, but it does not close +the socket\&. It is the compliment to \fBtls::import\fR by ending encryption of +a TCL channel\&. An error is thrown if TLS is not the top stacked channel type\&. +.TP \fBtls::status\fR ?\fB-local\fR? \fIchannel\fR Returns the current status of an SSL channel\&. The result is a list of key-value pairs describing the SSL, certificate, and certificate verification status\&. If the SSL handshake has not yet completed, an empty list is returned\&. If the -\fB-local\fR option is specified, then the local certificate is used\&. Returned -values include: +\fB-local\fR option is specified, then the local certificate is used\&. +Returned values include: .sp SSL Status .RS .TP \fBalpn\fR \fIprotocol\fR @@ -817,11 +830,11 @@ certificate and that certificate is authenticated (i\&.e\&. signed) by a Certificate Authority (CA)\&. Users can then exchange these certificates during the TLS initialization process and check them against the root CA certificates to ensure they are valid\&. This is handled by OpenSSL via the \fB-request\fR and \fB-require\fR options\&. See the \fB-cadir\fR, \fB-cadir\fR, and -\fB-castore\fR options for how tp specify where to find the CA certificates\&. +\fB-castore\fR options for how to specify where to find the CA certificates\&. Optionally, in a future release, they can also be checked against the Certificate Revocation List (CRL) of revoked certificates\&. Certificates can also be self-signed, but they are by default not trusted unless you add them to your certificate store\&. .PP @@ -849,39 +862,38 @@ Specifies the Uniform Resource Identifier (URI) for the Certificate Authority (CA) store, which may be a single container or a catalog of containers\&. Starting with OpenSSL 3\&.2 on MS Windows, set to "\fBorg\&.openssl\&.winstore://\fR" to use the built-in MS Windows Certificate Store\&. Starting in TclTLS 2\&.0, this is the default if \fB-cadir\fR, \fB-cadir\fR, and \fB-castore\fR are -not specified\&. This store only supports root certificate stores\&. See -\fBCertificate Validation\fR for more details\&. +not specified\&. This store only supports root certificate stores\&. .TP \fB-request\fR \fIbool\fR Request a certificate from the peer during the SSL handshake\&. This is needed to do Certificate Validation\&. Starting in TclTLS 1\&.8, the default is -\fBtrue\fR\&. Starting in TclTLS 2\&.0, If set to \fBfalse\fR and -\fB-require\fR is \fBtrue\fR, then this will be overridden to \fBtrue\fR\&. -In addition, the client can manually inspect and accept or reject -each certificate using the \fI-validatecommand\fR option\&. +\fBtrue\fR for client connections\&. Starting in TclTLS 2\&.0, if set to +\fBfalse\fR and \fB-require\fR is \fBtrue\fR, then this will be +overridden to \fBtrue\fR\&. In addition, the client can manually inspect and +accept or reject each certificate using the \fB-validatecommand\fR option\&. .TP \fB-require\fR \fIbool\fR Require a valid certificate from the peer during the SSL handshake\&. If this is set to true, then \fB-request\fR must also be set to true and a either \fB-cadir\fR, \fB-cafile\fR, \fB-castore\fR, or a platform default must be provided in order to validate against\&. The default in TclTLS 1\&.8 and earlier versions is \fBfalse\fR since not all platforms have certificates to validate against in a form compatible with OpenSSL\&. Starting in TclTLS 2\&.0, -the default is \fBtrue\fR\&. +the default is \fBtrue\fR for client connections\&. .PP .SS "WHEN ARE COMMAND LINE OPTIONS NEEDED?" In TclTLS 1\&.8 and earlier versions, certificate validation is \fINOT\fR enabled by default\&. This limitation is due to the lack of a common cross platform database of Certificate Authority (CA) provided certificates to validate against\&. Many Linux systems natively support OpenSSL and thus have these certificates installed as part of the OS, but MacOS and MS Windows do not\&. -Staring in TclTLS 2\&.0, this has been changed to require certificate validation -by default\&. In order to use the \fB-require\fR option, one of the following -must be true: +Staring in TclTLS 2\&.0, the default for client connections has been changed to +require certificate validation by default\&. In order to use the \fB-require\fR +option, one of the following must be true: .IP \(bu On Linux and Unix systems with OpenSSL already installed or if the CA certificates are available in PEM format, and if they are stored in the standard locations, or if the \fBSSL_CERT_DIR\fR or \fBSSL_CERT_FILE\fR environment variables are set, then \fB-cadir\fR, \fB-cadir\fR, @@ -891,11 +903,11 @@ or MS Windows and OpenSSL is installed, the \fBSSL_CERT_DIR\fR and/or \fBSSL_CERT_FILE\fR environment variables or the one of the \fB-cadir\fR, \fB-cadir\fR, or \fB-castore\fR options must be defined\&. .IP \(bu On MS Windows, starting in OpenSSL 3\&.2, it is now possible to access the -built-in Windows Certificate Store from OpenSSL\&. This can utilized by +built-in Windows Certificate Store from OpenSSL\&. This can be utilized by setting the \fB-castore\fR option to "\fBorg\&.openssl\&.winstore://\fR"\&. In TclTLS 2\&.0, this is the default value if \fB-cadir\fR, \fB-cadir\fR, and \fB-castore\fR are not specified\&. .IP \(bu If OpenSSL is not installed or the CA certificates are not available in PEM @@ -1025,25 +1037,25 @@ \fBalpn\fR \fIchannelId protocol match\fR For servers, this form of callback is invoked when the client ALPN extension is received\&. If \fImatch\fR is true, then \fIprotocol\fR is the first \fB-alpn\fR protocol option in common to both the client and server\&. If not, the first client specified protocol is used\&. This callback is called -after the Hello and ALPN callbacks\&. +after the Hello and SNI callbacks\&. .TP -\fBhello\fR \fIchannelId servername\fR +\fBhello\fR \fIchannelId servername session_id\fR For servers, this form of callback is invoked during client hello message processing\&. The purpose is so the server can select the appropriate certificate to present to the client, and to make other configuration adjustments relevant to that server name and its configuration\&. It is called before the SNI and ALPN callbacks\&. .TP \fBsni\fR \fIchannelId servername\fR For servers, this form of callback is invoked when the Server Name Indication (SNI) extension is received\&. The \fIservername\fR argument is the client -provided server name specified in the \fB-servername\fR option\&. The +provided server name specified in the \fB-servername\fR option\&. The purpose is so when a server supports multiple names, the right certificate -can be used\&. It is called after the hello callback but before the ALPN +can be used\&. It is called after the Hello callback but before the ALPN callback\&. .TP \fBverify\fR \fIchannelId depth cert status error\fR This form of callback is invoked by OpenSSL when a new certificate is received from the peer\&. It allows the client to check the certificate verification @@ -1172,12 +1184,34 @@ .CE .SH "SPECIAL CONSIDERATIONS" The capabilities of this package can vary enormously based upon how the linked to OpenSSL library was configured and built\&. New versions may obsolete older protocol versions, add or remove ciphers, change default values, etc\&. -Use the \fBtls::protocols\fR commands to obtain the supported +Use the \fBtls::protocols\fR command to obtain the supported protocol versions\&. +.SH "ERROR MESSAGES" +Some OpsnSSl error messages have cryptic meanings\&. This is a list of messages +along with their true meaning\&. +.TP +\fIhandshake failed: certificate verify failed due to "unable to get local issuer certificate"\fR +The certificates in the CA file or certificate store either do not have one or +more issuers of the certificates you are validating or they have expired\&. +Usually this means you need an updated CAcert file\&. +.TP +\fIpacket length too long\fR +Client has tried to connect to a HTTP server on the plain-text port instead of +the SSL/TLS port\&. +.TP +\fIunexpected eof while reading\fR +The peer has closed the connection without sending the "close notify" shutdown +alert\&. Some servers will terminate the connection after the file or webpage has +been sent without sending the "close notify" message\&. In this case, it should +not result in a loss of data\&. +.TP +\fIwrong version number\fR +Client has tried to connect to a non-HTTP server on a non-TLS (i\&.e\&. plain text) port\&. +.PP .SH "SEE ALSO" \fIOpenSSL\fR [https://www\&.openssl\&.org/], http, socket .SH KEYWORDS I/O, IP Address, OpenSSL, SSL, TCP, TLS, TclTLS, asynchronous I/O, bind, certificate, channel, connection, domain name, host, https, network, network address, socket, tls .SH CATEGORY Index: generic/tls.c ================================================================== --- generic/tls.c +++ generic/tls.c @@ -9,11 +9,11 @@ * Copyright (C) 1997-1999 Matt Newman * some modifications: * Copyright (C) 2000 Ajuba Solutions * Copyright (C) 2002 ActiveState Corporation * Copyright (C) 2004 Starfish Systems - * Copyright (C) 2023 Brian O'Hagan + * Copyright (C) 2023-2025 Brian O'Hagan * * Additional credit is due for Andreas Kupries (a.kupries@westend.com), for * providing the Tcl_ReplaceChannel mechanism and working closely with me * to enhance it to support full fileevent semantics. * @@ -31,10 +31,14 @@ #include #include #include #include #include +#if OPENSSL_VERSION_NUMBER < 0x30000000L + #include + #include +#endif /* Min OpenSSL version */ #if OPENSSL_VERSION_NUMBER < 0x10101000L #error "Only OpenSSL v1.1.1 or later is supported" #endif @@ -82,11 +86,11 @@ * Side effects: * Evaluates callback command * *------------------------------------------------------------------- */ - + static int EvalCallback( Tcl_Interp *interp, /* Tcl interpreter */ State *statePtr, /* Client state for TLS socket */ Tcl_Obj *cmdPtr) /* Command to eval as a Tcl object */ @@ -99,18 +103,18 @@ Tcl_Preserve((void *) statePtr); /* Eval callback with success for ok or return value 1, fail for error or return value 0 */ Tcl_ResetResult(interp); code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); - dprintf("EvalCallback: %d", code); + dprintf("EvalCallback code: %d", code); if (code == TCL_OK) { /* Check result for return value */ Tcl_Obj *result = Tcl_GetObjResult(interp); if (result == NULL || Tcl_GetIntFromObj(interp, result, &ok) != TCL_OK) { ok = 1; } - dprintf("Result: %d", ok); + dprintf("Result boolean: %d", ok); } else { /* Error - reject the certificate */ dprintf("Tcl_BackgroundError"); #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6) Tcl_BackgroundError(interp); @@ -137,11 +141,11 @@ * Side effects: * Calls callback (if defined) * *------------------------------------------------------------------- */ - + static void InfoCallback( const SSL *ssl, /* SSL context */ int where, /* Source of info */ int ret) /* message enum */ @@ -214,11 +218,11 @@ * Side effects: * Calls callback (if defined) * *------------------------------------------------------------------- */ - + #ifndef OPENSSL_NO_SSL_TRACE static void MessageCallback( int write_p, /* Message 0=received, 1=sent */ int version, /* TLS version */ @@ -229,11 +233,11 @@ void *arg) /* Client state for TLS socket */ { State *statePtr = (State*)arg; Tcl_Interp *interp = statePtr->interp; Tcl_Obj *cmdPtr; - char *ver, *type; + const char *ver, *type; BIO *bio; char buffer[15000]; Tcl_Size blen = 0; buffer[0] = 0; @@ -364,11 +368,11 @@ * The err field of the currently operative State is set * to a string describing the SSL negotiation failure reason * *------------------------------------------------------------------- */ - + static int VerifyCallback( int ok, /* Verify result */ X509_STORE_CTX *ctx) /* CTX context */ { @@ -434,11 +438,11 @@ * The err field of the currently operative State is set to a * string describing the SSL negotiation failure reason * *------------------------------------------------------------------- */ - + void Tls_Error( State *statePtr, /* Client state for TLS socket */ const char *msg) /* Error message */ { @@ -492,13 +496,13 @@ * Side effects: * none * *------------------------------------------------------------------- */ - + void KeyLogCallback( - const SSL *ssl, /* Client state for TLS socket */ + TCL_UNUSED(const SSL *), /* Client state for TLS socket */ const char *line) /* Key data to be logged */ { char *str = getenv(SSLKEYLOGFILE); FILE *fd; @@ -529,11 +533,11 @@ * Returns: * Password size in bytes or -1 for an error. * *------------------------------------------------------------------- */ - + static int PasswordCallback( char *buf, /* Pointer to buffer to store password in */ int size, /* Buffer length in bytes */ int rwflag, /* Whether password is needed for read or write */ @@ -614,11 +618,11 @@ * 0 = error where session will be immediately removed from the internal cache. * 1 = success where app retains session in session cache, and must call SSL_SESSION_free() when done. * *------------------------------------------------------------------- */ - + static int SessionCallback( SSL *ssl, /* SSL context */ SSL_SESSION *session) /* Session context */ { @@ -687,11 +691,11 @@ * SSL_TLSEXT_ERR_NOACK: ALPN protocol not selected, e.g., because no ALPN * protocols are configured for this connection. The connection continues. * *------------------------------------------------------------------- */ - + static int ALPNCallback( SSL *ssl, /* SSL context */ const unsigned char **out, /* Return buffer to store selected protocol */ unsigned char *outlen, /* Return buffer size */ @@ -709,11 +713,11 @@ if (ssl == NULL || arg == NULL) { return SSL_TLSEXT_ERR_NOACK; } /* Select protocol */ - if (SSL_select_next_proto((unsigned char **) out, outlen, statePtr->protos, statePtr->protos_len, + if (SSL_select_next_proto((unsigned char **) out, outlen, statePtr->protos, (unsigned)statePtr->protos_len, in, inlen) == OPENSSL_NPN_NEGOTIATED) { /* Match found */ res = SSL_TLSEXT_ERR_OK; } else { /* OPENSSL_NPN_NO_OVERLAP = No overlap, so use first item from client protocol list */ @@ -762,11 +766,11 @@ * SSL_TLSEXT_ERR_OK: NPN protocol selected. The connection continues. * SSL_TLSEXT_ERR_NOACK: NPN protocol not selected. The connection continues. * *------------------------------------------------------------------- */ - + #ifdef USE_NPN static int NPNCallback( const SSL *ssl, /* SSL context */ const unsigned char **out, /* Return buffer to store selected protocol */ @@ -799,10 +803,12 @@ * * SNI Callback for Servers -- * * Perform server-side SNI hostname selection after receiving SNI extension * in Client Hello. Called after hello callback but before ALPN callback. + * This callback is mostly superseded by the ClientHello callback. Used to + * acknowledge the server name requested by the client. * * Results: * None * * Side effects: @@ -817,11 +823,11 @@ * SSL_TLSEXT_ERR_NOACK: SNI hostname is not accepted and not acknowledged, * e.g. if SNI has not been configured. The connection continues. * *------------------------------------------------------------------- */ - + static int SNICallback( const SSL *ssl, /* SSL context */ int *alert, /* Returned alert message */ void *arg) /* Client state for TLS socket */ @@ -837,11 +843,13 @@ if (ssl == NULL || arg == NULL) { return SSL_TLSEXT_ERR_NOACK; } /* Only works for TLS 1.2 and earlier */ - servername = SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name); + if (SSL_get_servername_type(ssl) == TLSEXT_NAMETYPE_host_name) { + servername = SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name); + } if (!servername || servername[0] == '\0') { return SSL_TLSEXT_ERR_NOACK; } if (statePtr->vcmd == (Tcl_Obj*)NULL) { @@ -894,11 +902,11 @@ * SSL_CLIENT_HELLO_ERROR: failure, terminate connection. Set alert to error code. * SSL_CLIENT_HELLO_SUCCESS: success * *------------------------------------------------------------------- */ - + static int HelloCallback( SSL *ssl, /* SSL context */ int *alert, /* Returned alert message */ void *arg) /* Client state for TLS socket */ @@ -906,63 +914,73 @@ State *statePtr = (State*)arg; Tcl_Interp *interp = statePtr->interp; Tcl_Obj *cmdPtr; int code, res; const char *servername; - const unsigned char *p; - size_t len, remaining; + const unsigned char *p, *session_id; + size_t len, remaining, len2; dprintf("Called"); if (statePtr->vcmd == (Tcl_Obj*)NULL) { return SSL_CLIENT_HELLO_SUCCESS; } else if (ssl == (const SSL *)NULL || arg == NULL) { return SSL_CLIENT_HELLO_ERROR; } - /* Get names */ - if (!SSL_client_hello_get0_ext(ssl, TLSEXT_TYPE_server_name, &p, &remaining) || remaining <= 2) { - *alert = SSL_R_SSLV3_ALERT_ILLEGAL_PARAMETER; - return SSL_CLIENT_HELLO_ERROR; - } - - /* Extract the length of the supplied list of names. */ - len = (*(p++) << 8); - len += *(p++); - if (len + 2 != remaining) { - *alert = SSL_R_SSLV3_ALERT_ILLEGAL_PARAMETER; - return SSL_CLIENT_HELLO_ERROR; - } - remaining = len; - - /* The list in practice only has a single element, so we only consider the first one. */ - if (remaining == 0 || *p++ != TLSEXT_NAMETYPE_host_name) { - *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; - return SSL_CLIENT_HELLO_ERROR; - } - remaining--; - - /* Now we can finally pull out the byte array with the actual hostname. */ - if (remaining <= 2) { - *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; - return SSL_CLIENT_HELLO_ERROR; - } - len = (*(p++) << 8); - len += *(p++); - if (len + 2 > remaining) { - *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; - return SSL_CLIENT_HELLO_ERROR; - } - remaining = len; - servername = (const char *)p; - - /* Create command to eval with fn, chan, and server name args */ + /* Get server name */ + if (SSL_client_hello_get0_ext(ssl, TLSEXT_TYPE_server_name, &p, &remaining)) { + /* Check if there is sufficient data to extract */ + if (remaining <= 2) { + *alert = SSL_R_SSLV3_ALERT_ILLEGAL_PARAMETER; + return SSL_CLIENT_HELLO_ERROR; + } + + /* Extract the length of the supplied list of names. */ + len = (size_t)(*(p++) << 8); + len += *(p++); + if (len + 2 != remaining) { + *alert = SSL_R_SSLV3_ALERT_ILLEGAL_PARAMETER; + return SSL_CLIENT_HELLO_ERROR; + } + remaining = len; + + /* The list in practice only has a single element, so we only consider the first one. */ + if (remaining == 0 || *p++ != TLSEXT_NAMETYPE_host_name) { + *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; + return SSL_CLIENT_HELLO_ERROR; + } + remaining--; + + /* Now we can finally pull out the byte array with the actual hostname. */ + if (remaining <= 2) { + *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; + return SSL_CLIENT_HELLO_ERROR; + } + len = (size_t)(*(p++) << 8); + len += *(p++); + if (len + 2 > remaining) { + *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; + return SSL_CLIENT_HELLO_ERROR; + } + remaining = len; + servername = (const char *)p; + } else { + servername = ""; + len = 0; + } + + /* Get session id from Client Hello */ + len2 = SSL_client_hello_get0_session_id(ssl, &session_id); + + /* Create command to eval with fn, chan, server name, and session id */ cmdPtr = Tcl_DuplicateObj(statePtr->vcmd); Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("hello", -1)); Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1)); Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(servername, (Tcl_Size) len)); + Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(session_id, (Tcl_Size) len2)); /* Eval callback command */ Tcl_IncrRefCount(cmdPtr); if ((code = EvalCallback(interp, statePtr, cmdPtr)) > 1) { res = SSL_CLIENT_HELLO_RETRY; @@ -995,11 +1013,11 @@ * Side effects: * constructs and destroys SSL context (CTX) * *------------------------------------------------------------------- */ - + static const char *protocols[] = { "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL }; enum protocol { TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE @@ -1015,87 +1033,96 @@ Tcl_Obj *objPtr = NULL; SSL_CTX *ctx = NULL; SSL *ssl = NULL; STACK_OF(SSL_CIPHER) *sk; char buf[BUFSIZ]; - int index, verbose = 0, use_supported = 0; - const SSL_METHOD *method; + int index, verbose = 0, use_supported = 0, version = 0; + const SSL_METHOD *method = TLS_method(); dprintf("Called"); - if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose? ?supported?"); + if ((objc < 1) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "?protocol? ?verbose? ?supported?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], protocols, "protocol", 0, &index) != TCL_OK) { - return TCL_ERROR; + + if (objc > 1) { + if (Tcl_GetIndexFromObj(interp, objv[1], protocols, "protocol", 0, &index) != TCL_OK) { + return TCL_ERROR; + } else { + switch ((enum protocol)index) { + case TLS_SSL2: +#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2) + version = -1; +#else + version = SSL2_VERSION; +#endif + break; + case TLS_SSL3: +#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3) + version = -1; +#else + version = SSL3_VERSION; +#endif + break; + case TLS_TLS1: +#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1) + version = -1; +#else + version = TLS1_VERSION; +#endif + break; + case TLS_TLS1_1: +#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1) + version = -1; +#else + version = TLS1_1_VERSION; +#endif + break; + case TLS_TLS1_2: +#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2) + version = -1; +#else + version = TLS1_2_VERSION; +#endif + break; + case TLS_TLS1_3: +#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3) + version = -1; +#else + version = TLS1_3_VERSION; +#endif + break; + default: + version = -1; + } + } + + if (version < 0) { + Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); + return TCL_ERROR; + } } + if ((objc > 2) && Tcl_GetBooleanFromObj(interp, objv[2], &verbose) != TCL_OK) { return TCL_ERROR; } + if ((objc > 3) && Tcl_GetBooleanFromObj(interp, objv[3], &use_supported) != TCL_OK) { return TCL_ERROR; } ERR_clear_error(); - switch ((enum protocol)index) { - case TLS_SSL2: -#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2) - Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); - return TCL_ERROR; -#else - method = SSLv2_method(); break; -#endif - case TLS_SSL3: -#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3) || defined(OPENSSL_NO_SSL3_METHOD) - Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); - return TCL_ERROR; -#else - method = SSLv3_method(); break; -#endif - case TLS_TLS1: -#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1) || defined(OPENSSL_NO_TLS1_METHOD) - Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); - return TCL_ERROR; -#else - method = TLSv1_method(); break; -#endif - case TLS_TLS1_1: -#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1_METHOD) - Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); - return TCL_ERROR; -#else - method = TLSv1_1_method(); break; -#endif - case TLS_TLS1_2: -#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2_METHOD) - Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); - return TCL_ERROR; -#else - method = TLSv1_2_method(); break; -#endif - case TLS_TLS1_3: -#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3) - Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); - return TCL_ERROR; -#else - method = TLS_method(); - SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION); - SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION); - break; -#endif - default: - method = TLS_method(); - break; - } - ctx = SSL_CTX_new(method); if (ctx == NULL) { Tcl_AppendResult(interp, GET_ERR_REASON(), (char *)NULL); return TCL_ERROR; } + + SSL_CTX_set_min_proto_version(ctx, version); + SSL_CTX_set_max_proto_version(ctx, version); ssl = SSL_new(ctx); if (ssl == NULL) { Tcl_AppendResult(interp, GET_ERR_REASON(), (char *)NULL); SSL_CTX_free(ctx); @@ -1138,10 +1165,12 @@ } } if (use_supported) { sk_SSL_CIPHER_free(sk); } + } else { + objPtr = Tcl_NewStringObj("",0); } SSL_free(ssl); SSL_CTX_free(ctx); Tcl_SetObjResult(interp, objPtr); @@ -1350,11 +1379,11 @@ char *session_id = NULL; Tcl_Obj *alpn = NULL; int ssl2 = 0, ssl3 = 0; int tls1 = 0, tls1_1 = 0, tls1_2 = 1, tls1_3 = 1; int proto = 0, level = -1; - int verify = 0, require = 1, request = 1, post_handshake = 0; + int verify = 0, require = -1, request = -1, post_handshake = 0; dprintf("Called"); #if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1) tls1 = 0; @@ -1423,15 +1452,25 @@ OPTBAD("option", "-alpn, -cadir, -cafile, -castore, -cert, -certfile, -cipher, -ciphersuites, -command, -dhparams, -key, -keyfile, -model, -password, -post_handshake, -request, -require, -security_level, -server, -servername, -session_id, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, -tls1.3, or -validatecommand"); return TCL_ERROR; } + + /* For client, request and require default to true, server default is false */ + if (!server) { + if (request == -1) request = 1; + if (require == -1) require = 1; + } else { + if (request == -1) request = 0; + if (require == -1) require = 0; + } + if (require) request = 1; if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; if (request && post_handshake) verify |= SSL_VERIFY_POST_HANDSHAKE; - if (verify == 0) verify = SSL_VERIFY_NONE; + if (!verify) verify = SSL_VERIFY_NONE; proto |= (ssl2 ? TLS_PROTO_SSL2 : 0); proto |= (ssl3 ? TLS_PROTO_SSL3 : 0); proto |= (tls1 ? TLS_PROTO_TLS1 : 0); proto |= (tls1_1 ? TLS_PROTO_TLS1_1 : 0); @@ -1612,14 +1651,14 @@ /* Enable Application-Layer Protocol Negotiation. Examples are: http/1.0, http/1.1, h2, h3, ftp, imap, pop3, xmpp-client, xmpp-server, mqtt, irc, etc. */ if (alpn) { /* Convert a TCL list into a protocol-list in wire-format */ - unsigned char *protos, *p; - unsigned int protos_len = 0; + unsigned char *protos = NULL, *p; + size_t protos_len = 0; Tcl_Size cnt, i; - int j; + int res = TCL_OK; Tcl_Obj **list; if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) { Tls_Free((tls_free_type *) statePtr); return TCL_ERROR; @@ -1629,33 +1668,44 @@ for (i = 0; i < cnt; i++) { Tcl_GetStringFromObj(list[i], &len); if (len > 255) { Tcl_AppendResult(interp, "ALPN protocol names too long", (char *)NULL); Tcl_SetErrorCode(interp, "TLS", "IMPORT", "ALPN", "FAILED", (char *)NULL); - Tls_Free((tls_free_type *) statePtr); - return TCL_ERROR; + res = TCL_ERROR; + goto done; } - protos_len += 1 + (int) len; + protos_len += 1 + (size_t)len; } /* Build the complete protocol-list */ - protos = ckalloc(protos_len); + protos = (unsigned char *)ckalloc(protos_len); /* protocol-lists consist of 8-bit length-prefixed, byte strings */ - for (j = 0, p = protos; j < cnt; j++) { - char *str = Tcl_GetStringFromObj(list[j], &len); + for (i = 0, p = protos; i < cnt; i++) { + char *str = Tcl_GetStringFromObj(list[i], &len); *p++ = (unsigned char) len; memcpy(p, str, (size_t) len); p += len; } /* SSL_set_alpn_protos makes a copy of the protocol-list */ /* Note: This function reverses the return value convention */ - if (SSL_set_alpn_protos(statePtr->ssl, protos, protos_len)) { + if (SSL_set_alpn_protos(statePtr->ssl, protos, (unsigned)protos_len)) { Tcl_AppendResult(interp, "Set ALPN protocols failed: ", GET_ERR_REASON(), (char *)NULL); Tcl_SetErrorCode(interp, "TLS", "IMPORT", "ALPN", "FAILED", (char *)NULL); + res = TCL_ERROR; + } + +done: for (i = 0; i < cnt; i++) { + Tcl_IncrRefCount(list[i]); + Tcl_DecrRefCount(list[i]); + } + + if (res != TCL_OK) { Tls_Free((tls_free_type *) statePtr); - ckfree(protos); + if (protos != NULL) { + ckfree(protos); + } return TCL_ERROR; } /* Store protocols list */ statePtr->protos = protos; @@ -1707,10 +1757,11 @@ } /* Set server mode */ statePtr->flags |= TLS_TCL_SERVER; SSL_set_accept_state(statePtr->ssl); + } else { /* Client callbacks */ #ifdef USE_NPN if (statePtr->protos != NULL && tls1_2 == 0 && tls1_3 == 0) { SSL_CTX_set_next_proto_select_cb(statePtr->ctx, ALPNCallback, (void *)statePtr); @@ -1845,11 +1896,11 @@ * Side effects: * Loads CA certificates * *------------------------------------------------------------------- */ - + static int TlsLoadClientCAFileFromMemory( Tcl_Interp *interp, /* Tcl interpreter */ SSL_CTX *ctx, /* CTX context */ Tcl_Obj *file) /* CA certificates filename */ @@ -1878,11 +1929,11 @@ goto cleanup; } Tcl_Close(interp, in); data = (const void *) Tcl_GetByteArrayFromObj(buf, &len); - bio = BIO_new_mem_buf(data, len); + bio = BIO_new_mem_buf(data, (int)len); if (bio == NULL) { goto cleanup; } /* Where the certs go */ @@ -1984,139 +2035,75 @@ char *DHparams) /* DH parameters */ { Tcl_Interp *interp = statePtr->interp; SSL_CTX *ctx = NULL; Tcl_DString ds; - int off = 0, abort = 0; + uint64_t off = 0; + int abort = 0; int load_private_key; const SSL_METHOD *method; - - dprintf("Called"); - - if (!proto) { - Tcl_AppendResult(interp, "no valid protocol selected", (char *)NULL); - return NULL; - } - - /* create SSL context */ -#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2) - if (ENABLED(proto, TLS_PROTO_SSL2)) { - Tcl_AppendResult(interp, "SSL2 protocol not supported", (char *)NULL); - return NULL; - } -#endif -#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3) - if (ENABLED(proto, TLS_PROTO_SSL3)) { - Tcl_AppendResult(interp, "SSL3 protocol not supported", (char *)NULL); - return NULL; - } -#endif -#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1) - if (ENABLED(proto, TLS_PROTO_TLS1)) { - Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", (char *)NULL); - return NULL; - } -#endif -#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1) - if (ENABLED(proto, TLS_PROTO_TLS1_1)) { - Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", (char *)NULL); - return NULL; - } -#endif -#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2) - if (ENABLED(proto, TLS_PROTO_TLS1_2)) { - Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", (char *)NULL); - return NULL; - } -#endif -#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3) - if (ENABLED(proto, TLS_PROTO_TLS1_3)) { - Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", (char *)NULL); - return NULL; - } -#endif - if (proto == 0) { - /* Use full range */ - SSL_CTX_set_min_proto_version(ctx, 0); - SSL_CTX_set_max_proto_version(ctx, 0); - } - - switch (proto) { -#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2) - case TLS_PROTO_SSL2: - method = isServer ? SSLv2_server_method() : SSLv2_client_method(); - break; -#endif -#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) && !defined(OPENSSL_NO_SSL3_METHOD) - case TLS_PROTO_SSL3: - method = isServer ? SSLv3_server_method() : SSLv3_client_method(); - break; -#endif -#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) && !defined(OPENSSL_NO_TLS1_METHOD) - case TLS_PROTO_TLS1: - method = isServer ? TLSv1_server_method() : TLSv1_client_method(); - break; -#endif -#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1_METHOD) - case TLS_PROTO_TLS1_1: - method = isServer ? TLSv1_1_server_method() : TLSv1_1_client_method(); - break; -#endif -#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2_METHOD) - case TLS_PROTO_TLS1_2: - method = isServer ? TLSv1_2_server_method() : TLSv1_2_client_method(); - break; -#endif -#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) - case TLS_PROTO_TLS1_3: - /* Use the generic method and constraint range after context is created */ - method = isServer ? TLS_server_method() : TLS_client_method(); - break; -#endif - default: - /* Negotiate highest available SSL/TLS version */ - method = isServer ? TLS_server_method() : TLS_client_method(); -#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2) - off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2); -#endif -#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) - off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3); -#endif -#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) - off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1); -#endif -#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1) - off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1); -#endif -#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2) - off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2); -#endif -#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) - off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3); -#endif - break; - } + method = isServer ? TLS_server_method() : TLS_client_method(); + + dprintf("Called"); + + /* Get user defined allowed protocols */ +#if OPENSSL_VERSION_NUMBER < 0x10100000L +#if !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2) + if (!(proto & TLS_PROTO_SSL2)) +#endif + off |= SSL_OP_NO_SSLv2; +#endif + +#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) + if (!(proto & TLS_PROTO_SSL3)) +#endif + off |= SSL_OP_NO_SSLv3; + +#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) + if (!(proto & TLS_PROTO_TLS1)) +#endif + off |= SSL_OP_NO_TLSv1; + +#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1) + if (!(proto & TLS_PROTO_TLS1_1)) +#endif + off |= SSL_OP_NO_TLSv1_1; + +#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2) + if (!(proto & TLS_PROTO_TLS1_2)) +#endif + off |= SSL_OP_NO_TLSv1_2; + +#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) + if (!(proto & TLS_PROTO_TLS1_3)) +#endif + off |= SSL_OP_NO_TLSv1_3; ERR_clear_error(); + /* Create context */ ctx = SSL_CTX_new(method); if (!ctx) { return NULL; } + /* Specify allowed protocol range */ + if (!proto) { + SSL_CTX_set_min_proto_version(ctx, TLS1_2_VERSION); + SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION); + } else { + SSL_CTX_set_min_proto_version(ctx, 0); /* Support all */ + SSL_CTX_set_max_proto_version(ctx, 0); + SSL_CTX_set_options(ctx, off); /* Disable specific protocol versions */ + } + + /* Set crypyo key log file */ if (getenv(SSLKEYLOGFILE)) { SSL_CTX_set_keylog_callback(ctx, KeyLogCallback); } -#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) - if (proto == TLS_PROTO_TLS1_3) { - SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION); - SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION); - } -#endif - - /* Force cipher selection order by server */ + /* Force client cipher selection order to set by server */ if (!isServer) { SSL_CTX_set_options(ctx, SSL_OP_CIPHER_SERVER_PREFERENCE); } #if OPENSSL_VERSION_NUMBER < 0x10100000L @@ -2124,58 +2111,60 @@ #endif SSL_CTX_set_app_data(ctx, (void*)interp); /* remember the interpreter */ SSL_CTX_set_options(ctx, SSL_OP_ALL); /* Enable all SSL bug workarounds */ SSL_CTX_set_options(ctx, SSL_OP_NO_COMPRESSION); /* Disable compression even if supported */ - SSL_CTX_set_options(ctx, off); /* Disable specified protocol versions */ /* Allow writes to report success when less than all records have been written */ SSL_CTX_set_mode(ctx, SSL_MODE_ENABLE_PARTIAL_WRITE); /* Disable attempts to try to process the next record instead of returning after a non-app record. Avoids hangs in blocking mode, when using SSL_read() and a non-application record was sent without any application data. */ /*SSL_CTX_clear_mode(ctx, SSL_MODE_AUTO_RETRY);*/ + /* Set number of sessions to cache */ SSL_CTX_sess_set_cache_size(ctx, 128); - /* Set user defined ciphers, cipher suites, and security level */ + /* Set user defined ciphers and cipher suites */ if ((ciphers != NULL) && !SSL_CTX_set_cipher_list(ctx, ciphers)) { Tcl_AppendResult(interp, "Set ciphers failed: No valid ciphers", (char *)NULL); SSL_CTX_free(ctx); return NULL; } if ((ciphersuites != NULL) && !SSL_CTX_set_ciphersuites(ctx, ciphersuites)) { - Tcl_AppendResult(interp, "Set cipher suites failed: No valid ciphers", (char *)NULL); + Tcl_AppendResult(interp, "Set cipher suites failed: No valid cipher suites", (char *)NULL); SSL_CTX_free(ctx); return NULL; } - /* set automatic curve selection */ + /* Set automatic curve selection */ +#if OPENSSL_VERSION_NUMBER < 0x10101000L SSL_CTX_set_ecdh_auto(ctx, 1); +#endif /* Set security level */ if (level > -1 && level < 6) { /* SSL_set_security_level */ SSL_CTX_set_security_level(ctx, level); } - /* set some callbacks */ + /* Set get password callback */ SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback); SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr); - /* read a Diffie-Hellman parameters file, or use the built-in one */ + /* Set Diffie-Hellman parameters from file, or use the built-in one. + * Used by servers requiring ephemeral DH keys. */ Tcl_DStringInit(&ds); #ifdef OPENSSL_NO_DH if (DHparams != NULL) { Tcl_AppendResult(interp, "DH parameter support not available", (char *)NULL); SSL_CTX_free(ctx); return NULL; } #else { - DH* dh; if (DHparams != NULL) { BIO *bio; bio = BIO_new_file(F2N(DHparams, &ds), "r"); if (!bio) { @@ -2183,20 +2172,47 @@ Tcl_AppendResult(interp, "Could not find DH parameters file", (char *)NULL); SSL_CTX_free(ctx); return NULL; } - dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL); +#if OPENSSL_VERSION_NUMBER < 0x30000000L + DH* dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL); + BIO_free(bio); + Tcl_DStringFree(&ds); + if (!dh) { + Tcl_AppendResult(interp, "Could not read DH parameters from file: ", + GET_ERR_REASON(), (char *)NULL); + SSL_CTX_free(ctx); + return NULL; + } + if (!SSL_CTX_set_tmp_dh(ctx, dh)) { + Tcl_AppendResult(interp, "Could not set DH parameters from file: ", + GET_ERR_REASON(), (char *)NULL); + DH_free(dh); + SSL_CTX_free(ctx); + return NULL; + } + DH_free(dh); + dprintf("Diffie-Hellman initialized with %d bit key", 8 * DH_size(dh)); +#else + EVP_PKEY *dh = PEM_read_bio_Parameters(bio, NULL); BIO_free(bio); Tcl_DStringFree(&ds); if (!dh) { - Tcl_AppendResult(interp, "Could not read DH parameters from file", (char *)NULL); + Tcl_AppendResult(interp, "Could not read DH parameters from file: ", + GET_ERR_REASON(), (char *)NULL); + SSL_CTX_free(ctx); + return NULL; + } + if (!SSL_CTX_set0_tmp_dh_pkey(ctx, dh)) { + Tcl_AppendResult(interp, "Could not set DH parameters from file: ", + GET_ERR_REASON(), (char *)NULL); SSL_CTX_free(ctx); return NULL; } - SSL_CTX_set_tmp_dh(ctx, dh); - DH_free(dh); + dprintf("Diffie-Hellman initialized with %d bit key", 8 * EVP_PKEY_get_size(dh)); +#endif } else { /* Use well known DH parameters that have built-in support in OpenSSL */ if (!SSL_CTX_set_dh_auto(ctx, 1)) { Tcl_AppendResult(interp, "Could not enable set DH auto: ", GET_ERR_REASON(), @@ -2206,11 +2222,11 @@ } } } #endif - /* set our certificate */ + /* Set our certificate */ load_private_key = 0; if (certfile != NULL) { load_private_key = 1; if (SSL_CTX_use_certificate_file(ctx, F2N(certfile, &ds), SSL_FILETYPE_PEM) <= 0) { @@ -2241,11 +2257,11 @@ return NULL; #endif } } - /* set our private key */ + /* Set our private key */ if (load_private_key) { if (keyfile == NULL && key == NULL) { keyfile = certfile; } @@ -2341,14 +2357,15 @@ Tcl_Obj *cafileobj = Tcl_NewStringObj(CAfile, -1); Tcl_IncrRefCount(cafileobj); Tcl_Obj *fsinfo = Tcl_FSFileSystemInfo(cafileobj); if (fsinfo) { + Tcl_Obj *fstype = NULL; Tcl_IncrRefCount(fsinfo); - Tcl_Obj *fstype = NULL; Tcl_ListObjIndex(interp, fsinfo, 0, &fstype); + Tcl_IncrRefCount(fstype); if (Tcl_StringMatch("native", Tcl_GetString(fstype))) { if (!SSL_CTX_load_verify_file(ctx, F2N(CAfile, &ds))) { abort++; } @@ -2365,10 +2382,11 @@ /* Load certificate into memory */ if (!TlsLoadClientCAFileFromMemory(interp, ctx, cafileobj)) { abort++; } } + Tcl_DecrRefCount(fstype); Tcl_DecrRefCount(fsinfo); } else { abort++; /* Path is not recognized */ } @@ -2394,11 +2412,11 @@ * Side effects: * None. * *------------------------------------------------------------------- */ - + static int StatusObjCmd( TCL_UNUSED(ClientData), /* Client data */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Arg count */ @@ -2410,11 +2428,12 @@ Tcl_Channel chan; char *channelName, *ciphers; int mode; const unsigned char *proto; unsigned int len; - int nid, res; + int nid; + long res; dprintf("Called"); if (objc < 2 || objc > 3 || (objc == 3 && !strcmp(Tcl_GetString(objv[1]), "-local"))) { Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel"); @@ -2438,11 +2457,15 @@ } statePtr = (State *) Tcl_GetChannelInstanceData(chan); /* Get certificate for peer or self */ if (objc == 2) { +#if OPENSSL_VERSION_NUMBER < 0x30000000L peer = SSL_get_peer_certificate(statePtr->ssl); +#else + peer = SSL_get1_peer_certificate(statePtr->ssl); +#endif } else { peer = SSL_get_certificate(statePtr->ssl); } /* Get X509 certificate info */ if (peer) { @@ -2698,11 +2721,15 @@ /* Resumable session */ LAPPEND_BOOL(interp, objPtr, "resumable", SSL_SESSION_is_resumable(session)); /* Session start time (seconds since epoch) */ +#if OPENSSL_VERSION_NUMBER < 0x30300000L LAPPEND_LONG(interp, objPtr, "start_time", SSL_SESSION_get_time(session)); +#else + LAPPEND_WIDE(interp, objPtr, "start_time", SSL_SESSION_get_time_ex(session)); +#endif /* Timeout value - SSL_CTX_get_timeout (in seconds) */ LAPPEND_LONG(interp, objPtr, "timeout", SSL_SESSION_get_timeout(session)); /* Session id - TLSv1.2 and below only */ @@ -2751,11 +2778,11 @@ } /* Server info */ { long mode = SSL_CTX_get_session_cache_mode(statePtr->ctx); - char *msg; + const char *msg; if (mode & SSL_SESS_CACHE_OFF) { msg = "off"; } else if (mode & SSL_SESS_CACHE_CLIENT) { msg = "client"; @@ -2801,11 +2828,11 @@ * Side effects: * None. * *------------------------------------------------------------------- */ - + static int VersionObjCmd( TCL_UNUSED(ClientData), /* Client data */ Tcl_Interp *interp, /* Tcl interpreter */ TCL_UNUSED(int), /* objc - Arg count */ @@ -2832,11 +2859,11 @@ * Side effects: * None. * *------------------------------------------------------------------- */ - + static int MiscObjCmd( TCL_UNUSED(ClientData), /* Client data */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Arg count */ @@ -2844,10 +2871,11 @@ { static const char *commands [] = { "req", "strreq", NULL }; enum command { C_REQ, C_STRREQ, C_DUMMY }; int cmd, isStr; char buffer[16384]; + int res = TCL_OK; dprintf("Called"); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); @@ -2869,11 +2897,11 @@ Tcl_Obj **listv; Tcl_Size listc, i; BIO *out=NULL; - const char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email=""; + Tcl_Obj *k_C=NULL,*k_ST=NULL,*k_L=NULL,*k_O=NULL,*k_OU=NULL,*k_CN=NULL,*k_Email=NULL; char *keyout,*pemout,*str; int keysize,serial=0,days=365; #if OPENSSL_VERSION_NUMBER < 0x30000000L BIGNUM *bne = NULL; @@ -2902,38 +2930,57 @@ return TCL_ERROR; } if ((listc%2) != 0) { Tcl_SetResult(interp,"Information list must have even number of arguments",NULL); - return TCL_ERROR; + res = TCL_ERROR; } for (i=0; itimer != (Tcl_TimerToken) NULL) { Tcl_DeleteTimerHandler(statePtr->timer); statePtr->timer = NULL; + Tcl_Release((ClientData) statePtr); } /* Remove callbacks */ if (statePtr->callback) { Tcl_DecrRefCount(statePtr->callback); @@ -3146,10 +3241,39 @@ statePtr->ctx = NULL; } dprintf("Returning"); } + +/* + *------------------------------------------------------------------- + * + * Tls_Free -- + * + * This procedure cleans up when a SSL socket based channel + * is closed and its reference count falls below 1 + * + * Results: + * none + * + * Side effects: + * Frees all the state + * + *------------------------------------------------------------------- + */ + +void +Tls_Free( + tls_free_type *blockPtr) /* Client state for TLS socket */ +{ + State *statePtr = (State *)blockPtr; + + dprintf("Called"); + + Tls_Clean(statePtr); + ckfree(blockPtr); +} /* *---------------------------------------------------------------------- * * Build Info Command -- @@ -3247,13 +3371,13 @@ * Side effects: * Shutdown SSL library * *------------------------------------------------------* */ - + void TlsLibShutdown( - ClientData clientData) /* Not used */ + TCL_UNUSED(ClientData)) { dprintf("Called"); BIO_cleanup(); } @@ -3271,11 +3395,11 @@ * Side effects: * Initializes SSL library * *------------------------------------------------------* */ - + static int TlsLibInit() { static int initialized = 0; dprintf("Called"); @@ -3348,16 +3472,18 @@ Tcl_CreateObjCommand(interp, "::tls::ciphers", CiphersObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "::tls::connection", ConnectionInfoObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "::tls::handshake", HandshakeObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "::tls::import", ImportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "::tls::unimport", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "::tls::unstack", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "::tls::status", StatusObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "::tls::version", VersionObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "::tls::misc", MiscObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "::tls::protocols", ProtocolsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "::tls::shutdown", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "::tls::starttls", ImportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "::tls::status", StatusObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "::tls::unimport", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "::tls::unstack", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "::tls::version", VersionObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); BuildInfoCommand(interp); if (interp && Tcl_Eval(interp, tlsTclInitScript) != TCL_OK) { return TCL_ERROR; @@ -3379,12 +3505,12 @@ * Side effects: * Same as of 'Tls_Init' * *------------------------------------------------------------------- */ - + DLLEXPORT int Tls_SafeInit( Tcl_Interp *interp) /* Tcl interpreter */ { dprintf("Called"); return Tls_Init(interp); } Index: generic/tlsBIO.c ================================================================== --- generic/tlsBIO.c +++ generic/tlsBIO.c @@ -1,31 +1,31 @@ /* * Provides Custom BIO layer to interface OpenSSL with TCL. These functions * directly interface between the TCL IO channel and BIO buffers. * * Copyright (C) 1997-2000 Matt Newman - * Copyright (C) 2024 Brian O'Hagan + * Copyright (C) 2024-2025 Brian O'Hagan * */ /* - Normal - tlsBIO.c tlsIO.c - +------+ +---+ +---+ - | |Tcl_WriteRaw<--BioOutput|SSL|BIO_write<--TlsOutputProc<--Write| | - |socket| |BIO| |App| - | |Tcl_ReadRaw --> BioInput| |BIO_Read -->TlsInputProc --> Read| | - +------+ +---+ +---+ - - - Fast Path - tlsIO.c - +------+ +-----+ +-----+ - | |<-- write <--| SSL |BIO_write <-- TlsOutputProc <-- Write| | - |socket| | BIO | | App | - | |<-- read <--| |BIO_Read --> TlsInputProc --> Read| | - +------+ +-----+ +-----+ +Normal + tlsBIO.c tlsIO.c + +------+ +-----+ +---+ + | |Tcl_WriteRaw<--BioOutput| SSL |BIO_write<--TlsOutputProc <--puts| | + |socket| | BIO | |App| + | |Tcl_ReadRaw --> BioInput| |BIO_Read -->TlsInputProc --> read| | + +------+ +-----+ +---+ + + +Fast Path + tlsIO.c + +------+ +-----+ +-----+ + | |<-- write <--| SSL |BIO_write <-- TlsOutputProc <-- puts| | + |socket| | BIO | | App | + | |--> read -->| |BIO_Read --> TlsInputProc --> read| | + +------+ +-----+ +-----+ */ #include "tlsInt.h" #include @@ -37,47 +37,54 @@ /* *----------------------------------------------------------------------------- * * BIOShouldRetry -- * - * Determine if should retry operation based on error code. Same - * conditions as BIO_sock_should_retry function. + * Determine if an operation should be retried for non-fatal errors after + * next select/(e)poll. * * Results: * 1 = retry, 0 = no retry * * Side effects: * None * + * Notes: + * We check the same codes as BIO_sock_should_retry and + * BIO_sock_non_fatal_error (EWOULDBLOCK, ENOTCONN, EINTR, EAGAIN, EPROTO, + * EINPROGRESS, and EALREADY) except for ENOTCONN. Newer FreeBSDs return + * ENOTCONN instead of EAGAIN/EWOULDBLOCK when trying to send on a + * non-blocking socket which is not yet fully connected. While TCL core + * uses EWOULDBLOCK if the connect is still in progress, it uses ENOTCONN + * if it failed. So we skip it. + * *----------------------------------------------------------------------------- */ static int BIOShouldRetry(int code) { int res = 0; dprintf("BIOShouldRetry %d=%s", code, Tcl_ErrnoMsg(code)); - if (code == EAGAIN || code == EWOULDBLOCK || code == ENOTCONN || code == EPROTO || -#ifdef _WIN32 - code == WSAEWOULDBLOCK || -#endif - code == EINTR || code == EINPROGRESS || code == EALREADY) { + /* Check for non-blocking retry-able error codes, but skip ENOTCONN */ + if (code == EWOULDBLOCK || code == EINPROGRESS || code == EALREADY || + code == EAGAIN || code == EPROTO || code == EINTR) { res = 1; } - dprintf("BIOShouldRetry %d=%s, res=%d", code, Tcl_ErrnoMsg(code), res); + dprintf("BIOShouldRetry %d=%s, retry=%d", code, Tcl_ErrnoMsg(code), res); return res; } /* *----------------------------------------------------------------------------- * * BioOutput -- * - * This function is used to read encrypted data from the BIO and write it - * into the socket. This function will be called in response to the - * application calling the BIO_write_ex() or BIO_write() functions. + * This function is used to get encrypted data from the BIO in buf and + * write it to the channel. This function will be called in response to + * the tlsIO calling the BIO_write_ex() or BIO_write() functions. * * Results: * Returns the number of bytes written to channel, 0 for EOF, or -1 for * error. * @@ -143,27 +150,20 @@ /* *----------------------------------------------------------------------------- * * BioInput -- * - * This function is used to read encrypted data from the socket and - * write it into the BIO. This function will be called in response to the - * application calling the BIO_read_ex() or BIO_read() functions. + * This function is used to read encrypted data from the channel and pass + * it to the BIO in buf. This function will be called in response to the + * tlsIO calling the BIO_read_ex() or BIO_read() functions. * * Results: * Returns the number of bytes read from channel, 0 for EOF, or -1 for * error. * * Side effects: - * Reads channel data into BIO. - * - * Data is received in whole blocks known as records from the peer. A whole - * record is processed (e.g. decrypted) in one go and is buffered by OpenSSL - * until it is read by the application via a call to SSL_read. SSL_pending() - * returns the number of bytes which have been processed, buffered, and are - * available inside ssl for immediate read. SSL_has_pending() returns 1 if - * data is buffered (whether processed or unprocessed) and 0 otherwise. + * Reads channel data into BIO or sets retry flags. * *----------------------------------------------------------------------------- */ static int BioInput(BIO *bio, char *buf, int bufLen) { @@ -187,11 +187,11 @@ is_eof = Tcl_Eof(chan); tclErrno = Tcl_GetErrno(); is_blocked = Tcl_InputBlocked(chan); - dprintf("[chan=%p] BioInput(%d) -> %" TCL_SIZE_MODIFIER "d [tclEof=%d; blocked=%d; tclErrno=%d: %s]", + dprintf("[chan=%p] BioInput(buf len=%d) -> %" TCL_SIZE_MODIFIER "d [tclEof=%d; blocked=%d; tclErrno=%d: %s]", (void *) chan, bufLen, ret, is_eof, is_blocked, tclErrno, Tcl_ErrnoMsg(tclErrno)); if (ret > 0) { dprintf("Successfully read %" TCL_SIZE_MODIFIER "d bytes of data", ret); @@ -230,14 +230,15 @@ * This function is used to read a NULL terminated string from the BIO and * write it to the channel. This function will be called in response to * the application calling the BIO_puts() function. * * Results: - * Returns the number of bytes written to channel or 0 for error. + * Returns the number of bytes read from channel, 0 for EOF, or -1 for + * error. * * Side effects: - * Writes data to channel. + * Writes data to channel or sets retry flags. * *----------------------------------------------------------------------------- */ static int BioPuts(BIO *bio, const char *str) { @@ -251,11 +252,12 @@ * * BioCtrl -- * * This function is used to process control messages in the BIO. This * function will be called in response to the application calling the - * BIO_ctrl() function. + * BIO_ctrl() function. Several functions wrap BIO_ctrl() such as + * BIO_eof, BIO_flush, BIO_pending, BIO_wpending, etc. * * Results: * Function dependent * * Side effects: @@ -273,98 +275,99 @@ switch (cmd) { case BIO_CTRL_RESET: /* opt - Resets BIO to initial state. Implements BIO_reset. */ dprintf("Got BIO_CTRL_RESET"); - /* Return 1 for success (0 for file BIOs) and -1 for failure */ + /* Return 1 for success (0 for file BIOs) and -1 for failure. */ ret = 0; break; case BIO_CTRL_EOF: /* opt - Returns whether EOF has been reached. Implements BIO_eof. */ dprintf("Got BIO_CTRL_EOF"); - /* Returns 1 if EOF has been reached, 0 if not, or <0 for failure */ + /* Returns 1 if EOF has been reached, 0 if not, or <0 for failure. */ ret = ((chan) ? (Tcl_Eof(chan) || BIO_test_flags(bio, BIO_FLAGS_IN_EOF)) : 1); break; case BIO_CTRL_INFO: - /* opt - extra info on BIO. Implements BIO_get_mem_data */ + /* opt - extra info on BIO. Implements BIO_get_mem_data. */ dprintf("Got BIO_CTRL_INFO"); ret = 0; break; case BIO_CTRL_SET: - /* man - set the 'IO' parameter */ + /* man - set the 'IO' parameter. */ dprintf("Got BIO_CTRL_SET"); ret = 0; break; case BIO_CTRL_GET: - /* man - get the 'IO' parameter */ + /* man - get the 'IO' parameter. */ dprintf("Got BIO_CTRL_GET "); ret = 0; break; case BIO_CTRL_PUSH: - /* opt - internal, used to signify change. Implements BIO_push */ + /* opt - internal, used to signify change. Implements BIO_push. */ dprintf("Got BIO_CTRL_PUSH"); ret = 0; break; case BIO_CTRL_POP: - /* opt - internal, used to signify change. Implements BIO_pop */ + /* opt - internal, used to signify change. Implements BIO_pop. */ dprintf("Got BIO_CTRL_POP"); ret = 0; break; case BIO_CTRL_GET_CLOSE: - /* man - Get the close on BIO_free() flag set by BIO_CTRL_SET_CLOSE. Implements BIO_get_close */ + /* man - Get the close on BIO_free() flag set by BIO_CTRL_SET_CLOSE. Implements BIO_get_close. */ dprintf("Got BIO_CTRL_CLOSE"); - /* Returns BIO_CLOSE, BIO_NOCLOSE, or <0 for failure */ + /* Returns BIO_CLOSE, BIO_NOCLOSE, or <0 for failure. */ ret = BIO_get_shutdown(bio); break; case BIO_CTRL_SET_CLOSE: - /* man - Set the close on BIO_free() flag. Implements BIO_set_close */ + /* man - Set the close on BIO_free() flag. Implements BIO_set_close. */ dprintf("Got BIO_SET_CLOSE"); - BIO_set_shutdown(bio, num); - /* Returns 1 on success or <=0 for failure */ + BIO_set_shutdown(bio, (int)num); + /* Returns 1 on success or <=0 for failure. */ ret = 1; break; case BIO_CTRL_PENDING: - /* opt - Return number of bytes in BIO waiting to be read. Implements BIO_pending. */ + /* opt - Return number of bytes in chan waiting to be read. Implements BIO_pending. */ dprintf("Got BIO_CTRL_PENDING"); - /* Return the amount of pending data or 0 for error */ + /* Return the amount of pending data or 0 for error. */ ret = ((chan) ? Tcl_InputBuffered(chan) : 0); + dprintf("rbio pending=%ld", ret); break; case BIO_CTRL_FLUSH: /* opt - Flush any buffered output. Implements BIO_flush. */ dprintf("Got BIO_CTRL_FLUSH"); - /* Use Tcl_WriteRaw instead of Tcl_Flush to operate on right chan in stack */ + /* Use Tcl_WriteRaw instead of Tcl_Flush to operate on right chan in stack. */ /* Returns 1 for success, <=0 for error/retry. */ ret = ((chan) && (Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1); - /*ret = BioOutput(bio, NULL, 0);*/ break; case BIO_CTRL_DUP: - /* man - extra stuff for 'duped' BIO. Implements BIO_dup_state */ + /* man - extra stuff for 'duped' BIO. Implements BIO_dup_state. */ dprintf("Got BIO_CTRL_DUP"); ret = 1; break; case BIO_CTRL_WPENDING: - /* opt - Return number of bytes in BIO still to be written. Implements BIO_wpending. */ + /* opt - Return number of bytes in chan still to be written. Implements BIO_wpending. */ dprintf("Got BIO_CTRL_WPENDING"); /* Return the amount of pending data or 0 for error */ ret = ((chan) ? Tcl_OutputBuffered(chan) : 0); + dprintf("wbio pending=%ld", ret); break; case BIO_CTRL_SET_CALLBACK: - /* opt - Sets an informational callback. Implements BIO_set_info_callback */ + /* opt - Sets an informational callback. Implements BIO_set_info_callback. */ ret = 0; break; case BIO_CTRL_GET_CALLBACK: - /* opt - Get and return the info callback. Implements BIO_get_info_callback */ + /* opt - Get and return the info callback. Implements BIO_get_info_callback. */ ret = 0; break; case BIO_C_FILE_SEEK: - /* Not used for sockets. Tcl_Seek only works on top chan. Implements BIO_seek() */ + /* Not used for sockets. Tcl_Seek only works on top chan. Implements BIO_seek(). */ dprintf("Got BIO_C_FILE_SEEK"); ret = 0; /* Return 0 success and -1 for failure */ break; case BIO_C_FILE_TELL: - /* Not used for sockets. Tcl_Tell only works on top chan. Implements BIO_tell() */ + /* Not used for sockets. Tcl_Tell only works on top chan. Implements BIO_tell(). */ dprintf("Got BIO_C_FILE_TELL"); ret = 0; /* Return 0 success and -1 for failure */ break; case BIO_C_SET_FD: /* Implements BIO_set_fd */ @@ -375,23 +378,21 @@ /* Implements BIO_get_fd() */ dprintf("Unsupported call: BIO_C_GET_FD"); ret = -1; break; -#if OPENSSL_VERSION_NUMBER >= 0x30000000L && defined(BIO_CTRL_GET_KTLS_SEND) +#if OPENSSL_VERSION_NUMBER >= 0x30000000L case BIO_CTRL_GET_KTLS_SEND: /* Implements BIO_get_ktls_send */ dprintf("Got BIO_CTRL_GET_KTLS_SEND"); - /* Returns 1 if the BIO is using the Kernel TLS data-path for sending, 0 if not */ + /* Returns 1 if the BIO is using the Kernel TLS data-path for sending, 0 if not. */ ret = 0; break; -#endif -#if OPENSSL_VERSION_NUMBER >= 0x30000000L && defined(BIO_CTRL_GET_KTLS_RECV) case BIO_CTRL_GET_KTLS_RECV: /* Implements BIO_get_ktls_recv */ dprintf("Got BIO_CTRL_GET_KTLS_RECV"); - /* Returns 1 if the BIO is using the Kernel TLS data-path for receiving, 0 if not */ + /* Returns 1 if the BIO is using the Kernel TLS data-path for receiving, 0 if not. */ ret = 0; break; #endif default: dprintf("Got unknown control command (%i)", cmd); @@ -410,11 +411,11 @@ * This function is used to create a new instance of the BIO. This * function will be called in response to the application calling the * BIO_new() function. * * Results: - * Returns boolean success result (1=success, 0=failure) + * Returns boolean success result (1=success, 0=failure). * * Side effects: * Initializes BIO structure. * *----------------------------------------------------------------------------- @@ -441,14 +442,14 @@ * This function is used to destroy an instance of a BIO. This function * will be called in response to the application calling the BIO_free() * function. * * Results: - * Returns boolean success result + * Returns boolean success result (1=success, 0=failure). * * Side effects: - * Initializes BIO structure. + * De-initializes BIO structure. * *----------------------------------------------------------------------------- */ static int BioFree(BIO *bio) { @@ -459,12 +460,12 @@ } /* Clear flags if set to BIO_CLOSE (close I/O stream when the BIO is freed) */ if (BIO_get_shutdown(bio)) { BIO_set_data(bio, NULL); - BIO_set_init(bio, 0); BIO_clear_flags(bio, -1); + BIO_set_init(bio, 0); } return 1; } /* @@ -496,12 +497,11 @@ dprintf("BIO_new_tcl() called"); /* Create custom BIO method */ if (BioMethods == NULL) { /* BIO_TYPE_BIO = (19|BIO_TYPE_SOURCE_SINK) -- half a BIO pair */ - /* BIO_TYPE_CONNECT = (12|BIO_TYPE_SOURCE_SINK|BIO_TYPE_DESCRIPTOR) */ - /* BIO_TYPE_ACCEPT = (13|BIO_TYPE_SOURCE_SINK|BIO_TYPE_DESCRIPTOR) */ + /* custom = BIO_get_new_index() | BIO_TYPE_SOURCE_SINK */ BioMethods = BIO_meth_new(BIO_TYPE_BIO, "tcl"); if (BioMethods == NULL) { dprintf("Memory allocation error"); return NULL; Index: generic/tlsIO.c ================================================================== --- generic/tlsIO.c +++ generic/tlsIO.c @@ -2,11 +2,11 @@ * Provides IO functions to interface between the BIO buffers and TCL * applications when using stacked channels. * * Copyright (C) 1997-2000 Matt Newman * Copyright (C) 2000 Ajuba Solutions - * Copyright (C) 2024 Brian O'Hagan + * Copyright (C) 2024-2025 Brian O'Hagan * * Additional credit is due for Andreas Kupries (a.kupries@westend.com), for * providing the Tcl_ReplaceChannel mechanism and working closely with me * to enhance it to support full fileevent semantics. * @@ -15,26 +15,26 @@ * SSLtcl (Peter Antman) * */ /* - Normal - tlsBIO.c tlsIO.c - +------+ +---+ +---+ - | |Tcl_WriteRaw<--BioOutput|SSL|BIO_write<--TlsOutputProc<--Write| | - |socket| |BIO| |App| - | |Tcl_ReadRaw --> BioInput| |BIO_Read -->TlsInputProc --> Read| | - +------+ +---+ +---+ - - - Fast Path - tlsIO.c - +------+ +-----+ +-----+ - | |<-- write <--| SSL |BIO_write <-- TlsOutputProc <-- Write| | - |socket| | BIO | | App | - | |<-- read <--| |BIO_Read --> TlsInputProc --> Read| | - +------+ +-----+ +-----+ +Normal + tlsBIO.c tlsIO.c + +------+ +-----+ +---+ + | |Tcl_WriteRaw<--BioOutput| SSL |BIO_write<--TlsOutputProc <--puts| | + |socket| | BIO | |App| + | |Tcl_ReadRaw --> BioInput| |BIO_Read -->TlsInputProc --> read| | + +------+ +-----+ +---+ + + +Fast Path + tlsIO.c + +------+ +-----+ +-----+ + | |<-- write <--| SSL |BIO_write <-- TlsOutputProc <-- puts| | + |socket| | BIO | | App | + | |--> read -->| |BIO_Read --> TlsInputProc --> read| | + +------+ +-----+ +-----+ */ #include "tlsInt.h" #include @@ -41,13 +41,14 @@ /* *----------------------------------------------------------------------------- * * TlsBlockModeProc -- * - * This procedure is invoked by the generic IO level to set channel to + * This procedure is invoked by the generic IO level to set the channel to * blocking or nonblocking mode. Called by the generic I/O layer whenever - * the Tcl_SetChannelOption() function is used with option -blocking. + * the Tcl_SetChannelOption() function is used with option -blocking. Each + * stacked channel is configured individually. * * Results: * 0 if successful or POSIX error code if failed. * * Side effects: @@ -58,10 +59,12 @@ static int TlsBlockModeProc( ClientData instanceData, /* Connection state info */ int mode) /* Blocking or non-blocking mode */ { State *statePtr = (State *) instanceData; + + dprintf("Called with mode %d", mode); if (mode == TCL_MODE_NONBLOCKING) { statePtr->flags |= TLS_TCL_ASYNC; } else { statePtr->flags &= ~(TLS_TCL_ASYNC); @@ -80,27 +83,28 @@ * * Results: * 0 if successful or POSIX error code if failed. * * Side effects: - * Closes the socket of the channel. + * Closes the socket for the channel. * *----------------------------------------------------------------------------- */ static int TlsCloseProc( ClientData instanceData, /* Connection state info */ - Tcl_Interp *interp) /* Tcl interpreter to report errors to */ + TCL_UNUSED(Tcl_Interp *)) /* Tcl interpreter to report errors to */ { State *statePtr = (State *) instanceData; - dprintf("TlsCloseProc(%p)", (void *) statePtr); + dprintf("Close(%p)", (void *) statePtr); - /* Send shutdown notification. Will return 0 while in process, then 1 when - complete. Only closes the write direction of the connection; the read - direction is closed by the peer. Does not affect socket state. Don't - call after fatal error. */ - if (statePtr->ssl != NULL && !(statePtr->flags & TLS_TCL_HANDSHAKE_FAILED)) { + /* Send "close notify" shutdown notification. Will return 0 if in progress, + and 1 when complete. Only closes the write direction of the connection; + the read direction is closed by the peer. Does not affect the socket + state. Don't call after fatal error. */ + if (statePtr->ssl != NULL && !(statePtr->flags & TLS_TCL_INIT) && + !(statePtr->flags & TLS_TCL_FATAL_ERROR)) { BIO_flush(statePtr->bio); SSL_shutdown(statePtr->ssl); } /* Tls_Free calls Tls_Clean */ @@ -111,23 +115,28 @@ /* *----------------------------------------------------------------------------- * * TlsClose2Proc -- * - * Similar to TlsCloseProc, but allows for separate close read and write - * side of channel. + * Similar to TlsCloseProc, but allows for separate close of the read or + * write side of the channel. We don't support these since TLS is a + * bi-directional protocol. + * + * Results: + * 0 if successful or POSIX error code if failed. + * + * Side effects: + * Closes the socket for the channel. * *----------------------------------------------------------------------------- */ static int TlsClose2Proc( ClientData instanceData, /* Connection state info */ Tcl_Interp *interp, /* Tcl interpreter to report errors to */ int flags) /* Flags to close read/write side of channel */ { - State *statePtr = (State *) instanceData; - - dprintf("TlsClose2Proc(%p)", (void *) statePtr); + dprintf("Called with flags %d", flags); if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) { return TlsCloseProc(instanceData, interp); } return EINVAL; @@ -140,41 +149,39 @@ * * Perform connect (client) or accept (server) function. Also performs * equivalent of handshake function. * * Result: - * 1 if successful, 0 if wait for connect, and -1 if failed. + * 1 if successful, 0 if waiting for connect, and -1 if failed. Sets + * errorCodePtr to a POSIX error code if an error occurred, or 0 if not. * * Side effects: - * Issues SSL_accept or SSL_connect + * Performs SSL_accept or SSL_connect. * *----------------------------------------------------------------------------- */ int Tls_WaitForConnect( State *statePtr, /* Connection state info */ int *errorCodePtr, /* Storage for error code to return */ int handshakeFailureIsPermanent) /* Is the connect failure permanent */ { - unsigned long backingError; - int err, rc = 0; - int bioShouldRetry; + unsigned long err; + int ret, rc, reason, is_fatal, bioShouldRetry, io_err; *errorCodePtr = 0; dprintf("WaitForConnect(%p)", (void *) statePtr); + dprintf("Called with handshakeFailureIsPermanent %d", handshakeFailureIsPermanent); dprintFlags(statePtr); /* Can also check SSL_is_init_finished(ssl) */ if (!(statePtr->flags & TLS_TCL_INIT)) { dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success"); return 1; } - if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { - /* - * Different types of operations have different requirements - * SSL being established - */ + /* Different types of operations have different requirements for SSL being established. */ + if (statePtr->flags & TLS_TCL_FATAL_ERROR) { if (handshakeFailureIsPermanent) { dprintf("Asked to wait for a TLS handshake that has already failed. Returning fatal error"); *errorCodePtr = ECONNABORTED; } else { dprintf("Asked to wait for a TLS handshake that has already failed. Returning soft error"); @@ -182,48 +189,47 @@ } return -1; } for (;;) { + Tcl_SetErrno(0); ERR_clear_error(); BIO_clear_retry_flags(statePtr->bio); /* Not initialized yet! Also calls SSL_do_handshake(). */ if (statePtr->flags & TLS_TCL_SERVER) { dprintf("Calling SSL_accept()"); - err = SSL_accept(statePtr->ssl); + ret = SSL_accept(statePtr->ssl); } else { dprintf("Calling SSL_connect()"); - err = SSL_connect(statePtr->ssl); + ret = SSL_connect(statePtr->ssl); } /* 1=successful, 0=not successful and shut down, <0=fatal error */ - if (err > 0) { + if (ret > 0) { dprintf("Accept or connect was successful"); - err = BIO_flush(statePtr->bio); - if (err <= 0) { + if (BIO_flush(statePtr->bio) <= 0) { dprintf("Flushing the lower layers failed, this will probably terminate this session"); } } else { dprintf("Accept or connect failed"); } /* Same as SSL_want, but also checks the error queue */ - rc = SSL_get_error(statePtr->ssl, err); - backingError = ERR_get_error(); - if (rc != SSL_ERROR_NONE) { - dprintf("Got error: %i (rc = %i)", err, rc); - dprintf("Got error: %s", ERR_reason_error_string(backingError)); - } - + rc = SSL_get_error(statePtr->ssl, ret); + err = ERR_get_error(); + reason = ERR_GET_REASON(err); + is_fatal = ERR_FATAL_ERROR(err); /* The retry flag is set by the BIO_set_retry_* functions */ bioShouldRetry = BIO_should_retry(statePtr->bio); - dprintf("bioShouldRetry = %d", bioShouldRetry); + io_err = Tcl_GetErrno(); + dprintf("Connect: ret=%d, rc=%d, err=%ld, reason=%d, is_fatal=%d, lib=%s, msg=%s, bioShouldRetry=%d, errno=%d, id=%s, msg=%s", \ + ret, rc, err, reason, is_fatal, ERR_lib_error_string(err), ERR_reason_error_string(err), bioShouldRetry, io_err, Tcl_ErrnoId(), Tcl_ErrnoMsg(io_err)); - if (err <= 0) { + if (ret <= 0) { if (rc == SSL_ERROR_WANT_CONNECT || rc == SSL_ERROR_WANT_ACCEPT) { bioShouldRetry = 1; } else if (rc == SSL_ERROR_WANT_READ) { bioShouldRetry = 1; statePtr->want |= TCL_READABLE; @@ -248,10 +254,11 @@ dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though"); break; } + /* Based on error, do retry or abort */ switch (rc) { case SSL_ERROR_NONE: /* The TLS/SSL I/O operation completed successfully */ dprintf("SSL_ERROR_NONE"); *errorCodePtr = 0; @@ -264,103 +271,102 @@ dprintf("SSL_ERROR_SSL: Fatal SSL protocol error occurred"); if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) { Tls_Error(statePtr, X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl))); } - if (backingError != 0) { - Tls_Error(statePtr, ERR_reason_error_string(backingError)); + if (err != 0) { + Tls_Error(statePtr, ERR_reason_error_string(err)); } - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; *errorCodePtr = ECONNABORTED; + statePtr->flags |= TLS_TCL_FATAL_ERROR; + statePtr->flags |= TLS_TCL_EOF; return -1; case SSL_ERROR_WANT_READ: /* More data must be read from the underlying BIO layer in order to complete the actual SSL_*() operation. */ - dprintf("SSL_ERROR_WANT_READ"); + dprintf("SSL_ERROR_WANT_READ: EAGAIN"); BIO_set_retry_read(statePtr->bio); *errorCodePtr = EAGAIN; - dprintf("ERR(SSL_ERROR_WANT_READ, EAGAIN)"); statePtr->want |= TCL_READABLE; return 0; case SSL_ERROR_WANT_WRITE: /* There is data in the SSL buffer that must be written to the underlying BIO in order to complete the SSL_*() operation. */ - dprintf("SSL_ERROR_WANT_WRITE"); + dprintf("SSL_ERROR_WANT_WRITE: EAGAIN"); BIO_set_retry_write(statePtr->bio); *errorCodePtr = EAGAIN; - dprintf("ERR(SSL_ERROR_WANT_WRITE, EAGAIN)"); statePtr->want |= TCL_WRITABLE; return 0; case SSL_ERROR_WANT_X509_LOOKUP: /* The operation did not complete because an application callback set by SSL_CTX_set_client_cert_cb() has asked to be called again. */ - dprintf("SSL_ERROR_WANT_X509_LOOKUP"); + dprintf("SSL_ERROR_WANT_X509_LOOKUP: EAGAIN"); BIO_set_retry_special(statePtr->bio); BIO_set_retry_reason(statePtr->bio, BIO_RR_SSL_X509_LOOKUP); *errorCodePtr = EAGAIN; - dprintf("ERR(SSL_ERROR_WANT_X509_LOOKUP, EAGAIN)"); return 0; case SSL_ERROR_SYSCALL: /* Some non-recoverable, fatal I/O error occurred */ dprintf("SSL_ERROR_SYSCALL: Fatal I/O error occurred"); - if (backingError == 0 && err == 0) { + if (err == 0 && ret == 0) { + /* Unexpected EOF for 1.1.1 */ dprintf("EOF reached") *errorCodePtr = ECONNRESET; Tls_Error(statePtr, "(unexpected) EOF reached"); - } else if (backingError == 0 && err == -1) { + } else if (err == 0 && ret == -1) { dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno()); *errorCodePtr = Tcl_GetErrno(); if (*errorCodePtr == ECONNRESET) { *errorCodePtr = ECONNABORTED; } + statePtr->flags |= TLS_TCL_FATAL_ERROR; Tls_Error(statePtr, Tcl_ErrnoMsg(*errorCodePtr)); } else { - dprintf("I/O error occurred (backingError = %lu)", backingError); + dprintf("I/O error occurred (err = %lu)", err); *errorCodePtr = Tcl_GetErrno(); if (*errorCodePtr == ECONNRESET) { *errorCodePtr = ECONNABORTED; } - Tls_Error(statePtr, ERR_reason_error_string(backingError)); + statePtr->flags |= TLS_TCL_FATAL_ERROR; + Tls_Error(statePtr, ERR_reason_error_string(err)); } - - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + statePtr->flags |= TLS_TCL_EOF; return -1; case SSL_ERROR_ZERO_RETURN: /* Peer has cleanly closed the connection by sending the close_notify alert. Can't read, but can write. Need to return an EOF, so the channel is closed which will send an SSL_shutdown(). */ dprintf("SSL_ERROR_ZERO_RETURN: Peer has closed the connection"); *errorCodePtr = ECONNRESET; + statePtr->flags |= TLS_TCL_EOF; Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert"); return -1; case SSL_ERROR_WANT_CONNECT: /* The operation did not complete and connect would have blocked. Retry again after connection is established. */ - dprintf("SSL_ERROR_WANT_CONNECT"); + dprintf("SSL_ERROR_WANT_CONNECT: EAGAIN"); BIO_set_retry_special(statePtr->bio); BIO_set_retry_reason(statePtr->bio, BIO_RR_CONNECT); *errorCodePtr = EAGAIN; - dprintf("ERR(SSL_ERROR_WANT_CONNECT, EAGAIN)"); return 0; case SSL_ERROR_WANT_ACCEPT: /* The operation did not complete and accept would have blocked. Retry again after connection is established. */ - dprintf("SSL_ERROR_WANT_ACCEPT"); + dprintf("SSL_ERROR_WANT_ACCEPT: EAGAIN"); BIO_set_retry_special(statePtr->bio); BIO_set_retry_reason(statePtr->bio, BIO_RR_ACCEPT); *errorCodePtr = EAGAIN; - dprintf("ERR(SSL_ERROR_WANT_ACCEPT, EAGAIN)"); return 0; case SSL_ERROR_WANT_ASYNC: /* Used with flag SSL_MODE_ASYNC, op didn't complete because an async engine is still processing data */ @@ -395,48 +401,63 @@ *----------------------------------------------------------------------------- * * TlsInputProc -- * * This procedure is invoked by the generic I/O layer to read data from - * the BIO whenever the Tcl_Read(), Tcl_ReadChars, Tcl_Gets, and - * Tcl_GetsObj functions are used. Equivalent to SSL_read_ex and SSL_read. + * the BIO whenever the Tcl_Read, Tcl_ReadChars, Tcl_Gets, and Tcl_GetsObj + * functions are used. Equivalent to SSL_read_ex and SSL_read. * * Results: * Returns the number of bytes read or -1 on error. Sets errorCodePtr to - * a POSIX error code if an error occurred, or 0 if none. + * a POSIX error code if an error occurred, or 0 if successful. * * Side effects: - * Reads input from the input device of the channel. + * Reads data from SSL/BIO. * - * Data is received in whole blocks known as records from the peer. A whole - * record is processed (e.g. decrypted) in one go and is buffered by OpenSSL - * until it is read by the application via a call to SSL_read. + * Notes: + * Data is received in whole blocks known as records from the peer. A + * whole record is processed (e.g. decrypted) in one go and is buffered by + * OpenSSL until it is read by the application via a call to SSL_read() or + * BIO_read() in our case. SSL_pending() returns the number of bytes which + * have been processed, buffered, and are available inside ssl for + * immediate read. SSL_has_pending() returns 1 if data is buffered + * (whether processed or unprocessed) and 0 otherwise. * *----------------------------------------------------------------------------- */ static int TlsInputProc( ClientData instanceData, /* Connection state info */ char *buf, /* Buffer to store data read from BIO */ int bufSize, /* Buffer size in bytes */ int *errorCodePtr) /* Storage for error code to return */ { - unsigned long backingError; + unsigned long err; State *statePtr = (State *) instanceData; - int bytesRead, err; + int bytesRead, rc, reason, is_fatal, bioShouldRetry, io_err; *errorCodePtr = 0; - dprintf("Read(%d)", bufSize); + dprintf("Read %d bytes", bufSize); /* Abort if the user verify callback is still running to avoid triggering * another call before the current one is complete. */ if (statePtr->flags & TLS_TCL_CALLBACK) { dprintf("Callback is running, reading 0 bytes"); return 0; } - /* If not initialized, do connect */ - /* Can also check SSL_is_init_finished(ssl) */ + /* Abort if connection has failed or EOF already detected. Can't read, but can write. */ + if (statePtr->flags & TLS_TCL_FATAL_ERROR) { + dprintf("Fatal error already detected, abort read"); + *errorCodePtr = 0; + return 0; + } else if (statePtr->flags & TLS_TCL_EOF) { + dprintf("EOF already detected, abort read"); + *errorCodePtr = 0; + return 0; + } + + /* If not initialized, do connect. Can also check SSL_is_init_finished(). */ if (statePtr->flags & TLS_TCL_INIT) { int tlsConnect; dprintf("Calling Tls_WaitForConnect"); @@ -449,10 +470,11 @@ if (*errorCodePtr == ECONNRESET) { dprintf("Got connection reset"); /* Soft EOF */ *errorCodePtr = 0; bytesRead = 0; + statePtr->flags |= TLS_TCL_EOF; } return bytesRead; } else if (tlsConnect == 0) { /* Try again */ bytesRead = -1; @@ -463,52 +485,44 @@ /* * 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 */ + dprintf("BIO_read eof=%d, buffered=%d, input=%d, output=%d", Tcl_Eof(statePtr->self), Tcl_ChannelBuffered(statePtr->self), \ + Tcl_InputBuffered(statePtr->self), Tcl_OutputBuffered(statePtr->self)); ERR_clear_error(); + Tcl_SetErrno(0); ERR_clear_error(); BIO_clear_retry_flags(statePtr->bio); bytesRead = BIO_read(statePtr->bio, buf, bufSize); dprintf("BIO_read -> %d", bytesRead); + dprintf("BIO_read eof=%d, buffered=%d, input=%d, output=%d", Tcl_Eof(statePtr->self), Tcl_ChannelBuffered(statePtr->self), \ + Tcl_InputBuffered(statePtr->self), Tcl_OutputBuffered(statePtr->self)); /* Same as SSL_want, but also checks the error queue */ - err = SSL_get_error(statePtr->ssl, bytesRead); - backingError = ERR_get_error(); + rc = SSL_get_error(statePtr->ssl, bytesRead); + err = ERR_get_error(); + reason = ERR_GET_REASON(err); + is_fatal = ERR_FATAL_ERROR(err); + /* The retry flag is set by the BIO_set_retry_* functions */ + bioShouldRetry = BIO_should_retry(statePtr->bio); + io_err = Tcl_GetErrno(); + dprintf("Read: bytesRead=%d, rc=%d, err=%ld, reason=%d, is_fatal=%d, lib=%s, msg=%s, bioShouldRetry=%d, errno=%d, id=%s, msg=%s", \ + bytesRead, rc, err, reason, is_fatal, ERR_lib_error_string(err), ERR_reason_error_string(err), bioShouldRetry, io_err, Tcl_ErrnoId(), Tcl_ErrnoMsg(io_err)); if (bytesRead <= 0) { /* The retry flag is set by the BIO_set_retry_* functions */ - if (BIO_should_retry(statePtr->bio)) { - dprintf("Read failed with code=%d, bytes read=%d: should retry", err, bytesRead); - /* Some docs imply we should redo the BIO_read now */ - } else { - dprintf("Read failed with code=%d, bytes read=%d: error condition", err, bytesRead); - } - - dprintf("BIO is EOF %d", BIO_eof(statePtr->bio)); - - /* These are the same as BIO_retry_type */ - if (BIO_should_read(statePtr->bio)) { - dprintf("BIO has insufficient data to read and return"); - statePtr->want |= TCL_READABLE; - } - if (BIO_should_write(statePtr->bio)) { - dprintf("BIO has pending data to write"); - statePtr->want |= TCL_WRITABLE; - } - if (BIO_should_io_special(statePtr->bio)) { - int reason = BIO_get_retry_reason(statePtr->bio); - dprintf("BIO has some special condition other than read or write: code=%d", reason); - } - } - - switch (err) { + dprintf("Read failed: is EOF=%d, should retry=%d, retry read=%d, retry write=%d, other=%d", + BIO_eof(statePtr->bio), BIO_should_retry(statePtr->bio), BIO_should_read(statePtr->bio), + BIO_should_write(statePtr->bio), BIO_should_io_special(statePtr->bio)); + if (BIO_should_retry(statePtr->bio)) { + *errorCodePtr = EAGAIN; + } + } + + /* Based on error, do retry or abort */ + switch (rc) { case SSL_ERROR_NONE: /* I/O operation completed */ dprintf("SSL_ERROR_NONE"); dprintBuffer(buf, bytesRead); break; @@ -515,12 +529,12 @@ case SSL_ERROR_SSL: /* A non-recoverable, fatal error in the SSL library occurred, usually a protocol error. */ dprintf("SSL_ERROR_SSL: Fatal SSL protocol error occurred"); - if (backingError != 0) { - Tls_Error(statePtr, ERR_reason_error_string(backingError)); + if (err != 0) { + Tls_Error(statePtr, ERR_reason_error_string(err)); } else if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) { Tls_Error(statePtr, X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl))); } else { Tls_Error(statePtr, "Unknown SSL error"); @@ -528,17 +542,23 @@ *errorCodePtr = ECONNABORTED; bytesRead = -1; #if OPENSSL_VERSION_NUMBER >= 0x30000000L /* Unexpected EOF from the peer for OpenSSL 3.0+ */ - if (ERR_GET_REASON(backingError) == SSL_R_UNEXPECTED_EOF_WHILE_READING) { + if (ERR_GET_REASON(err) == SSL_R_UNEXPECTED_EOF_WHILE_READING) { dprintf("(Unexpected) EOF reached") *errorCodePtr = 0; bytesRead = 0; Tls_Error(statePtr, "EOF reached"); + } else { + statePtr->flags |= TLS_TCL_FATAL_ERROR; } +#else + statePtr->flags |= TLS_TCL_FATAL_ERROR; #endif + + statePtr->flags |= TLS_TCL_EOF; break; case SSL_ERROR_WANT_READ: /* Operation did not complete due to not enough data was available. Retry again later. */ @@ -569,39 +589,42 @@ case SSL_ERROR_SYSCALL: /* Some non-recoverable, fatal I/O error occurred */ dprintf("SSL_ERROR_SYSCALL: Fatal I/O error occurred"); - if (backingError == 0 && bytesRead == 0) { + if (err == 0 && bytesRead == 0) { /* Unexpected EOF from the peer for OpenSSL 1.1 */ dprintf("(Unexpected) EOF reached") *errorCodePtr = 0; bytesRead = 0; Tls_Error(statePtr, "EOF reached"); - } else if (backingError == 0 && bytesRead == -1) { - dprintf("I/O error occurred (errno = %lu)", - (unsigned long) Tcl_GetErrno()); + } else if (err == 0 && bytesRead == -1) { + dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno()); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; + statePtr->flags |= TLS_TCL_FATAL_ERROR; Tls_Error(statePtr, Tcl_ErrnoMsg(*errorCodePtr)); } else { - dprintf("I/O error occurred (backingError = %lu)", backingError); + dprintf("I/O error occurred (err = %lu)", err); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; - Tls_Error(statePtr, ERR_reason_error_string(backingError)); + statePtr->flags |= TLS_TCL_FATAL_ERROR; + Tls_Error(statePtr, ERR_reason_error_string(err)); } + statePtr->flags |= TLS_TCL_EOF; break; case SSL_ERROR_ZERO_RETURN: /* Peer has cleanly closed the connection by sending the close_notify alert. Can't read, but can write. Need to return an EOF, so the channel is closed which will send an SSL_shutdown(). */ dprintf("SSL_ERROR_ZERO_RETURN: Peer has closed the connection"); - bytesRead = 0; *errorCodePtr = 0; + bytesRead = 0; + statePtr->flags |= TLS_TCL_EOF; Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert"); break; case SSL_ERROR_WANT_ASYNC: /* Used with flag SSL_MODE_ASYNC, operation didn't complete because @@ -610,11 +633,12 @@ *errorCodePtr = EAGAIN; bytesRead = 0; break; default: - dprintf("Unknown error (err = %i), mapping to EOF", err); + /* Other error */ + dprintf("Other error, abort"); *errorCodePtr = 0; bytesRead = 0; Tls_Error(statePtr, "Unknown error"); break; } @@ -632,29 +656,29 @@ * BIO whenever the the Tcl_Write(), Tcl_WriteChars, and Tcl_WriteObj * functions are used. Equivalent to SSL_write_ex and SSL_write. * * Results: * Returns the number of bytes written or -1 on error. Sets errorCodePtr - * to a POSIX error code if an error occurred, or 0 if none. + * to a POSIX error code if an error occurred, or 0 if successful. * * Side effects: - * Writes output on the output device of the channel. + * Writes data to SSL/BIO. * *----------------------------------------------------------------------------- */ static int TlsOutputProc( ClientData instanceData, /* Connection state info */ const char *buf, /* Buffer with data to write to BIO */ int toWrite, /* Size of data to write in bytes */ int *errorCodePtr) /* Storage for error code to return */ { - unsigned long backingError; + unsigned long err; State *statePtr = (State *) instanceData; - int written, err; + int written, rc, reason, is_fatal, bioShouldRetry, io_err; *errorCodePtr = 0; - dprintf("Write(%p, %d)", (void *) statePtr, toWrite); + dprintf("Write %d bytes", toWrite); dprintBuffer(buf, toWrite); /* Abort if the user verify callback is still running to avoid triggering * another call before the current one is complete. */ if (statePtr->flags & TLS_TCL_CALLBACK) { @@ -662,12 +686,18 @@ written = -1; *errorCodePtr = EAGAIN; return -1; } - /* If not initialized, do connect */ - /* Can also check SSL_is_init_finished(ssl) */ + /* Abort if connection has failed. */ + if (statePtr->flags & TLS_TCL_FATAL_ERROR) { + dprintf("Fatal error already detected, abort write"); + *errorCodePtr = ECONNABORTED; + return -1; + } + + /* If not initialized, do connect. Can also check SSL_is_init_finished(). */ if (statePtr->flags & TLS_TCL_INIT) { int tlsConnect; dprintf("Calling Tls_WaitForConnect"); @@ -680,84 +710,78 @@ if (*errorCodePtr == ECONNRESET) { dprintf("Got connection reset"); /* Soft EOF */ *errorCodePtr = 0; written = 0; + statePtr->flags |= TLS_TCL_EOF; } return written; } else if (tlsConnect == 0) { /* Try again */ written = -1; return written; } } + /* Flush */ if (toWrite == 0) { dprintf("zero-write"); - err = BIO_flush(statePtr->bio); - if (err <= 0) { + if (BIO_flush(statePtr->bio) <= 0) { dprintf("Flushing failed"); Tls_Error(statePtr, "Flush failed"); *errorCodePtr = EIO; written = 0; return -1; } - written = 0; *errorCodePtr = 0; + written = 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. - * - * Alternatively, we may want to handle the <0 return codes from - * BIO_write specially (as advised in the RSA docs). TLS's lower level - * BIO functions play with the retry flags though, and this seems to - * work correctly. Similar fix in TlsInputProc. - hobbs */ + dprintf("BIO_write eof=%d, buffered=%d, input=%d, output=%d", Tcl_Eof(statePtr->self), Tcl_ChannelBuffered(statePtr->self), \ + Tcl_InputBuffered(statePtr->self), Tcl_OutputBuffered(statePtr->self)); + Tcl_SetErrno(0); ERR_clear_error(); BIO_clear_retry_flags(statePtr->bio); written = BIO_write(statePtr->bio, buf, toWrite); dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written); + dprintf("BIO_write eof=%d, buffered=%d, input=%d, output=%d", Tcl_Eof(statePtr->self), Tcl_ChannelBuffered(statePtr->self), \ + Tcl_InputBuffered(statePtr->self), Tcl_OutputBuffered(statePtr->self)); /* Same as SSL_want, but also checks the error queue */ - err = SSL_get_error(statePtr->ssl, written); - backingError = ERR_get_error(); + rc = SSL_get_error(statePtr->ssl, written); + err = ERR_get_error(); + reason = ERR_GET_REASON(err); + is_fatal = ERR_FATAL_ERROR(err); + /* The retry flag is set by the BIO_set_retry_* functions */ + bioShouldRetry = BIO_should_retry(statePtr->bio); + io_err = Tcl_GetErrno(); + dprintf("Write: written=%d, rc=%d, err=%ld, reason=%d, is_fatal=%d, lib=%s, msg=%s, bioShouldRetry=%d, errno=%d, id=%s, msg=%s", \ + written, rc, err, reason, is_fatal, ERR_lib_error_string(err), ERR_reason_error_string(err), bioShouldRetry, io_err, Tcl_ErrnoId(), Tcl_ErrnoMsg(io_err)); if (written <= 0) { - /* The retry flag is set by the BIO_set_retry_* functions */ + dprintf("Write failed: is EOF=%d, should retry=%d, retry read=%d, retry write=%d, other=%d", + BIO_eof(statePtr->bio), BIO_should_retry(statePtr->bio), BIO_should_read(statePtr->bio), + BIO_should_write(statePtr->bio), BIO_should_io_special(statePtr->bio)); if (BIO_should_retry(statePtr->bio)) { - dprintf("Write failed with code %d, bytes written=%d: should retry", - err, written); - } else { - dprintf("Write failed with code %d, bytes written=%d: error condition", - err, written); - } - - /* These are the same as BIO_retry_type */ - if (BIO_should_read(statePtr->bio)) { - dprintf("BIO has insufficient data to read and return"); - } - if (BIO_should_write(statePtr->bio)) { - dprintf("BIO has pending data to write"); - } - if (BIO_should_io_special(statePtr->bio)) { - int reason = BIO_get_retry_reason(statePtr->bio); - dprintf("BIO has some special condition other than read or write: code=%d", reason); - } - + *errorCodePtr = EAGAIN; + } } else { BIO_flush(statePtr->bio); } - switch (err) { + /* Based on error, do retry or abort */ + switch (rc) { case SSL_ERROR_NONE: /* I/O operation completed */ dprintf("SSL_ERROR_NONE"); if (written < 0) { written = 0; @@ -766,19 +790,21 @@ case SSL_ERROR_SSL: /* A non-recoverable, fatal error in the SSL library occurred, usually a protocol error */ dprintf("SSL_ERROR_SSL: Fatal SSL protocol error occurred"); - if (backingError != 0) { - Tls_Error(statePtr, ERR_reason_error_string(backingError)); + if (err != 0) { + Tls_Error(statePtr, ERR_reason_error_string(err)); } else if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) { Tls_Error(statePtr, X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl))); } else { Tls_Error(statePtr, "Unknown SSL error"); } *errorCodePtr = ECONNABORTED; + statePtr->flags |= TLS_TCL_FATAL_ERROR; + statePtr->flags |= TLS_TCL_EOF; written = -1; break; case SSL_ERROR_WANT_READ: /* Operation did not complete due to not enough data was available. @@ -810,37 +836,41 @@ case SSL_ERROR_SYSCALL: /* Some non-recoverable, fatal I/O error occurred */ dprintf("SSL_ERROR_SYSCALL: Fatal I/O error occurred"); - if (backingError == 0 && written == 0) { + if (err == 0 && written == 0) { dprintf("EOF reached") *errorCodePtr = 0; written = 0; Tls_Error(statePtr, "EOF reached"); - } else if (backingError == 0 && written == -1) { + } else if (err == 0 && written == -1) { dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno()); *errorCodePtr = Tcl_GetErrno(); written = -1; + statePtr->flags |= TLS_TCL_FATAL_ERROR; Tls_Error(statePtr, Tcl_ErrnoMsg(*errorCodePtr)); } else { - dprintf("I/O error occurred (backingError = %lu)", backingError); + dprintf("I/O error occurred (err = %lu)", err); *errorCodePtr = Tcl_GetErrno(); written = -1; - Tls_Error(statePtr, ERR_reason_error_string(backingError)); + statePtr->flags |= TLS_TCL_FATAL_ERROR; + Tls_Error(statePtr, ERR_reason_error_string(err)); } + statePtr->flags |= TLS_TCL_EOF; break; case SSL_ERROR_ZERO_RETURN: /* Peer has cleanly closed the connection by sending the close_notify alert. Can't read, but can write. Need to return an EOF, so the channel is closed which will send an SSL_shutdown(). */ dprintf("SSL_ERROR_ZERO_RETURN: Peer has closed the connection"); *errorCodePtr = 0; written = 0; + statePtr->flags |= TLS_TCL_EOF; Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert"); break; case SSL_ERROR_WANT_ASYNC: /* Used with flag SSL_MODE_ASYNC, operation didn't complete because @@ -849,11 +879,14 @@ *errorCodePtr = EAGAIN; written = 0; break; default: - dprintf("unknown error: %d", err); + /* Other error */ + dprintf("Other error, abort"); + *errorCodePtr = 0; + written = 0; Tls_Error(statePtr, "Unknown error"); break; } dprintf("Output(%d) -> %d", toWrite, written); @@ -911,11 +944,11 @@ { State *statePtr = (State *) instanceData; Tcl_Channel parent = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); Tcl_DriverSetOptionProc *setOptionProc; - dprintf("Called"); + dprintf("Called to set option %s to value %s", optionName, optionValue); /* Pass to parent */ setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(parent)); if (setOptionProc != NULL) { return (*setOptionProc)(Tcl_GetChannelInstanceData(parent), interp, optionName, optionValue); @@ -925,27 +958,27 @@ */ return Tcl_BadChannelOption(interp, optionName, ""); } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsGetOptionProc -- * * Get a option's value for a SSL socket based channel, or a list of all * options and their values. Called by the generic I/O layer whenever the * Tcl_GetChannelOption() function is used. * * * Results: - * A standard Tcl result. The value of the specified option or a list of - * all options and their values is returned in the supplied DString. + * TCL_OK if successful or TCL_ERROR if failed. Sets optionValue to + * the option's value. * * Side effects: - * None. + * None * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static int TlsGetOptionProc( ClientData instanceData, /* Socket state. */ Tcl_Interp *interp, /* For errors - can be NULL. */ @@ -955,11 +988,11 @@ { State *statePtr = (State *) instanceData; Tcl_Channel parent = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); Tcl_DriverGetOptionProc *getOptionProc; - dprintf("Called"); + dprintf("Called to get option %s", optionName); /* Pass to parent */ getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(parent)); if (getOptionProc != NULL) { return (*getOptionProc)(Tcl_GetChannelInstanceData(parent), interp, @@ -979,16 +1012,17 @@ /* *----------------------------------------------------------------------------- * * TlsChannelHandlerTimer -- * - * Called by the notifier via a timer, to flush out data waiting in - * channel buffers. called by the generic I/O layer whenever the - * Tcl_GetChannelHandle() function is used. + * Called by the notifier via a timer, to generate read/write events to + * flush out data waiting in channel buffers. Called by TlsWatchProc to + * periodically check for new events. Used to generate events when data is + * buffered in BIO and there are no underlying channel events. * * Results: - * None. + * None * * Side effects: * Creates notification event. * *----------------------------------------------------------------------------- @@ -999,11 +1033,14 @@ State *statePtr = (State *) clientData; int mask = statePtr->want; /* Init to SSL_ERROR_WANT_READ and SSL_ERROR_WANT_WRITE */ dprintf("Called with mask 0x%02x", mask); - statePtr->timer = (Tcl_TimerToken) NULL; + if (statePtr->timer != (Tcl_TimerToken) NULL) { + statePtr->timer = (Tcl_TimerToken) NULL; + Tcl_Release((ClientData) statePtr); + } /* Check for amount of data pending in IO or BIO write buffer */ if (Tcl_OutputBuffered(statePtr->self) || BIO_wpending(statePtr->bio)) { dprintf("[chan=%p] BIO writable", statePtr->self); @@ -1033,15 +1070,15 @@ * channel. Called by the generic I/O layer whenever the user (or the * system) announces its (dis)interest in events on the channel. This is * called repeatedly. * * Results: - * None. + * None * * Side effects: - * Sets up the time-based notifier so that future events on the channel - * will be seen by TCL. + * Sets up or clears a time-based notifier so that future events on the + * channel will be seen by TCL. * *----------------------------------------------------------------------------- */ static void TlsWatchProc( @@ -1052,23 +1089,27 @@ Tcl_Channel parent; State *statePtr = (State *) instanceData; Tcl_DriverWatchProc *watchProc; int pending = 0; - dprintf("Called with mask 0x%02x", mask); + dprintf("Called with mask 0x%02x and want 0x%02x", mask, statePtr->want); dprintFlags(statePtr); /* Abort if the user verify callback is still running to avoid triggering * another call before the current one is complete. */ if (statePtr->flags & TLS_TCL_CALLBACK) { dprintf("Callback is on-going, doing nothing"); return; } + /* Get channel to monitor for events */ parent = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + dprintf("Parent: chan buffer=%d, input buffer=%d, output buffer=%d", \ + Tcl_ChannelBuffered(parent), Tcl_InputBuffered(parent), Tcl_OutputBuffered(parent)); - if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { + /* Abort if connect failed */ + if (statePtr->flags & TLS_TCL_FATAL_ERROR) { dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here"); dprintf("Unregistering interest in the lower channel"); watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(parent)); watchProc(Tcl_GetChannelInstanceData(parent), 0); @@ -1096,25 +1137,23 @@ dprintf("IO Want=%d, input buffer=%d, output buffer=%d, BIO pending=%zd, BIO wpending=%zd, pending=%d", \ statePtr->want, Tcl_InputBuffered(statePtr->self), Tcl_OutputBuffered(statePtr->self), \ BIO_ctrl_pending(statePtr->bio), BIO_ctrl_wpending(statePtr->bio), pending); - /* Schedule next event if data is pending, otherwise cease events for now */ - if (!(mask & TCL_READABLE) || pending == 0) { - /* Remove timer, if any */ - if (statePtr->timer != (Tcl_TimerToken) NULL) { - dprintf("A timer was found, deleting it"); - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = (Tcl_TimerToken) NULL; - } - - } else { - /* Add timer, if none */ - if (statePtr->timer == (Tcl_TimerToken) NULL) { - dprintf("Creating a new timer since data appears to be waiting"); - statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); - } + /* Remove timer, if any */ + if (statePtr->timer != (Tcl_TimerToken) NULL) { + dprintf("A timer was found, deleting it"); + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + Tcl_Release((ClientData) statePtr); + } + + /* Add timer, if none */ + if (mask & TCL_READABLE) { + dprintf("Creating a new timer since data appears to be waiting"); + Tcl_Preserve((ClientData) statePtr); + statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); } } /* *----------------------------------------------------------------------------- @@ -1123,23 +1162,25 @@ * * This procedure is invoked by the generic IO level to retrieve an OS * specific handle associated with the channel. Not used for transforms. * * Results: - * The appropriate Tcl_File handle or NULL if none. + * The appropriate Tcl_File handle or NULL if None * * Side effects: - * None. + * None * *----------------------------------------------------------------------------- */ static int TlsGetHandleProc( ClientData instanceData, /* Socket state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Handle associated with the channel */ { State *statePtr = (State *) instanceData; + + dprintf("Called with direction 0x%02x", direction); return Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr); } @@ -1152,14 +1193,14 @@ * that an event has occurred on the underlying channel. It is used by * stacked channel drivers that wish to be notified of events that occur * on the underlying (stacked) channel. * * Results: - * Type of event or 0 if failed + * Returns mask value to indicate none of the events were serviced. * * Side effects: - * May process the incoming event by itself. + * May call Tls_WaitForConnect and/or delete timer. * *----------------------------------------------------------------------------- */ static int TlsNotifyProc( ClientData instanceData, /* Socket state. */ @@ -1168,10 +1209,22 @@ { State *statePtr = (State *) instanceData; int errorCode = 0; dprintf("Called with mask 0x%02x", mask); + + /* + * Delete an existing timer. It was not fired, yet we are here, so the + * below channel generated such an event and we don't need to. The renewal + * of the interest after the execution of channel handlers will eventually + * cause us to recreate the timer (in TlsWatchProc). + */ + if (statePtr->timer != (Tcl_TimerToken) NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + Tcl_Release((ClientData) statePtr); + } /* Abort if the user verify callback is still running to avoid triggering * another call before the current one is complete. */ if (statePtr->flags & TLS_TCL_CALLBACK) { dprintf("Callback is on-going, returning failed"); @@ -1195,21 +1248,10 @@ dprintf("Tls_WaitForConnect returned an error"); } } - /* - * 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 TlsWatchProc). - */ - if (statePtr->timer != (Tcl_TimerToken) NULL) { - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = (Tcl_TimerToken) NULL; - } - /* * An event occurred in the underlying channel. This transformation doesn't * process such events thus returns the incoming mask unchanged. */ dprintf("Returning %i", mask); @@ -1219,17 +1261,17 @@ /* *----------------------------------------------------------------------------- * * Tls_ChannelType -- * - * Defines the correct TLS channel driver handlers for this channel type. + * Defines the TLS channel driver handlers for this channel type. * * Results: - * Tcl_ChannelType structure. + * Returns a pointer to Tcl_ChannelType structure. * * Side effects: - * None. + * None * *----------------------------------------------------------------------------- */ static const Tcl_ChannelType tlsChannelType = { "tls", /* Type name */ Index: generic/tlsInt.h ================================================================== --- generic/tlsInt.h +++ generic/tlsInt.h @@ -122,11 +122,11 @@ 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_FATAL_ERROR) == TLS_TCL_FATAL_ERROR) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FATAL_ERROR"); }; \ 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__); } @@ -159,10 +159,14 @@ } #define LAPPEND_OBJ(interp, obj, text, tclObj) {\ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \ Tcl_ListObjAppendElement(interp, obj, (tclObj != NULL) ? tclObj : Tcl_NewStringObj("", 0)); \ } +#define LAPPEND_WIDE(interp, obj, text, value) {\ + if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \ + Tcl_ListObjAppendElement(interp, obj, Tcl_NewWideIntObj(value)); \ +} /* * Defines for State.flags */ #define TLS_TCL_ASYNC (1<<0) /* Non-blocking mode */ @@ -169,14 +173,17 @@ #define TLS_TCL_SERVER (1<<1) /* Server-Side */ #define TLS_TCL_INIT (1<<2) /* Initializing connection */ #define TLS_TCL_DEBUG (1<<3) /* Show debug tracing */ #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 +#define TLS_TCL_FATAL_ERROR (1<<5) /* Set on handshake failure or other fatal error. All * further I/O will result in ECONNABORTED errors. */ -#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used +#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used * directly by the SSL library. */ +#define TLS_TCL_EOF (1<<7) /* At EOF. Can't read, but can write. */ + +/* Set timer delay */ #define TLS_TCL_DELAY (5) /* * This structure describes the per-instance state of an SSL channel. * @@ -200,11 +207,11 @@ 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) */ - unsigned int protos_len; /* Length of protos */ + size_t protos_len; /* Length of protos */ unsigned char *protos; /* List of supported protocols in protocol format */ const char *err; } State; @@ -228,14 +235,13 @@ Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert, int all); Tcl_Obj *Tls_NewCAObj(Tcl_Interp *interp, const SSL *ssl, int peer); void Tls_Error(State *statePtr, const char *msg); void Tls_Free(tls_free_type *blockPtr); -void Tls_Clean(State *statePtr); int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent); BIO *BIO_new_tcl(State* statePtr, int flags); int BIO_cleanup(); #define PTR2INT(x) ((int) ((intptr_t) (x))) #endif /* _TLSINT_H */ Index: generic/tlsX509.c ================================================================== --- generic/tlsX509.c +++ generic/tlsX509.c @@ -44,12 +44,12 @@ if (resultObj == NULL) { return NULL; } for (int i = 0; i < ilen; i++) { - *dptr++ = hex[(*iptr>>4)&0xF]; - *dptr++ = hex[(*iptr++)&0xF]; + *dptr++ = (unsigned char)hex[(*iptr>>4)&0xF]; + *dptr++ = (unsigned char)hex[(*iptr++)&0xF]; } return resultObj; } /* @@ -211,12 +211,12 @@ * Side effects: * None * *----------------------------------------------------------------------------- */ -char *Tls_x509Purpose(X509 *cert) { - char *purpose = NULL; +const char *Tls_x509Purpose(X509 *cert) { + const char *purpose = NULL; if (X509_check_purpose(cert, X509_PURPOSE_SSL_CLIENT, 0) > 0) { purpose = "SSL Client"; } else if (X509_check_purpose(cert, X509_PURPOSE_SSL_SERVER, 0) > 0) { purpose = "SSL Server"; @@ -300,11 +300,11 @@ if (resultObj == NULL) { return NULL; } - if ((names = X509_get_ext_d2i(cert, nid, NULL, NULL)) != NULL) { + if ((names = (STACK_OF(GENERAL_NAME) *)X509_get_ext_d2i(cert, nid, NULL, NULL)) != NULL) { for (int i=0; i < sk_GENERAL_NAME_num(names); i++) { const GENERAL_NAME *name = sk_GENERAL_NAME_value(names, i); len = BIO_to_Buffer(name && GENERAL_NAME_print(bio, (GENERAL_NAME *) name), bio, buffer, 1024); LAPPEND_STR(interp, resultObj, NULL, buffer, len); @@ -394,21 +394,21 @@ if (resultObj == NULL) { return NULL; } - if ((crl = X509_get_ext_d2i(cert, NID_crl_distribution_points, NULL, NULL)) != NULL) { + if ((crl = (STACK_OF(DIST_POINT) *)X509_get_ext_d2i(cert, NID_crl_distribution_points, NULL, NULL)) != NULL) { for (int i=0; i < sk_DIST_POINT_num(crl); i++) { DIST_POINT *dp = sk_DIST_POINT_value(crl, i); DIST_POINT_NAME *distpoint = dp->distpoint; if (distpoint->type == 0) { /* full-name GENERALIZEDNAME */ for (int j = 0; j < sk_GENERAL_NAME_num(distpoint->name.fullname); j++) { GENERAL_NAME *gen = sk_GENERAL_NAME_value(distpoint->name.fullname, j); int type; - ASN1_STRING *uri = GENERAL_NAME_get0_value(gen, &type); + ASN1_STRING *uri = (ASN1_STRING *)GENERAL_NAME_get0_value(gen, &type); if (type == GEN_URI) { LAPPEND_STR(interp, resultObj, (char *) NULL, (char *) ASN1_STRING_get0_data(uri), (Tcl_Size) ASN1_STRING_length(uri)); } } } else if (distpoint->type == 1) { @@ -415,11 +415,11 @@ /* relative-name X509NAME */ STACK_OF(X509_NAME_ENTRY) *sk_relname = distpoint->name.relativename; for (int j = 0; j < sk_X509_NAME_ENTRY_num(sk_relname); j++) { X509_NAME_ENTRY *e = sk_X509_NAME_ENTRY_value(sk_relname, j); ASN1_STRING *d = X509_NAME_ENTRY_get_data(e); - LAPPEND_STR(interp, resultObj, (char *) NULL, (char *) ASN1_STRING_data(d), (Tcl_Size) ASN1_STRING_length(d)); + LAPPEND_STR(interp, resultObj, (char *) NULL, (char *) ASN1_STRING_get0_data(d), (Tcl_Size) ASN1_STRING_length(d)); } } } CRL_DIST_POINTS_free(crl); } @@ -481,13 +481,13 @@ if (resultObj == NULL) { return NULL; } - if ((ads = X509_get_ext_d2i(cert, NID_info_access, NULL, NULL)) != NULL) { + if ((ads = (STACK_OF(ACCESS_DESCRIPTION) *)X509_get_ext_d2i(cert, NID_info_access, NULL, NULL)) != NULL) { for (int i = 0; i < sk_ACCESS_DESCRIPTION_num(ads); i++) { - ad = sk_ACCESS_DESCRIPTION_value(ads, i); + ad = (ACCESS_DESCRIPTION *)sk_ACCESS_DESCRIPTION_value(ads, i); if (OBJ_obj2nid(ad->method) == NID_ad_ca_issuers && ad->location) { if (ad->location->type == GEN_URI) { Tcl_Size len = (Tcl_Size) ASN1_STRING_to_UTF8(&buf, ad->location->d.uniformResourceIdentifier); Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj((char *) buf, len)); OPENSSL_free(buf); @@ -522,13 +522,13 @@ int mdnid, pknid, bits; Tcl_Size len; unsigned int ulen; uint32_t xflags; unsigned long flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT; - flags &= ~ASN1_STRFLGS_ESC_MSB; + flags &= ~(unsigned long)ASN1_STRFLGS_ESC_MSB; - char *buffer = ckalloc(BUFSIZ > EVP_MAX_MD_SIZE ? BUFSIZ : EVP_MAX_MD_SIZE); + char *buffer = (char *)ckalloc(BUFSIZ > EVP_MAX_MD_SIZE ? BUFSIZ : EVP_MAX_MD_SIZE); dprintf("Called"); if (interp == NULL || cert == NULL || bio == NULL || resultObj == NULL || buffer == NULL) { Tcl_DecrRefCount(resultObj); Index: tclconfig/README.txt ================================================================== --- tclconfig/README.txt +++ tclconfig/README.txt @@ -1,9 +1,9 @@ These files comprise the basic building blocks for a Tcl Extension Architecture (TEA) extension. For more information on TEA see: - http://www.tcl.tk/doc/tea/ + https://wiki.tcl-lang.org/page/TEA This package is part of the Tcl project at SourceForge, but sources and bug/patch database are hosted on fossil here: https://core.tcl-lang.org/tclconfig Index: tclconfig/tcl.m4 ================================================================== --- tclconfig/tcl.m4 +++ tclconfig/tcl.m4 @@ -140,20 +140,20 @@ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ + `ls -d /usr/lib/tcl9.1 2>/dev/null` \ `ls -d /usr/lib/tcl9.0 2>/dev/null` \ - `ls -d /usr/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/lib/tcl8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl9.1 2>/dev/null` \ `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl9.1 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.5 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" @@ -223,14 +223,10 @@ no_tk=true AC_ARG_WITH(tk, AS_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), [with_tkconfig="${withval}"]) - AC_ARG_WITH(tk8, - AS_HELP_STRING([--with-tk8], - [Compile for Tk8 in Tk9 environment]), - [with_tk8="${withval}"]) AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ # First check to see if --with-tkconfig was specified. if test x"${with_tkconfig}" != x ; then @@ -294,22 +290,22 @@ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ + `ls -d /usr/lib/tk9.1 2>/dev/null` \ `ls -d /usr/lib/tk9.0 2>/dev/null` \ - `ls -d /usr/lib/tk8.7 2>/dev/null` \ `ls -d /usr/lib/tk8.6 2>/dev/null` \ `ls -d /usr/lib/tk8.5 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ + `ls -d /usr/local/lib/tk9.1 2>/dev/null` \ `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tk8.7 2>/dev/null` \ `ls -d /usr/local/lib/tk8.6 2>/dev/null` \ `ls -d /usr/local/lib/tk8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tk9.1 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tk8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk8.5 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" @@ -455,11 +451,14 @@ CC=$hold_cc AC_MSG_RESULT($TEA_PLATFORM) # The BUILD_$pkg is to define the correct extern storage class # handling when making this package - AC_DEFINE_UNQUOTED(BUILD_${PACKAGE_NAME}, [], + # To be able to sefely use the package name in a #define, it must not + # contain anything other than alphanumeric characters and underscores + SAFE_PKG_NAME=patsubst(AC_PACKAGE_NAME, [[^A-Za-z0-9_]], [_]) + AC_DEFINE_UNQUOTED(BUILD_${SAFE_PKG_NAME}, [], [Building extension source?]) # Do this here as we have fully defined TEA_PLATFORM now if test "${TEA_PLATFORM}" = "windows" ; then EXEEXT=".exe" CLEANFILES="$CLEANFILES *.lib *.dll *.pdb *.exp" @@ -1192,10 +1191,11 @@ ;; ia64) MACHINE="IA64" ;; esac + do64bit_ok=yes fi if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT @@ -1202,11 +1202,11 @@ else runtime=-MD fi case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) - lflags="${lflags} -nodefaultlib:libucrt.lib" + lflags="${lflags} -nodefaultlib:ucrt.lib" TEA_ADD_LIBS([ucrt.lib]) ;; *) ;; esac @@ -1378,15 +1378,19 @@ SHLIB_SUFFIX=".so" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - CYGWIN_*) + CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" + if test "${TEA_PLATFORM}" = "unix" -a "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$(patsubst cyg%.dll,lib%.dll,\$[@]).a" + else + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" + fi EXEEXT=".exe" do64bit_ok=yes CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; @@ -3202,19 +3206,26 @@ # Shared libraries and static libraries have different names. # Use the double eval to make sure any variables in the suffix is # substituted. (@@@ Might not be necessary anymore) #-------------------------------------------------------------------- - PACKAGE_LIB_PREFIX8="${PACKAGE_LIB_PREFIX}" - PACKAGE_LIB_PREFIX9="${PACKAGE_LIB_PREFIX}tcl9" + if test "$TEA_PLATFORM" = "unix"; then + PACKAGE_LIB_PREFIX8="lib" + if test "$EXEEXT" = ".exe" -a "$SHARED_BUILD" != "0"; then + PACKAGE_LIB_PREFIX9="cygtcl9" + else + PACKAGE_LIB_PREFIX9="libtcl9" + fi + else + PACKAGE_LIB_PREFIX8="" + PACKAGE_LIB_PREFIX9="tcl9" + fi if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX9}" else PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX8}" AC_DEFINE(TCL_MAJOR_VERSION, 8, [Compile for Tcl8?]) - fi - if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tk8}" != x; then AC_DEFINE(TK_MAJOR_VERSION, 8, [Compile for Tk8?]) fi if test "${TEA_PLATFORM}" = "windows" ; then if test "${SHARED_BUILD}" = "1" ; then # We force the unresolved linking of symbols that are really in @@ -3223,10 +3234,18 @@ SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test "$GCC" = "yes"; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -static-libgcc" + fi + AC_CACHE_CHECK([if the linker understands --disable-high-entropy-va], + tcl_cv_ld_high_entropy, [ + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--disable-high-entropy-va" + AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_ld_high_entropy=yes],[tcl_cv_ld_high_entropy=no]) + CFLAGS=$hold_cflags]) + if test $tcl_cv_ld_high_entropy = yes; then + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--disable-high-entropy-va" fi eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" else @@ -3254,24 +3273,24 @@ if test "${SHARED_BUILD}" = "1" ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" fi - eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" RANLIB=: else - eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" - eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then - eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" + eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" else - eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" + eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi fi # These are escaped so that only CFLAGS is picked up at configure time. # The other values will be substituted at make time. Index: tests/all.tcl ================================================================== --- tests/all.tcl +++ tests/all.tcl @@ -2,35 +2,32 @@ # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# set path [file normalize [file dirname [file join [pwd] [info script]]]] -#set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]] -set auto_path [linsert $auto_path 0 [file dirname $path] [file normalize [pwd]]] +set auto_path [linsert $auto_path 0 [file dirname $path] $path] -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest - namespace import ::tcltest::* + namespace import -force ::tcltest::* } -# Get common functions +# Add user provided args such as -load +tcltest::configure {*}$argv -testdir $path +#tcltest::configure -verbose tpse + +# Print stats at end +set ::tcltest::testSingleFile false +#tcltest::configure -singleproc 1 + +# Get common functions, if any if {[file exists [file join $path common.tcl]]} { source -encoding utf-8 [file join $path common.tcl] } -set ::tcltest::testSingleFile false -set ::tcltest::testsDirectory [file dir [info script]] - -# 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} - # # Run all tests in current and any sub directories with an all.tcl file. # set ::exitCode 0 if {[package vsatisfies [package require tcltest] 2.5-]} { @@ -46,7 +43,11 @@ set ::exitCode [expr {$numTests(Total) == 0 || $numTests(Failed) > 0}] } ::tcltest::runAllTests } -# Exit code: 0=all passed, 1=one or more failed -exit $::exitCode +# Return exit code for use by test frameworks: 0=all passed, 1=one or more failed +if {[info exists env(ERROR_ON_FAILURES)]} { + exit $::exitCode +} else { + exit 0 +} Index: tests/badssl.csv ================================================================== --- tests/badssl.csv +++ tests/badssl.csv @@ -1,26 +1,27 @@ # Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes +command,package prefer latest,,,,,,,,, command,package require tls,,,,,,,,, ,,,,,,,,,, command,# Constraints,,,,,,,,, command,source [file join [file dirname [info script]] common.tcl],,,,,,,,, ,,,,,,,,,, command,# Helper functions,,,,,,,,, command,"proc badssl {url} {set port 443;lassign [split $url "":""] url port;if {$port eq """"} {set port 443};set cmd [list tls::socket -autoservername 1 -require 1];if {[info exists ::env(SSL_CERT_FILE)]} {lappend cmd -cafile $::env(SSL_CERT_FILE)};lappend cmd $url $port;set ch [eval $cmd];if {[catch {tls::handshake $ch} err]} {close $ch;return -code error $err} else {close $ch}}",,,,,,,,, ,,,,,,,,,, command,# BadSSL.com Tests,,,,,,,,, -BadSSL,1000-sans,,,badssl 1000-sans.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 -BadSSL,10000-sans,,,badssl 10000-sans.badssl.com,,,handshake failed: excessive message size,,,1 +BadSSL,1000 sans,,,badssl 1000-sans.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 +BadSSL,10000 sans,,,badssl 10000-sans.badssl.com,,,handshake failed: excessive message size,,,1 BadSSL,3des,,,badssl 3des.badssl.com,,glob,handshake failed: * alert handshake failure,,,1 -BadSSL,captive-portal,old_api,,badssl captive-portal.badssl.com,,,"handshake failed: certificate verify failed due to ""Hostname mismatch""",,,1 -BadSSL,captive-portal,new_api,,badssl captive-portal.badssl.com,,,"handshake failed: certificate verify failed due to ""hostname mismatch""",,,1 +BadSSL,captive portal,old_api,,badssl captive-portal.badssl.com,,,"handshake failed: certificate verify failed due to ""Hostname mismatch""",,,1 +BadSSL,captive portal,new_api,,badssl captive-portal.badssl.com,,,"handshake failed: certificate verify failed due to ""hostname mismatch""",,,1 BadSSL,cbc,,,badssl cbc.badssl.com,,,,,, -BadSSL,client-cert-missing,,,badssl client-cert-missing.badssl.com,,,,,, +BadSSL,client cert missing,,,badssl client-cert-missing.badssl.com,,,,,, BadSSL,client,,,badssl client.badssl.com,,,,,, -BadSSL,dh-composite,old_api,,badssl dh-composite.badssl.com,,,,,, -BadSSL,dh-composite,new_api,,badssl dh-composite.badssl.com,,,handshake failed: dh key too small,,,1 -BadSSL,dh-small-subgroup,,,badssl dh-small-subgroup.badssl.com,,,,,, +BadSSL,dh composite,old_api,,badssl dh-composite.badssl.com,,,,,, +BadSSL,dh composite,new_api,,badssl dh-composite.badssl.com,,,handshake failed: dh key too small,,,1 +BadSSL,dh small subgroup,,,badssl dh-small-subgroup.badssl.com,,,,,, BadSSL,dh480,old_api,,badssl dh480.badssl.com,,,handshake failed: dh key too small,,,1 BadSSL,dh480,new_api,,badssl dh480.badssl.com,,,handshake failed: modulus too small,,,1 BadSSL,dh512,old_api,,badssl dh512.badssl.com,,,handshake failed: dh key too small,,,1 BadSSL,dh512,mac,,badssl dh512.badssl.com,,,handshake failed: unknown security bits,,,1 BadSSL,dh1024,old_api,,badssl dh1024.badssl.com,,,,,, @@ -29,51 +30,51 @@ BadSSL,dsdtestprovider,,,badssl dsdtestprovider.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 BadSSL,ecc256,,,badssl ecc256.badssl.com,,,,,, BadSSL,ecc384,,,badssl ecc384.badssl.com,,,,,, BadSSL,edellroot,,,badssl edellroot.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 BadSSL,expired,,,badssl expired.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 -BadSSL,extended-validation,,,badssl extended-validation.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 +BadSSL,extended validation,,,badssl extended-validation.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 BadSSL,hsts,,,badssl hsts.badssl.com,,,,,, -BadSSL,https-everywhere,,,badssl https-everywhere.badssl.com,,,,,, -BadSSL,incomplete-chain,,,badssl incomplete-chain.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 -BadSSL,invalid-expected-sct,,,badssl invalid-expected-sct.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 -BadSSL,long-extended-subdomain-name-containing-many-letters-and-dashes,,,badssl long-extended-subdomain-name-containing-many-letters-and-dashes.badssl.com,,,,,, +BadSSL,https everywhere,,,badssl https-everywhere.badssl.com,,,,,, +BadSSL,incomplete chain,,,badssl incomplete-chain.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,invalid expected sct,,,badssl invalid-expected-sct.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,long extended subdomain name containing many letters and dashes,,,badssl long-extended-subdomain-name-containing-many-letters-and-dashes.badssl.com,,,,,, BadSSL,longextendedsubdomainnamewithoutdashesinordertotestwordwrapping,,,badssl longextendedsubdomainnamewithoutdashesinordertotestwordwrapping.badssl.com,,,,,, -BadSSL,mitm-software,,,badssl mitm-software.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 -BadSSL,no-common-name,,,badssl no-common-name.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 -BadSSL,no-sct,,,badssl no-sct.badssl.com,,,,,, -BadSSL,no-subject,,,badssl no-subject.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 +BadSSL,mitm software,,,badssl mitm-software.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,no common name,,,badssl no-common-name.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 +BadSSL,no sct,,,badssl no-sct.badssl.com,,,,,, +BadSSL,no subject,,,badssl no-subject.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 BadSSL,null,,,badssl null.badssl.com,,glob,handshake failed: * alert handshake failure,,,1 -BadSSL,pinning-test,,,badssl pinning-test.badssl.com,,,,,, -BadSSL,preact-cli,,,badssl preact-cli.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 -BadSSL,preloaded-hsts,,,badssl preloaded-hsts.badssl.com,,,,,, -BadSSL,rc4-md5,,,badssl rc4-md5.badssl.com,,glob,handshake failed: * alert handshake failure,,,1 +BadSSL,pinning test,,,badssl pinning-test.badssl.com,,,,,, +BadSSL,preact cli,,,badssl preact-cli.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,preloaded hsts,,,badssl preloaded-hsts.badssl.com,,,,,, +BadSSL,rc4 md5,,,badssl rc4-md5.badssl.com,,glob,handshake failed: * alert handshake failure,,,1 BadSSL,rc4,,,badssl rc4.badssl.com,,glob,handshake failed: * alert handshake failure,,,1 -BadSSL,revoked,,,badssl revoked.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 +BadSSL,revoked,,,badssl revoked.badssl.com,,,,,, BadSSL,rsa2048,,,badssl rsa2048.badssl.com,,,,,, BadSSL,rsa4096,,,badssl rsa4096.badssl.com,,,,,, BadSSL,rsa8192,,,badssl rsa8192.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 -BadSSL,self-signed,old_api,,badssl self-signed.badssl.com,,,"handshake failed: certificate verify failed due to ""self signed certificate""",,,1 -BadSSL,self-signed,new_api,,badssl self-signed.badssl.com,,,"handshake failed: certificate verify failed due to ""self-signed certificate""",,,1 -BadSSL,sha1-2016,,,badssl sha1-2016.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 -BadSSL,sha1-2017,old_api,,badssl sha1-2017.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 -BadSSL,sha1-2017,new_api,,badssl sha1-2017.badssl.com,,,"handshake failed: certificate verify failed due to ""CA signature digest algorithm too weak""",,,1 -BadSSL,sha1-intermediate,,,badssl sha1-intermediate.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,self signed,old_api,,badssl self-signed.badssl.com,,,"handshake failed: certificate verify failed due to ""self signed certificate""",,,1 +BadSSL,self signed,new_api,,badssl self-signed.badssl.com,,,"handshake failed: certificate verify failed due to ""self-signed certificate""",,,1 +BadSSL,sha1 2016,,,badssl sha1-2016.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,sha1 2017,old_api,,badssl sha1-2017.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 +BadSSL,sha1 2017,new_api,,badssl sha1-2017.badssl.com,,,"handshake failed: certificate verify failed due to ""CA signature digest algorithm too weak""",,,1 +BadSSL,sha1 intermediate,,,badssl sha1-intermediate.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 BadSSL,sha256,,,badssl sha256.badssl.com,,,,,, BadSSL,sha384,,,badssl sha384.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 BadSSL,sha512,,,badssl sha512.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1 -BadSSL,static-rsa,,,badssl static-rsa.badssl.com,,,,,, -BadSSL,subdomain.preloaded-hsts,old_api,,badssl subdomain.preloaded-hsts.badssl.com,,,"handshake failed: certificate verify failed due to ""Hostname mismatch""",,,1 -BadSSL,subdomain.preloaded-hsts,new_api,,badssl subdomain.preloaded-hsts.badssl.com,,,"handshake failed: certificate verify failed due to ""hostname mismatch""",,,1 +BadSSL,static rsa,,,badssl static-rsa.badssl.com,,,,,, +BadSSL,subdomain.preloaded hsts,old_api,,badssl subdomain.preloaded-hsts.badssl.com,,,"handshake failed: certificate verify failed due to ""Hostname mismatch""",,,1 +BadSSL,subdomain.preloaded hsts,new_api,,badssl subdomain.preloaded-hsts.badssl.com,,,"handshake failed: certificate verify failed due to ""hostname mismatch""",,,1 BadSSL,superfish,,,badssl superfish.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 -BadSSL,tls-v1-0:1010,tls1 old_api,,badssl tls-v1-0.badssl.com:1010,,,,,, -BadSSL,tls-v1-0:1010,tls1 new_api,,badssl tls-v1-0.badssl.com:1010,,,handshake failed: unsupported protocol,,,1 -BadSSL,tls-v1-1:1011,tls1.1 old_api,,badssl tls-v1-1.badssl.com:1011,,,,,, -BadSSL,tls-v1-1:1011,tls1.1 new_api,,badssl tls-v1-1.badssl.com:1011,,,handshake failed: unsupported protocol,,,1 -BadSSL,tls-v1-2:1012,tls1.2,,badssl tls-v1-2.badssl.com:1012,,,,,, -BadSSL,untrusted-root,old_api,,badssl untrusted-root.badssl.com,,,"handshake failed: certificate verify failed due to ""self signed certificate in certificate chain""",,,1 -BadSSL,untrusted-root,new_api,,badssl untrusted-root.badssl.com,,,"handshake failed: certificate verify failed due to ""self-signed certificate in certificate chain""",,,1 +BadSSL,tls v1 0:1010,tls1 old_api,,badssl tls-v1-0.badssl.com:1010,,,,,, +BadSSL,tls v1 0:1010,tls1 new_api,,badssl tls-v1-0.badssl.com:1010,,,handshake failed: unsupported protocol,,,1 +BadSSL,tls v1 1:1011,tls1.1 old_api,,badssl tls-v1-1.badssl.com:1011,,,,,, +BadSSL,tls v1 1:1011,tls1.1 new_api,,badssl tls-v1-1.badssl.com:1011,,,handshake failed: unsupported protocol,,,1 +BadSSL,tls v1 2:1012,tls1.2,,badssl tls-v1-2.badssl.com:1012,,,,,, +BadSSL,untrusted root,old_api,,badssl untrusted-root.badssl.com,,,"handshake failed: certificate verify failed due to ""self signed certificate in certificate chain""",,,1 +BadSSL,untrusted root,new_api,,badssl untrusted-root.badssl.com,,,"handshake failed: certificate verify failed due to ""self-signed certificate in certificate chain""",,,1 BadSSL,upgrade,,,badssl upgrade.badssl.com,,,,,, -BadSSL,webpack-dev-server,,,badssl webpack-dev-server.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 +BadSSL,webpack dev server,,,badssl webpack-dev-server.badssl.com,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1 BadSSL,wrong.host,old_api,,badssl wrong.host.badssl.com,,,"handshake failed: certificate verify failed due to ""Hostname mismatch""",,,1 BadSSL,wrong.host,new_api,,badssl wrong.host.badssl.com,,,"handshake failed: certificate verify failed due to ""hostname mismatch""",,,1 -BadSSL,mozilla-modern,,,badssl mozilla-modern.badssl.com,,,,,, +BadSSL,mozilla modern,,,badssl mozilla-modern.badssl.com,,,,,, Index: tests/badssl.test ================================================================== --- tests/badssl.test +++ tests/badssl.test @@ -1,15 +1,16 @@ # Auto generated test cases for badssl.csv # Load Tcl Test package -if {[lsearch [namespace children] ::tcltest] == -1} { +if {[lsearch [namespace children] ::tcltest] < 0} { package require tcltest namespace import ::tcltest::* } -set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path] +set ::auto_path [concat [list [file dirname [file dirname [info script]]]] $::auto_path] +package prefer latest package require tls # Constraints source [file join [file dirname [info script]] common.tcl] @@ -17,51 +18,51 @@ proc badssl {url} {set port 443;lassign [split $url ":"] url port;if {$port eq ""} {set port 443};set cmd [list tls::socket -autoservername 1 -require 1];if {[info exists ::env(SSL_CERT_FILE)]} {lappend cmd -cafile $::env(SSL_CERT_FILE)};lappend cmd $url $port;set ch [eval $cmd];if {[catch {tls::handshake $ch} err]} {close $ch;return -code error $err} else {close $ch}} # BadSSL.com Tests -test BadSSL-1.1 {1000-sans} -body { +test BadSSL-1.1 {1000 sans} -body { badssl 1000-sans.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} -test BadSSL-1.2 {10000-sans} -body { +test BadSSL-1.2 {10000 sans} -body { badssl 10000-sans.badssl.com } -result {handshake failed: excessive message size} -returnCodes {1} test BadSSL-1.3 {3des} -body { badssl 3des.badssl.com } -match {glob} -result {handshake failed: * alert handshake failure} -returnCodes {1} -test BadSSL-1.4 {captive-portal} -constraints {old_api} -body { +test BadSSL-1.4 {captive portal} -constraints {old_api} -body { badssl captive-portal.badssl.com } -result {handshake failed: certificate verify failed due to "Hostname mismatch"} -returnCodes {1} -test BadSSL-1.5 {captive-portal} -constraints {new_api} -body { +test BadSSL-1.5 {captive portal} -constraints {new_api} -body { badssl captive-portal.badssl.com } -result {handshake failed: certificate verify failed due to "hostname mismatch"} -returnCodes {1} test BadSSL-1.6 {cbc} -body { badssl cbc.badssl.com } -test BadSSL-1.7 {client-cert-missing} -body { +test BadSSL-1.7 {client cert missing} -body { badssl client-cert-missing.badssl.com } test BadSSL-1.8 {client} -body { badssl client.badssl.com } -test BadSSL-1.9 {dh-composite} -constraints {old_api} -body { +test BadSSL-1.9 {dh composite} -constraints {old_api} -body { badssl dh-composite.badssl.com } -test BadSSL-1.10 {dh-composite} -constraints {new_api} -body { +test BadSSL-1.10 {dh composite} -constraints {new_api} -body { badssl dh-composite.badssl.com } -result {handshake failed: dh key too small} -returnCodes {1} -test BadSSL-1.11 {dh-small-subgroup} -body { +test BadSSL-1.11 {dh small subgroup} -body { badssl dh-small-subgroup.badssl.com } test BadSSL-1.12 {dh480} -constraints {old_api} -body { badssl dh480.badssl.com @@ -109,71 +110,71 @@ test BadSSL-1.23 {expired} -body { badssl expired.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} -test BadSSL-1.24 {extended-validation} -body { +test BadSSL-1.24 {extended validation} -body { badssl extended-validation.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} test BadSSL-1.25 {hsts} -body { badssl hsts.badssl.com } -test BadSSL-1.26 {https-everywhere} -body { +test BadSSL-1.26 {https everywhere} -body { badssl https-everywhere.badssl.com } -test BadSSL-1.27 {incomplete-chain} -body { +test BadSSL-1.27 {incomplete chain} -body { badssl incomplete-chain.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} -test BadSSL-1.28 {invalid-expected-sct} -body { +test BadSSL-1.28 {invalid expected sct} -body { badssl invalid-expected-sct.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} -test BadSSL-1.29 {long-extended-subdomain-name-containing-many-letters-and-dashes} -body { +test BadSSL-1.29 {long extended subdomain name containing many letters and dashes} -body { badssl long-extended-subdomain-name-containing-many-letters-and-dashes.badssl.com } test BadSSL-1.30 {longextendedsubdomainnamewithoutdashesinordertotestwordwrapping} -body { badssl longextendedsubdomainnamewithoutdashesinordertotestwordwrapping.badssl.com } -test BadSSL-1.31 {mitm-software} -body { +test BadSSL-1.31 {mitm software} -body { badssl mitm-software.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} -test BadSSL-1.32 {no-common-name} -body { +test BadSSL-1.32 {no common name} -body { badssl no-common-name.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} -test BadSSL-1.33 {no-sct} -body { +test BadSSL-1.33 {no sct} -body { badssl no-sct.badssl.com } -test BadSSL-1.34 {no-subject} -body { +test BadSSL-1.34 {no subject} -body { badssl no-subject.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} test BadSSL-1.35 {null} -body { badssl null.badssl.com } -match {glob} -result {handshake failed: * alert handshake failure} -returnCodes {1} -test BadSSL-1.36 {pinning-test} -body { +test BadSSL-1.36 {pinning test} -body { badssl pinning-test.badssl.com } -test BadSSL-1.37 {preact-cli} -body { +test BadSSL-1.37 {preact cli} -body { badssl preact-cli.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} -test BadSSL-1.38 {preloaded-hsts} -body { +test BadSSL-1.38 {preloaded hsts} -body { badssl preloaded-hsts.badssl.com } -test BadSSL-1.39 {rc4-md5} -body { +test BadSSL-1.39 {rc4 md5} -body { badssl rc4-md5.badssl.com } -match {glob} -result {handshake failed: * alert handshake failure} -returnCodes {1} test BadSSL-1.40 {rc4} -body { badssl rc4.badssl.com @@ -193,31 +194,31 @@ test BadSSL-1.44 {rsa8192} -body { badssl rsa8192.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} -test BadSSL-1.45 {self-signed} -constraints {old_api} -body { +test BadSSL-1.45 {self signed} -constraints {old_api} -body { badssl self-signed.badssl.com } -result {handshake failed: certificate verify failed due to "self signed certificate"} -returnCodes {1} -test BadSSL-1.46 {self-signed} -constraints {new_api} -body { +test BadSSL-1.46 {self signed} -constraints {new_api} -body { badssl self-signed.badssl.com } -result {handshake failed: certificate verify failed due to "self-signed certificate"} -returnCodes {1} -test BadSSL-1.47 {sha1-2016} -body { +test BadSSL-1.47 {sha1 2016} -body { badssl sha1-2016.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} -test BadSSL-1.48 {sha1-2017} -constraints {old_api} -body { +test BadSSL-1.48 {sha1 2017} -constraints {old_api} -body { badssl sha1-2017.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} -test BadSSL-1.49 {sha1-2017} -constraints {new_api} -body { +test BadSSL-1.49 {sha1 2017} -constraints {new_api} -body { badssl sha1-2017.badssl.com } -result {handshake failed: certificate verify failed due to "CA signature digest algorithm too weak"} -returnCodes {1} -test BadSSL-1.50 {sha1-intermediate} -body { +test BadSSL-1.50 {sha1 intermediate} -body { badssl sha1-intermediate.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} test BadSSL-1.51 {sha256} -body { badssl sha256.badssl.com @@ -229,59 +230,59 @@ test BadSSL-1.53 {sha512} -body { badssl sha512.badssl.com } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1} -test BadSSL-1.54 {static-rsa} -body { +test BadSSL-1.54 {static rsa} -body { badssl static-rsa.badssl.com } -test BadSSL-1.55 {subdomain.preloaded-hsts} -constraints {old_api} -body { +test BadSSL-1.55 {subdomain.preloaded hsts} -constraints {old_api} -body { badssl subdomain.preloaded-hsts.badssl.com } -result {handshake failed: certificate verify failed due to "Hostname mismatch"} -returnCodes {1} -test BadSSL-1.56 {subdomain.preloaded-hsts} -constraints {new_api} -body { +test BadSSL-1.56 {subdomain.preloaded hsts} -constraints {new_api} -body { badssl subdomain.preloaded-hsts.badssl.com } -result {handshake failed: certificate verify failed due to "hostname mismatch"} -returnCodes {1} test BadSSL-1.57 {superfish} -body { badssl superfish.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} -test BadSSL-1.58 {tls-v1-0:1010} -constraints {tls1 old_api} -body { - badssl tls-v1-0.badssl.com:1010 - } - -test BadSSL-1.59 {tls-v1-0:1010} -constraints {tls1 new_api} -body { - badssl tls-v1-0.badssl.com:1010 - } -result {handshake failed: unsupported protocol} -returnCodes {1} - -test BadSSL-1.60 {tls-v1-1:1011} -constraints {tls1.1 old_api} -body { - badssl tls-v1-1.badssl.com:1011 - } - -test BadSSL-1.61 {tls-v1-1:1011} -constraints {tls1.1 new_api} -body { - badssl tls-v1-1.badssl.com:1011 - } -result {handshake failed: unsupported protocol} -returnCodes {1} - -test BadSSL-1.62 {tls-v1-2:1012} -constraints {tls1.2} -body { - badssl tls-v1-2.badssl.com:1012 - } - -test BadSSL-1.63 {untrusted-root} -constraints {old_api} -body { - badssl untrusted-root.badssl.com - } -result {handshake failed: certificate verify failed due to "self signed certificate in certificate chain"} -returnCodes {1} - -test BadSSL-1.64 {untrusted-root} -constraints {new_api} -body { +test BadSSL-1.58 {tls v1 0:1010} -constraints {tls1 old_api} -body { + badssl tls-v1-0.badssl.com:1010 + } + +test BadSSL-1.59 {tls v1 0:1010} -constraints {tls1 new_api} -body { + badssl tls-v1-0.badssl.com:1010 + } -result {handshake failed: unsupported protocol} -returnCodes {1} + +test BadSSL-1.60 {tls v1 1:1011} -constraints {tls1.1 old_api} -body { + badssl tls-v1-1.badssl.com:1011 + } + +test BadSSL-1.61 {tls v1 1:1011} -constraints {tls1.1 new_api} -body { + badssl tls-v1-1.badssl.com:1011 + } -result {handshake failed: unsupported protocol} -returnCodes {1} + +test BadSSL-1.62 {tls v1 2:1012} -constraints {tls1.2} -body { + badssl tls-v1-2.badssl.com:1012 + } + +test BadSSL-1.63 {untrusted root} -constraints {old_api} -body { + badssl untrusted-root.badssl.com + } -result {handshake failed: certificate verify failed due to "self signed certificate in certificate chain"} -returnCodes {1} + +test BadSSL-1.64 {untrusted root} -constraints {new_api} -body { badssl untrusted-root.badssl.com } -result {handshake failed: certificate verify failed due to "self-signed certificate in certificate chain"} -returnCodes {1} test BadSSL-1.65 {upgrade} -body { badssl upgrade.badssl.com } -test BadSSL-1.66 {webpack-dev-server} -body { +test BadSSL-1.66 {webpack dev server} -body { badssl webpack-dev-server.badssl.com } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1} test BadSSL-1.67 {wrong.host} -constraints {old_api} -body { badssl wrong.host.badssl.com @@ -289,12 +290,12 @@ test BadSSL-1.68 {wrong.host} -constraints {new_api} -body { badssl wrong.host.badssl.com } -result {handshake failed: certificate verify failed due to "hostname mismatch"} -returnCodes {1} -test BadSSL-1.69 {mozilla-modern} -body { +test BadSSL-1.69 {mozilla modern} -body { badssl mozilla-modern.badssl.com } # Cleanup ::tcltest::cleanupTests return Index: tests/ciphers.csv ================================================================== --- tests/ciphers.csv +++ tests/ciphers.csv @@ -1,6 +1,7 @@ # Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes +command,package prefer latest,,,,,,,,, command,package require tls,,,,,,,,, command,,,,,,,,,, command,# Make sure path includes location of OpenSSL executable,,,,,,,,, command,"if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin "";""] $::env(path)]}",,,,,,,,, command,,,,,,,,,, @@ -41,21 +42,21 @@ Ciphers By Protocol,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3] [::tls::ciphers tls1.3]",,,missing {} unexpected {},,, ,,,,,,,,,, command,# Test cipher descriptions,,,,,,,,, Ciphers With Descriptions,SSL2,ssl2,,"lcompare [exec_get ""\r\n"" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]",,,missing {} unexpected {},,, Ciphers With Descriptions,SSL3,ssl3,,"lcompare [exec_get ""\r\n"" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]",,,missing {} unexpected {},,, -Ciphers With Descriptions,TLS1.0,tls1,,"lcompare [exec_get ""\r\n"" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]",,,missing {} unexpected {},,, -Ciphers With Descriptions,TLS1.1,tls1.1,,"lcompare [exec_get ""\r\n"" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]",,,missing {} unexpected {},,, -Ciphers With Descriptions,TLS1.2,tls1.2,,"lcompare [exec_get ""\r\n"" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]",,,missing {} unexpected {},,, -Ciphers With Descriptions,TLS1.3,tls1.3,,"lcompare [exec_get ""\r\n"" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]",,,missing {} unexpected {},,, +Ciphers With Descriptions,TLS1.0,tls1 old_api,,"lcompare [exec_get ""\r\n"" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]",,,missing {} unexpected {},,, +Ciphers With Descriptions,TLS1.1,tls1.1 old_api,,"lcompare [exec_get ""\r\n"" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]",,,missing {} unexpected {},,, +Ciphers With Descriptions,TLS1.2,tls1.2 old_api,,"lcompare [exec_get ""\r\n"" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]",,,missing {} unexpected {},,, +Ciphers With Descriptions,TLS1.3,tls1.3 old_api,,"lcompare [exec_get ""\r\n"" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]",,,missing {} unexpected {},,, ,,,,,,,,,, command,# Test protocol specific ciphers,,,,,,,,, Ciphers Protocol Specific,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]",,,missing {} unexpected {},,, Ciphers Protocol Specific,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]",,,missing {} unexpected {},,, -Ciphers Protocol Specific,TLS1.0,tls1,,"lcompare [exec_get "":"" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]",,,missing {} unexpected {},,, -Ciphers Protocol Specific,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]",,,missing {} unexpected {},,, -Ciphers Protocol Specific,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]",,,missing {} unexpected {},,, -Ciphers Protocol Specific,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]",,,missing {} unexpected {},,, +Ciphers Protocol Specific,TLS1.0,tls1 old_api,,"lcompare [exec_get "":"" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]",,,missing {} unexpected {},,, +Ciphers Protocol Specific,TLS1.1,tls1.1 old_api,,"lcompare [exec_get "":"" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]",,,missing {} unexpected {},,, +Ciphers Protocol Specific,TLS1.2,tls1.2 old_api,,"lcompare [exec_get "":"" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]",,,missing {} unexpected {},,, +Ciphers Protocol Specific,TLS1.3,tls1.3 old_api,,"lcompare [exec_get "":"" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]",,,missing {} unexpected {},,, ,,,,,,,,,, command,# Test version,,,,,,,,, Version,All,,,::tls::version,,glob,*,,, Version,OpenSSL,OpenSSL,,::tls::version,,glob,OpenSSL*,,, Index: tests/ciphers.test ================================================================== --- tests/ciphers.test +++ tests/ciphers.test @@ -1,15 +1,16 @@ # Auto generated test cases for ciphers.csv # Load Tcl Test package -if {[lsearch [namespace children] ::tcltest] == -1} { +if {[lsearch [namespace children] ::tcltest] < 0} { package require tcltest namespace import ::tcltest::* } -set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path] +set ::auto_path [concat [list [file dirname [file dirname [info script]]]] $::auto_path] +package prefer latest package require tls # Make sure path includes location of OpenSSL executable if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin ";"] $::env(path)]} @@ -81,23 +82,23 @@ test Ciphers_With_Descriptions-3.2 {SSL3} -constraints {ssl3} -body { lcompare [exec_get "\r\n" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n] } -result {missing {} unexpected {}} -test Ciphers_With_Descriptions-3.3 {TLS1.0} -constraints {tls1} -body { +test Ciphers_With_Descriptions-3.3 {TLS1.0} -constraints {tls1 old_api} -body { lcompare [exec_get "\r\n" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n] } -result {missing {} unexpected {}} -test Ciphers_With_Descriptions-3.4 {TLS1.1} -constraints {tls1.1} -body { +test Ciphers_With_Descriptions-3.4 {TLS1.1} -constraints {tls1.1 old_api} -body { lcompare [exec_get "\r\n" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n] } -result {missing {} unexpected {}} -test Ciphers_With_Descriptions-3.5 {TLS1.2} -constraints {tls1.2} -body { +test Ciphers_With_Descriptions-3.5 {TLS1.2} -constraints {tls1.2 old_api} -body { lcompare [exec_get "\r\n" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n] } -result {missing {} unexpected {}} -test Ciphers_With_Descriptions-3.6 {TLS1.3} -constraints {tls1.3} -body { +test Ciphers_With_Descriptions-3.6 {TLS1.3} -constraints {tls1.3 old_api} -body { lcompare [exec_get "\r\n" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n] } -result {missing {} unexpected {}} # Test protocol specific ciphers @@ -108,23 +109,23 @@ test Ciphers_Protocol_Specific-4.2 {SSL3} -constraints {ssl3} -body { lcompare [exec_get ":" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1] } -result {missing {} unexpected {}} -test Ciphers_Protocol_Specific-4.3 {TLS1.0} -constraints {tls1} -body { +test Ciphers_Protocol_Specific-4.3 {TLS1.0} -constraints {tls1 old_api} -body { lcompare [exec_get ":" ciphers -tls1 -s] [::tls::ciphers tls1 0 1] } -result {missing {} unexpected {}} -test Ciphers_Protocol_Specific-4.4 {TLS1.1} -constraints {tls1.1} -body { +test Ciphers_Protocol_Specific-4.4 {TLS1.1} -constraints {tls1.1 old_api} -body { lcompare [exec_get ":" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1] } -result {missing {} unexpected {}} -test Ciphers_Protocol_Specific-4.5 {TLS1.2} -constraints {tls1.2} -body { +test Ciphers_Protocol_Specific-4.5 {TLS1.2} -constraints {tls1.2 old_api} -body { lcompare [exec_get ":" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1] } -result {missing {} unexpected {}} -test Ciphers_Protocol_Specific-4.6 {TLS1.3} -constraints {tls1.3} -body { +test Ciphers_Protocol_Specific-4.6 {TLS1.3} -constraints {tls1.3 old_api} -body { lcompare [exec_get ":" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1] } -result {missing {} unexpected {}} # Test version Index: tests/common.tcl ================================================================== --- tests/common.tcl +++ tests/common.tcl @@ -1,8 +1,9 @@ #!/usr/bin/env tclsh # Common Constraints +package prefer latest package require tls # Supported protocols set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3] foreach protocol $protocols { Index: tests/keytest1.tcl ================================================================== --- tests/keytest1.tcl +++ tests/keytest1.tcl @@ -1,8 +1,9 @@ #!/usr/bin/env tclsh set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]] +package prefer latest package require tls proc creadable {s} { puts "LINE=[gets $s]" after 2000 @@ -18,10 +19,10 @@ close [file tempfile keyfile keyfile] close [file tempfile certfile certfile] tls::misc req 1024 $keyfile $certfile [list C CCC ST STTT L LLLL O OOOO OU OUUUU CN CNNNN Email some@email.com days 730 serial 12] -tls::socket -keyfile $keyfile -certfile $certfile -server myserv 12300 +tls::socket -require 0 -keyfile $keyfile -certfile $certfile -server myserv 12300 puts "Now run keytest2.tcl" vwait forever Index: tests/keytest2.tcl ================================================================== --- tests/keytest2.tcl +++ tests/keytest2.tcl @@ -1,10 +1,11 @@ #!/usr/bin/env tclsh set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]] +package prefer latest package require tls -set s [tls::socket 127.0.0.1 12300] +set s [tls::socket -require 0 127.0.0.1 12300] puts $s "A line" flush $s puts [join [tls::status $s] \n] exit Index: tests/make_test_files.tcl ================================================================== --- tests/make_test_files.tcl +++ tests/make_test_files.tcl @@ -1,5 +1,6 @@ +#!/usr/bin/env tclsh # # Name: Make Test Files From CSV Files # Version: 0.3 # Date: March 9, 2024 # Author: Brian O'Hagan @@ -81,42 +82,47 @@ puts $out [format "# Auto generated test cases for %s" [file tail $filename]] #puts $out [format "# Auto generated test cases for %s created on %s" [file tail $filename] [clock format [clock seconds]]] # Package requires puts $out "\n# Load Tcl Test package" - puts $out [subst -nocommands {if {[lsearch [namespace children] ::tcltest] == -1} {\n\tpackage require tcltest\n\tnamespace import ::tcltest::*\n}\n}] - puts $out {set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]} + puts $out [subst -nocommands {if {[lsearch [namespace children] ::tcltest] < 0} {\n\tpackage require tcltest\n\tnamespace import ::tcltest::*\n}\n}] + puts $out {set ::auto_path [concat [list [file dirname [file dirname [info script]]]] $::auto_path]} puts $out "" # Generate test cases and add to test file while {[gets $in data] > -1} { # Skip comments set data [string trim $data] - if {[string match "#*" $data]} continue + if {[string match "#*" $data] || [string match "\"#*" $data]} continue # Split comma separated fields with quotes set list [parse_csv $in $data] # Get command or test case foreach {group name constraints setup body cleanup match result output errorOutput returnCodes} $list { if {$group eq "command"} { puts $out $name } elseif {$group ne "" && $body ne ""} { - set group [string map [list " " "_"] $group] + # Remove illegal characters + set group [string map [list " " "_" "-" "_"] $group] + set name [string map [list "-" "_"] $name] + + # Define test number if {$group ne $prev} { incr test set prev $group puts $out "" } - # Test case + # Create test case if {[string index $name 0] ne {$}} { set buffer [format "\ntest %s-%d.%d {%s}" $group $test [incr cases($group)] $name] } else { set buffer [format "\ntest %s-%d.%d %s" $group $test [incr cases($group)] $name] } + # Add test case arguments foreach opt [list -constraints -setup -body -cleanup -match -result -output -errorOutput -returnCodes] { set cmd [string trim [set [string trimleft $opt "-"]]] if {$cmd ne ""} { if {$opt in [list -setup -body -cleanup]} { append buffer " " $opt " \{\n" Index: tests/remote.tcl ================================================================== --- tests/remote.tcl +++ tests/remote.tcl @@ -11,13 +11,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # load tls package +package prefer latest package require tls -# Initialize message delimitor +# Initialize message delimiter # Initialize command array catch {unset command} set command(0) "" set callerSocket "" @@ -43,20 +44,23 @@ puts $fd $l puts $fd "---" close $fd } set callerSocket $s - if {[catch {uplevel #0 $l} msg]} { - if {0} { + set ::errorInfo "" + if {[catch {uplevel "#0" $l} msg]} { + if {0} { set fd [open remoteServer.log a] puts $fd "error: $msg" close $fd } - list error $msg + set code error } else { - list success $msg + set code success } + #return [list $code $::errorInfo $msg] + return [list $code $msg] } proc __readAndExecute__ {s} { global command VERBOSE @@ -96,12 +100,12 @@ if {$VERBOSE} { puts "Server accepts new connection from $a:$p on $s" } tls::handshake $s - fileevent $s readable [list __readAndExecute__ $s] fconfigure $s -buffering line -translation crlf + fileevent $s readable [list __readAndExecute__ $s] } set serverIsSilent 0 for {set i 0} {$i < $argc} {incr i} { if {[lindex $argv $i] eq "-serverIsSilent"} { @@ -115,12 +119,12 @@ } } if {![info exists serverPort]} { for {set i 0} {$i < $argc} {incr i} { if {[lindex $argv $i] eq "-port"} { - if {$i < [expr $argc - 1]} { - set serverPort [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverPort [lindex $argv [expr {$i + 1}]] } break } } } @@ -134,12 +138,12 @@ } } if {![info exists serverAddress]} { for {set i 0} {$i < $argc} {incr i} { if {[lindex $argv $i] eq "-address"} { - if {$i < [expr $argc - 1]} { - set serverAddress [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverAddress [lindex $argv [expr {$i + 1}]] } break } } } @@ -175,12 +179,13 @@ set certsDir [file join [file dirname [info script]] certs] set serverCert [file join $certsDir server.pem] set caCert [file join $certsDir cacert.pem] set serverKey [file join $certsDir server.key] if {[catch {set serverSocket \ - [tls::socket -myaddr $serverAddress -server __accept__ \ + [tls::socket -require 0 -myaddr $serverAddress -server __accept__ \ -cafile $caCert -certfile $serverCert -keyfile $serverKey \ $serverPort]} msg]} { puts "Server on $serverAddress:$serverPort cannot start: $msg" } else { + puts ready vwait __server_wait_variable__ } Index: tests/simpleClient.tcl ================================================================== --- tests/simpleClient.tcl +++ tests/simpleClient.tcl @@ -1,19 +1,21 @@ #!/usr/bin/env tclsh +package prefer latest package require tls set dir [file join [file dirname [info script]] ../tests/certs] set OPTS(-cafile) [file join $dir ca.pem] set OPTS(-cert) [file join $dir client.pem] set OPTS(-key) [file join $dir client.key] -set OPTS(-host) lorax +set OPTS(-host) localhost set OPTS(-port) 2468 set OPTS(-debug) 1 set OPTS(-count) 8 set OPTS(-parallel) 1 +set OPTS(-require) 0 foreach {key val} $argv { if {![info exists OPTS($key)]} { puts stderr "Usage: $argv0 ?options?\ \n\t-debug boolean Debugging on or off ($OPTS(-debug))\ @@ -21,11 +23,12 @@ \n\t-client file Client Cert ($OPTS(-cert))\ \n\t-ckey file Client Key ($OPTS(-key))\ \n\t-count num No of sync. connections to make per client ($OPTS(-count))\ \n\t-parallel num No of parallel clients to run ($OPTS(-parallel))\ \n\t-host hostname Server hostname ($OPTS(-host))\ - \n\t-port num Server port ($OPTS(-port))" + \n\t-port num Server port ($OPTS(-port))\ + \n\t-require boolean Require Certificate ($OPTS(-require))" exit } set OPTS($key) $val } @@ -104,8 +107,8 @@ exit 0 } } } -tls::init -cafile $OPTS(-cafile) -certfile $OPTS(-cert) -keyfile $OPTS(-key) +tls::init -cafile $OPTS(-cafile) -certfile $OPTS(-cert) -keyfile $OPTS(-key) -require $OPTS(-require) go Index: tests/simpleServer.tcl ================================================================== --- tests/simpleServer.tcl +++ tests/simpleServer.tcl @@ -1,7 +1,8 @@ #!/usr/bin/env tclsh +package prefer latest package require tls set dir [file join [file dirname [info script]] ../tests/certs] set OPTS(-cafile) [file join $dir ca.pem] set OPTS(-cert) [file join $dir server.pem] @@ -16,11 +17,11 @@ puts stderr "Usage: $argv0 ?options?\ \n\t-debug boolean Debugging on or off ($OPTS(-debug))\ \n\t-cafile file Cert. Auth. File ($OPTS(-cafile))\ \n\t-cert file Server Cert ($OPTS(-cert))\ \n\t-key file Server Key ($OPTS(-key))\ - \n\t-require boolean Require Certification ($OPTS(-require))\ + \n\t-require boolean Require Certificate ($OPTS(-require))\ \n\t-port num Port to listen on ($OPTS(-port))" exit } set OPTS($key) $val } Index: tests/tlsIO.test ================================================================== --- tests/tlsIO.test +++ tests/tlsIO.test @@ -68,10 +68,11 @@ namespace import -force ::tcltest::* } # The build dir is added as the first element of $PATH # Load the tls package +package prefer latest package require tls set tlsServerPort 8048 # Specify where the certificates are @@ -101,13 +102,13 @@ } if {![info exists remoteServerPort]} { if {[info exists env(remoteServerPort)]} { set remoteServerPort $env(remoteServerPort) } else { - if {[info exists remoteServerIP]} { + if {[info exists remoteServerIP]} { set remoteServerPort $tlsServerPort - } + } } } proc do_handshake {s {type readable} {cmd {}} args} { if {[eof $s]} { @@ -153,11 +154,11 @@ set remoteProcChan "" set commandSocket "" if {$doTestsWithRemoteServer} { catch {close $commandSocket} - if {[catch {set commandSocket [tls::socket \ + if {[catch {set commandSocket [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP $remoteServerPort]}] != 0} { if {[info commands exec] eq ""} { set noRemoteTestReason "can't exec" set doTestsWithRemoteServer 0 @@ -167,12 +168,12 @@ if {[catch {set remoteProcChan \ [open "|[list $::tcltest::tcltest $remoteFile \ -serverIsSilent -port $remoteServerPort \ -address $remoteServerIP]" w+]} msg] == 0} { after 1000 - if {[catch {set commandSocket [tls::socket -cafile $caCert \ - -certfile $clientCert -keyfile $clientKey \ + if {[catch {set commandSocket [tls::socket -require 0 \ + -cafile $caCert -certfile $clientCert -keyfile $clientKey \ $remoteServerIP $remoteServerPort]} msg] == 0} { fconfigure $commandSocket -translation crlf -buffering line } else { set noRemoteTestReason $msg set doTestsWithRemoteServer 0 @@ -189,11 +190,11 @@ # Some tests are run only if we are doing testing against a remote server. set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer if {$doTestsWithRemoteServer == 0} { if {[string first s $::tcltest::verbose] != -1} { - puts "Skipping tests with remote server. See tests/socket.test for" + puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" } } @@ -302,19 +303,20 @@ test tlsIO-2.1 {tcp connection} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x timed_out"] + set timer [after 2000 [list set x timed_out]] } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" puts $f { proc accept {file addr port} { global x set x done - close $file + close $file } puts ready vwait x after cancel $timer close $f @@ -323,14 +325,14 @@ close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f x if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8828} msg]} { - set x $msg + set x $msg } else { - lappend x [gets $f] - close $msg + lappend x [gets $f] + close $msg } lappend x [gets $f] close $f set x } {ready done {}} @@ -344,20 +346,21 @@ test tlsIO-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x done"] + set timer [after 2000 [list set x done]] } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]" puts $f { proc accept {sock addr port} { - global x - puts "[gets $sock] $port" - close $sock - set x done + global x + puts "[gets $sock] $port" + close $sock + set x done } puts ready vwait x after cancel $timer close $f @@ -364,20 +367,20 @@ } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f x global port - if {[catch {tls::socket -myport $port \ + if {[catch {tls::socket -myport $port -require 0 \ -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8829} sock]} { - set x $sock + set x $sock catch {close [tls::socket 127.0.0.1 8829]} } else { - puts $sock hello + puts $sock hello flush $sock - lappend x [gets $f] - close $sock + lappend x [gets $f] + close $sock } close $f set x } [list ready "hello $port"] @@ -384,38 +387,39 @@ test tlsIO-2.3 {tcp connection with client interface specified} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x done"] + set timer [after 2000 [list set x done]] } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]" puts $f { proc accept {sock addr port} { - global x - puts "[gets $sock] $addr" - close $sock - set x done + global x + puts "[gets $sock] $addr" + close $sock + set x done } puts ready vwait x after cancel $timer close $f } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f x - if {[catch {tls::socket -myaddr 127.0.0.1 \ + if {[catch {tls::socket -myaddr 127.0.0.1 -require 0 \ -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8830} sock]} { - set x $sock + set x $sock } else { - puts $sock hello + puts $sock hello catch {flush $sock} - lappend x [gets $f] - close $sock + lappend x [gets $f] + close $sock } close $f set x } {ready {hello 127.0.0.1}} @@ -422,37 +426,38 @@ test tlsIO-2.4 {tcp connection with server interface specified} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x done"] + set timer [after 2000 [list set x done]] } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr localhost 8831 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr localhost 8831 \]" puts $f { proc accept {sock addr port} { - global x - puts "[gets $sock]" - close $sock - set x done + global x + puts "[gets $sock]" + close $sock + set x done } puts ready vwait x after cancel $timer close $f } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ + if {[catch {tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey localhost 8831} sock]} { - set x $sock + set x $sock } else { - puts $sock hello + puts $sock hello flush $sock - lappend x [gets $f] - close $sock + lappend x [gets $f] + close $sock } close $f set x } {ready hello} @@ -459,44 +464,46 @@ test tlsIO-2.5 {tcp connection with redundant server port} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x done"] + set timer [after 2000 [list set x done]] } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]" puts $f { proc accept {sock addr port} { - global x - puts "[gets $sock]" - close $sock - set x done + global x + puts "[gets $sock]" + close $sock + set x done } puts ready vwait x after cancel $timer close $f } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ + if {[catch {tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8832} sock]} { - set x $sock + set x $sock } else { - puts $sock hello + puts $sock hello flush $sock - lappend x [gets $f] - close $sock + lappend x [gets $f] + close $sock } close $f set x } {ready hello} + test tlsIO-2.6 {tcp connection} {socket} { set status ok - if {![catch {set sock [tls::socket 127.0.0.1 8833]}]} { + if {![catch {set sock [tls::socket -require 0 127.0.0.1 8833]}]} { if {![catch {gets $sock}]} { set status broken } close $sock } @@ -506,28 +513,29 @@ test tlsIO-2.7 {echo server, one line} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x done"] + set timer [after 2000 [list set x done]] } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834 \]" puts $f { proc accept {s a p} { - fileevent $s readable [list echo $s] + fileevent $s readable [list echo $s] fconfigure $s -translation lf -buffering line - } + } proc echo {s} { set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - puts $s $l - } + if {[eof $s]} { + global x + close $s + set x done + } else { + puts $s $l + } } puts ready vwait x after cancel $timer close $f @@ -534,11 +542,11 @@ puts done } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f - set s [tls::socket -certfile $clientCert -cafile $caCert \ + set s [tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8834] fconfigure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" after 1000 set x [gets $s] @@ -550,64 +558,69 @@ test tlsIO-2.8 {echo server, loop 50 times, single connection} {socket stdio} { set f [open script w] puts $f [list set auto_path $auto_path] puts $f { - package require tls + package prefer latest + package require tls } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835 \]" puts $f { + fconfigure $f -blocking 1 -buffering line proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } + fileevent $s readable [list echo $s] + fconfigure $s -blocking 0 -buffering line + } proc echo {s} { - global i - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - incr i - puts $s $l - } + global i + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } elseif {[string length $l] > 0} { + incr i + puts $s $l + } } set i 0 puts ready - set timer [after 20000 "set x done"] + set timer [after 20000 [list set x time-out]] vwait x after cancel $timer close $f - puts "done $i" + puts "$x $i" } close $f set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket -certfile $clientCert -cafile $caCert \ + fconfigure $f -blocking 1 -buffering line + gets $f var + set s [tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8835] - fconfigure $s -buffering line + fconfigure $s -blocking 1 -buffering line + tls::handshake $s catch { for {set x 0} {$x < 50} {incr x} { puts $s "hello abcdefghijklmnop" - gets $s + gets $s var } } close $s catch {set x [gets $f]} - close $f + catch {close $f} set x } {done 50} test tlsIO-2.9 {socket conflict} {socket stdio} { - set s [tls::socket -server accept 8828] + set s [tls::socket -server accept -require 0 8828] removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts -nonewline $f { + package prefer latest package require tls - tls::socket -server accept 8828 + tls::socket -server accept -require 0 8828 } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f after 100 @@ -616,12 +629,12 @@ set x } {1 {couldn't open socket: address already in use}} test tlsIO-2.10 {close on accept, accepted socket lives} {socket} { set done 0 - set timer [after 20000 "set done timed_out"] - set ss [tls::socket -server accept -certfile $serverCert -cafile $caCert \ + set timer [after 20000 [list set done timed_out]] + set ss [tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert \ -keyfile $serverKey 8830] proc accept {s a p} { global ss close $ss fileevent $s readable "readit $s" @@ -631,11 +644,11 @@ global done gets $s close $s set done 1 } - set cs [tls::socket -certfile $clientCert -cafile $caCert \ + set cs [tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey localhost 8830] close $cs vwait done after cancel $timer @@ -651,14 +664,14 @@ fconfigure $s -blocking 0 -buffering line set sock $s fileevent $s readable [list do_handshake $s] } - set s [tls::socket -server accept \ + set s [tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8400] set sock "" - set s2 [tls::socket -certfile $clientCert -cafile $caCert \ + set s2 [tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8400] # when doing an in-process client/server test, both sides need # to be non-blocking for the TLS handshake Also make sure to # return the channel to line buffering mode (TLS sets it to 'none'). fconfigure $s2 -blocking 0 -buffering line @@ -689,17 +702,18 @@ # certificate isn't specified. removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set timer [after 2000 "set x timed_out"] - set f [tls::socket -server accept 8828] + set timer [after 2000 [list set x timed_out]] + set f [tls::socket -server accept -require 0 8828] proc accept {file addr port} { global x set x done - close $file + close $file } puts ready vwait x after cancel $timer close $f @@ -706,15 +720,15 @@ puts $x } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f x - if {[catch {tls::socket 127.0.0.1 8828} msg]} { - set x $msg + if {[catch {tls::socket -require 0 127.0.0.1 8828} msg]} { + set x $msg } else { - lappend x [gets $f] - close $msg + lappend x [gets $f] + close $msg } lappend x [gets $f] close $f set x } {ready done {}} @@ -722,24 +736,24 @@ test tlsIO-3.1 {socket conflict} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" + puts $f "set f \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" puts $f { puts ready gets stdin close $f } close $f set f [open "|[list $::tcltest::tcltest script]" r+] gets $f - set x [list [catch {tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -server accept 8828} msg] \ + set x [list [catch {tls::socket -server accept -require 0 \ + -certfile $clientCert -cafile $caCert -keyfile $clientKey 8828} msg] \ $msg] puts $f bye close $f set x } {1 {couldn't open socket: address already in use}} @@ -747,31 +761,32 @@ test tlsIO-3.2 {server with several clients} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] + set t1 [after 30000 [list set x timed_out]] + set t2 [after 31000 [list set x timed_out]] + set t3 [after 32000 [list set x timed_out]] set counter 0 } - puts $f "set s \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" + puts $f "set s \[tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" puts $f { proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line } proc echo {s} { global x - set l [gets $s] - if {[eof $s]} { - close $s - set x done - } else { - puts $s $l - } + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } } puts ready vwait x after cancel $t1 vwait x @@ -782,19 +797,19 @@ puts $x } close $f set f [open "|[list $::tcltest::tcltest script]" r+] set x [gets $f] - set s1 [tls::socket \ + set s1 [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8828] fconfigure $s1 -buffering line - set s2 [tls::socket \ + set s2 [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8828] fconfigure $s2 -buffering line - set s3 [tls::socket \ + set s3 [tls::socket -require 0 \ -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,tlsIO-3.2,s1 @@ -816,14 +831,15 @@ # have seen intermittent hangs on Windows removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls gets stdin } - puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]" + puts $f "set s \[tls::socket -require 0 -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]" puts $f { fconfigure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello gets $s @@ -843,24 +859,23 @@ fconfigure $s -buffering line fileevent $s readable [list echo $s] } proc echo {s} { global x - set l [gets $s] - if {[eof $s]} { - close $s - set x done - } else { - puts $s $l - } - } - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8828] + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + set t1 [after 30000 [list set x timed_out]] + set t2 [after 31000 [list set x timed_out]] + set t3 [after 32000 [list set x timed_out]] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828] puts $p1 open puts $p2 open puts $p3 open vwait x vwait x @@ -882,11 +897,11 @@ set l } {{p1 bye done} {p2 bye done} {p3 bye done}} test tlsIO-4.2 {byte order problems, socket numbers, htons} {socket} { set x ok - if {[catch {tls::socket -server dodo 0x3000} msg]} { + if {[catch {tls::socket -server dodo -require 0 0x3000} msg]} { set x $msg } else { close $msg } set x @@ -893,28 +908,28 @@ } ok test tlsIO-5.1 {byte order problems, socket numbers, htons} \ {socket unixOnly notRoot} { set x {couldn't open socket: not owner} - if {![catch {tls::socket -server dodo 0x1} msg]} { - set x {htons problem, should be disallowed, are you running as SU?} + if {![catch {tls::socket -server dodo -require 0 0x1} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} close $msg } set x } {couldn't open socket: not owner} test tlsIO-5.2 {byte order problems, socket numbers, htons} {socket} { set x {couldn't open socket: port number too high} - if {![catch {tls::socket -server dodo 0x10000} msg]} { + if {![catch {tls::socket -server dodo -require 0 0x10000} msg]} { set x {port resolution problem, should be disallowed} close $msg } set x } {couldn't open socket: port number too high} test tlsIO-5.3 {byte order problems, socket numbers, htons} \ {socket unixOnly notRoot} { set x {couldn't open socket: not owner} - if {![catch {tls::socket -server dodo 21} msg]} { + if {![catch {tls::socket -server dodo -require 0 21} msg]} { set x {htons problem, should be disallowed, are you running as SU?} close $msg } set x } {couldn't open socket: not owner} @@ -924,11 +939,12 @@ # certificate isn't specified. removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { - package require tls + package prefer latest + 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+] @@ -935,15 +951,15 @@ proc bgerror args { global x set x $args } proc accept {s a p} {expr 10 / 0} - set s [tls::socket -server accept \ + set s [tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8848] puts $f hello close $f - set timer [after 10000 "set x timed_out"] + set timer [after 10000 [list set x timed_out]] vwait x after cancel $timer close $s rename bgerror {} set x @@ -952,21 +968,22 @@ test tlsIO-7.1 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls } - puts $f [list tls::socket -server accept \ + puts $f [list tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820] puts $f { proc accept args { global x set x done } puts ready - set timer [after 10000 "set x timed_out"] + set timer [after 10000 [list set x timed_out]] vwait x after cancel $timer } close $f set f [open "|[list $::tcltest::tcltest script]" r] @@ -986,20 +1003,21 @@ test tlsIO-7.2 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls } - puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821" + puts $f "tls::socket -server accept -require 0 -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821" puts $f { proc accept args { global x set x done } puts ready - set timer [after 10000 "set x timed_out"] + set timer [after 10000 [list set x timed_out]] vwait x after cancel $timer } close $f set f [open "|[list $::tcltest::tcltest script]" r] @@ -1015,13 +1033,12 @@ lappend l [lindex $p 0] lappend l [string equal [lindex $p 2] 8821] } {3 127.0.0.1 0} test tlsIO-7.3 {testing socket specific options} {socket} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8822] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8822] set l [llength [fconfigure $s]] close $s update # A bug fixed in fconfigure for 8.3.4+ make this return 14 normally, # but 12 in older versions. @@ -1029,22 +1046,21 @@ } 1 # bug report #5812 fconfigure doesn't return value for '-sockname' test tlsIO-7.4 {testing socket specific options} {socket} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8823] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8823] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } set s1 [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - localhost 8823] - set timer [after 10000 "set x timed_out"] + localhost 8823] + set timer [after 10000 [list set x timed_out]] vwait x after cancel $timer close $s close $s1 set l "" @@ -1052,22 +1068,21 @@ } {8823 3} # bug report #5812 fconfigure doesn't return value for '-sockname' test tlsIO-7.5 {testing socket specific options} {socket unixOrPc} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8829] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } set s1 [tls::socket \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8829] - set timer [after 10000 "set x timed_out"] + set timer [after 10000 [list set x timed_out]] vwait x after cancel $timer close $s close $s1 set l "" @@ -1075,13 +1090,12 @@ } {127.0.0.1 8829 3} test tlsIO-8.1 {testing -async flag on sockets} {socket} { # NOTE: This test may fail on some Solaris 2.4 systems. # See notes in Tcl's socket.test. - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8830] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830] proc accept {s a p} { global x # when doing an in-process client/server test, both sides need # to be non-blocking for the TLS handshake. Also make sure # to return the channel to line buffering mode. @@ -1090,11 +1104,11 @@ # Only OpenSSL 0.9.5a on Windows seems to need the after (delayed) # close, but it works just the same for all others. -hobbs after 500 close $s set x done } - set s1 [tls::socket \ + set s1 [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ -async localhost 8830] # when doing an in-process client/server test, both sides need # to be non-blocking for the TLS handshake Also make sure to # return the channel to line buffering mode (TLS sets it to 'none'). @@ -1109,11 +1123,12 @@ close $s close $s1 set z } bye -test tlsIO-9.1 {testing spurious events} {socket} { + +test tlsIO-9.1 {testing spurious (0 byte read) events} {socket} { set len 0 set spurious 0 set done 0 proc readlittle {s} { global spurious done len @@ -1132,27 +1147,24 @@ proc accept {s a p} { fconfigure $s -blocking 0 fileevent $s readable [list do_handshake $s readable readlittle \ -buffering none] } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8831] - set c [tls::socket \ + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8831] + set c [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ localhost 8831] # This differs from socket-9.1 in that both sides need to be # non-blocking because of TLS' required handshake fconfigure $c -blocking 0 puts -nonewline $c 01234567890123456789012345678901234567890123456789 flush $c - set timer2 [after 2000 [list close $c]] - set timer [after 10000 "set done timed_out"] + set timer [after 10000 [list set done timed_out]] + after 1000 [list close $c] vwait done after cancel $timer - after cancel $timer2 - catch {close $c} catch {close $s} list $spurious $len } {0 50} test tlsIO-9.2 {testing async write, fileevents, flush on close} {socket} { @@ -1182,16 +1194,15 @@ dputs "send \"[string replace $secondblock 10 end-3 ...]\" \ ([string length $secondblock]) down $s" puts -nonewline $s $secondblock close $s } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8832] - set c [tls::socket \ + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8839] + set c [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - localhost 8832] + localhost 8839] fconfigure $c -blocking 0 -trans lf -buffering line set count 0 puts $c hello proc readit {s} { global count done @@ -1202,16 +1213,17 @@ if {[eof $s]} { close $s set done 1 } } - fileevent $c readable "readit $c" + fileevent $c readable [list readit $c] set done 0 - set timer [after 10000 "set done timed_out"] + set timer [after 10000 [list set done timed_out]] vwait done after cancel $timer - close $s + catch {close $c} + catch {close $s} list $count $done } {65566 1} test tlsIO-9.3 {testing EOF stickyness} {unexplainedFailure socket} { # HOBBS: never worked correctly @@ -1243,14 +1255,13 @@ proc accept {s a p} { fconfigure $s -blocking 0 -buffering line -translation lf fileevent $s writable [list do_handshake $s writable write_then_close \ -buffering line -translation lf] } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8833] - set c [tls::socket \ + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8833] + set c [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ localhost 8833] fconfigure $c -blocking 0 -buffering line -translation lf fileevent $c readable "count_to_eof $c" set timer [after 2000 timerproc] @@ -1262,31 +1273,31 @@ removeFile script test tlsIO-10.1 {testing socket accept callback error handling} {socket} { set goterror 0 proc bgerror args {global goterror; set goterror 1} - set s [tls::socket -cafile $caCert -server accept 8898] + set s [tls::socket -server accept -require 0 -cafile $caCert 8898] proc accept {s a p} {close $s; error} - set c [tls::socket -cafile $caCert 127.0.0.1 8898] + set c [tls::socket -require 0 -cafile $caCert 127.0.0.1 8898] vwait goterror close $s close $c set goterror } 1 test tlsIO-11.1 {tcp connection} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { - set socket9_1_test_server [tls::socket -server accept \ + set socket9_1_test_server [tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834] proc accept {s a p} { tls::handshake $s puts $s done close $s } } - set s [tls::socket \ + set s [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8834] set r [gets $s] close $s sendCommand {close $socket9_1_test_server} @@ -1299,19 +1310,19 @@ } else { set port [expr {$tlsServerPort + [pid]%1024}] } sendCertValues sendCommand { - set socket9_2_test_server [tls::socket -server accept \ + set socket9_2_test_server [tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835] proc accept {s a p} { tls::handshake $s puts $s $p close $s } } - set s [tls::socket \ + set s [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ -myport $port $remoteServerIP 8835] set r [gets $s] close $s sendCommand {close $socket9_2_test_server} @@ -1323,11 +1334,11 @@ set result } ok test tlsIO-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { set status ok - if {![catch {set s [tls::socket \ + if {![catch {set s [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIp 8836]}]} { if {![catch {gets $s}]} { set status broken } @@ -1337,13 +1348,12 @@ } ok test tlsIO-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { - set socket10_6_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] + set socket10_6_test_server [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc accept {s a p} { tls::handshake $s fileevent $s readable [list echo $s] fconfigure $s -buffering line -translation crlf } @@ -1354,11 +1364,11 @@ } else { puts $s $l } } } - set f [tls::socket \ + set f [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fconfigure $f -translation crlf -buffering line puts $f hello set r [gets $f] @@ -1368,11 +1378,11 @@ } hello test tlsIO-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { - set socket10_7_test_server [tls::socket -server accept \ + set socket10_7_test_server [tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc accept {s a p} { tls::handshake $s fileevent $s readable [list echo $s] fconfigure $s -buffering line -translation crlf @@ -1384,11 +1394,11 @@ } else { puts $s $l } } } - set f [tls::socket \ + set f [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fconfigure $f -translation crlf -buffering line for {set cnt 0} {$cnt < 50} {incr cnt} { puts $f "hello, $cnt" @@ -1407,16 +1417,14 @@ } else { set conflictResult {1 {couldn't open socket: address already in use}} } test tlsIO-11.6 {socket conflict} {socket doTestsWithRemoteServer} { - set s1 [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] - if {[catch {set s2 [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836]} msg]} { + set s1 [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] + if {[catch {set s2 [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836]} msg]} { set result [list 1 $msg] } else { set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] close $s2 } @@ -1425,13 +1433,12 @@ } $conflictResult test tlsIO-11.7 {server with several clients} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { - set socket10_9_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] + set socket10_9_test_server [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc accept {s a p} { fconfigure $s -buffering line fileevent $s readable [list echo $s] } proc echo {s} { @@ -1441,19 +1448,19 @@ } else { puts $s $l } } } - set s1 [tls::socket \ + set s1 [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fconfigure $s1 -buffering line - set s2 [tls::socket \ + set s2 [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fconfigure $s2 -buffering line - set s3 [tls::socket \ + set s3 [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,tlsIO-11.7,s1 @@ -1472,13 +1479,13 @@ test tlsIO-11.8 {client with several servers} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { tls::init -certfile $serverCert -cafile $caCert -keyfile $serverKey - set s1 [tls::socket -server "accept 4003" 4003] - set s2 [tls::socket -server "accept 4004" 4004] - set s3 [tls::socket -server "accept 4005" 4005] + set s1 [tls::socket -server "accept 4003" -require 0 4003] + set s2 [tls::socket -server "accept 4004" -require 0 4004] + set s3 [tls::socket -server "accept 4005" -require 0 4005] proc handshake {s mp} { if {[eof $s]} { close $s } elseif {[catch {tls::handshake $s} result]} { # Some errors are normal. @@ -1495,13 +1502,13 @@ fconfigure $s -blocking 0 -buffering line fileevent $s readable [list handshake $s $mp] } } tls::init -certfile $clientCert -cafile $caCert -keyfile $clientKey - set s1 [tls::socket $remoteServerIP 4003] - set s2 [tls::socket $remoteServerIP 4004] - set s3 [tls::socket $remoteServerIP 4005] + set s1 [tls::socket -require 0 $remoteServerIP 4003] + set s2 [tls::socket -require 0 $remoteServerIP 4004] + set s3 [tls::socket -require 0 $remoteServerIP 4005] set l "" lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ [gets $s3] [gets $s3] [eof $s3] close $s1 close $s2 @@ -1513,30 +1520,29 @@ } set l } {4003 {} 1 4004 {} 1 4005 {} 1} test tlsIO-11.9 {accept callback error} {socket doTestsWithRemoteServer} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc accept {s a p} {expr 10 / 0} proc bgerror args { global x set x $args } sendCertValues if {[catch {sendCommand { set peername [fconfigure $callerSocket -peername] - set s [tls::socket \ + set s [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ [lindex $peername 0] 8836] close $s - }} msg]} { + }} msg]} { close $s error $msg } - set timer [after 10000 "set x timed_out"] + set timer [after 10000 [list set x timed_out]] vwait x after cancel $timer close $s rename bgerror {} set x @@ -1543,16 +1549,15 @@ } {{divide by zero}} test tlsIO-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { - set socket10_12_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] + set socket10_12_test_server [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc accept {s a p} {close $s} } - set s [tls::socket \ + set s [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] set p [fconfigure $s -peername] set n [fconfigure $s -sockname] set l "" @@ -1564,11 +1569,11 @@ test tlsIO-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { # remote equivalent of 9.1 sendCertValues sendCommand { - set socket_test_server [tls::socket -server accept \ + set socket_test_server [tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc handshake {s} { if {[eof $s]} { close $s } elseif {[catch {tls::handshake $s} result]} { @@ -1605,19 +1610,19 @@ } } else { incr len [string length $l] } } - set c [tls::socket \ + set c [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] # Get the buffering corrected fconfigure $c -buffering line # Put a byte into the client pipe to trigger TLS handshaking puts $c a fileevent $c readable [list readlittle $c] - set timer [after 10000 "set done timed_out"] + set timer [after 10000 [list set done timed_out]] vwait done after cancel $timer sendCommand {close $socket_test_server} list $spurious $len } {0 2690} @@ -1644,19 +1649,18 @@ set done {timed_out, EOF is not sticky} close $c } sendCertValues sendCommand { - set socket10_14_test_server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8836] + set socket10_14_test_server [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8836] proc accept {s a p} { tls::handshake $s after 100 close $s } } - set c [tls::socket \ + set c [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8836] fileevent $c readable "count_up $c" set after_id [after 1000 timed_out] vwait done @@ -1677,13 +1681,12 @@ } sendCertValues sendCommand { set firstblock [string repeat a 31] set secondblock [string repeat b 65535] - set l [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8845] + set l [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8845] proc accept {s a p} { tls::handshake $s fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line fileevent $s readable "readable $s" @@ -1702,18 +1705,18 @@ global secondblock puts -nonewline $s $secondblock close $s } } - set s [tls::socket \ + set s [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ $remoteServerIP 8845] fconfigure $s -blocking 0 -translation lf -buffering line set count 0 puts $s hello fileevent $s readable "readit $s" - set timer [after 10000 "set done timed_out"] + set timer [after 10000 [list set done timed_out]] vwait done after cancel $timer sendCommand {close $l} set count } 65566 @@ -1762,13 +1765,14 @@ set f [open script2 w] puts $f [list set tclsh $::tcltest::tcltest] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls } - puts $f "set f \[tls::socket -server accept \ + puts $f "set f \[tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828\]" puts $f { proc accept { file addr port } { close $file } @@ -1785,13 +1789,13 @@ after 5000 { set ok_to_proceed 1 } vwait ok_to_proceed # If we can still connect to the server, the socket got inherited. - if {[catch {tls::socket \ + if {[catch {tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 8828} msg]} { + 127.0.0.1 8828} msg]} { set x {server socket was not inherited} } else { close $msg set x {server socket was inherited} } @@ -1819,13 +1823,14 @@ set f [open script2 w] puts $f [list set tclsh $::tcltest::tcltest] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls } - puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert \ + puts $f "set f \[tls::socket -require 0 -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8829\]" puts $f { exec $tclsh script1 & puts $f testing flush $f @@ -1834,13 +1839,12 @@ } close $f # Create the server socket - set server [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8829] + set server [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829] proc accept { file host port } { # When the client connects, establish the read handler global server close $server fconfigure $file -blocking 0 @@ -1880,13 +1884,14 @@ set f [open script2 w] puts $f [list set tclsh $::tcltest::tcltest] puts $f [list set auto_path $auto_path] puts $f { + package prefer latest package require tls } - puts $f "set f \[tls::socket -server accept \ + puts $f "set f \[tls::socket -server accept -require 0 \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8930\]" puts $f { proc accept { file host port } { global tclsh fconfigure $file -buffering line @@ -1904,11 +1909,11 @@ exec $::tcltest::tcltest script2 & after 2000 set ok_to_proceed 1 vwait ok_to_proceed - set f [tls::socket \ + set f [tls::socket -require 0 \ -certfile $clientCert -cafile $caCert -keyfile $clientKey \ 127.0.0.1 8930] fconfigure $f -buffering full -blocking 0 # We need to put a byte into the read queue, otherwise the # TLS handshake doesn't finish @@ -1930,27 +1935,28 @@ # HOBBS: never tested removeFile script threadReap makeFile { - package require tls - set f [tls::socket -server accept 8828] + package prefer latest + package require tls + set f [tls::socket -server accept -require 0 8828] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } proc echo {s} { global i - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { incr i - puts $s $l - } + puts $s $l + } } set i 0 vwait x close $f @@ -1961,11 +1967,11 @@ # create a thread set serverthread [testthread create { source script } ] update after 1000 - set s [tls::socket 127.0.0.1 8828] + set s [tls::socket -require 0 127.0.0.1 8828] fconfigure $s -buffering line catch { puts $s "hello" gets $s result @@ -2015,52 +2021,51 @@ proc accept {s a p} { fconfigure $s -blocking 0 fileevent $s readable [list do_handshake $s readable readlittle \ -buffering none] } - set s [tls::socket -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 8831] - set c [tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - localhost 8831] + set s [tls::socket -server accept -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey 8838] + set c [tls::socket -require 0 -certfile $clientCert -cafile $caCert -keyfile $clientKey \ + localhost 8838] # only the client gets tls::import set res [tls::unimport $c] list $res [catch {close $c} err] $err \ [catch {close $s} err] $err } {{} 0 {} 0 {}} test tls-bug58-1.0 {test protocol negotiation failure} {socket} { # Following code is based on what was reported in bug #58. Prior # to fix the program would crash with a segfault. - proc Accept {sock args} { - fconfigure $sock -blocking 0; - fileevent $sock readable [list Handshake $sock] + proc accept {sock args} { + fconfigure $sock -blocking 0; + fileevent $sock readable [list Handshake $sock] } proc Handshake {sock} { - set ::done HAND - catch {tls::handshake $sock} msg - set ::done $msg + set ::done HAND + catch {tls::handshake $sock} msg + 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.3 - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey -request 0 \ - -require 0 -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 0 -tls1.3 1 \ - -server Accept 8831] + set s [tls::socket -server accept -request 0 -require 0 \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey \ + -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 0 -tls1.3 1 8837] # Client - Only propose TLS1.2 set c [tls::socket -async -cafile $caCert -request 0 -require 0 \ - -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 localhost 8831] + -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 localhost 8837] 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" - - "handshake failed: unsupported protocol" { - set ::done "handshake failed: wrong version number" - } + "handshake failed: wrong ssl version" - + "handshake failed: unsupported protocol" { + set ::done "handshake failed: wrong version number" + } } catch {close $c} catch {close $s} set ::done } {handshake failed: wrong version number} Index: win/rules.vc ================================================================== --- win/rules.vc +++ win/rules.vc @@ -22,11 +22,11 @@ # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 13 +RULES_VERSION_MINOR = 15 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif @@ -695,11 +695,11 @@ !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] + && [nmakehlp -V "$(_TCL_H)" "define TCL_MINOR_VERSION" >> versions.vc] !endif !if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] !endif !if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ @@ -879,14 +879,10 @@ !if [nmakehlp -f $(OPTS) "tcl8"] !message *** Build for Tcl8 TCL_BUILD_FOR = 8 !endif -!if [nmakehlp -f $(OPTS) "tk8"] -!message *** Build for Tk8 -TK_BUILD_FOR = 8 -!endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 @@ -1295,11 +1291,12 @@ !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib -PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) +# Even when building against Tcl 9, PRJLIBNAME8 must have "t" +PRJLIBNAME8 = $(PROJECT)$(VERSION)t$(SUFX:t=).$(EXT) # Even when building against Tcl 8, PRJLIBNAME9 must not have "t" PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" PRJLIBNAME = $(PRJLIBNAME8) !else @@ -1451,14 +1448,11 @@ !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif !endif !if "$(TCL_BUILD_FOR)" == "8" -OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 -!endif -!if "$(TK_BUILD_FOR)" == "8" -OPTDEFINES = $(OPTDEFINES) /DTK_MAJOR_VERSION=8 +OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 /DTK_MAJOR_VERSION=8 !endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both @@ -1586,11 +1580,11 @@ ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 -lflags = $(lflags) -nodefaultlib:libucrt.lib +lflags = $(lflags) -nodefaultlib:ucrt.lib !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows @@ -1645,20 +1639,20 @@ default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL) default-pkgindex: - @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl + @echo if {[package vsatisfies [package provide Tcl] 9.0]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } >> $(OUT_DIR)\pkgIndex.tcl !else default-pkgindex: - @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl + @echo if {[package vsatisfies [package provide Tcl] 9.0]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl @@ -1694,10 +1688,11 @@ # Alias for default-install-scripts default-install-libraries: default-install-scripts default-install-scripts: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' + @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) default-install-stubs: Index: win/targets.vc ================================================================== --- win/targets.vc +++ win/targets.vc @@ -51,10 +51,11 @@ # that the parent makefile will not define until after including rules-ext.vc !if "$(PRJ_HEADERS_PUBLIC)" != "" default-install: default-install-headers default-install-headers: @echo Installing headers to '$(INCLUDE_INSTALL_DIR)' + @if not exist "$(INCLUDE_INSTALL_DIR)" $(MKDIR) "$(INCLUDE_INSTALL_DIR)" @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)" !endif !if "$(DISABLE_STANDARD_TARGETS)" == "" DISABLE_STANDARD_TARGETS = 0