Index: Makefile.in
==================================================================
--- Makefile.in
+++ Makefile.in
@@ -99,11 +99,11 @@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
CC = @CC@
CCLD = @CCLD@
CFLAGS_DEFAULT = @CFLAGS_DEFAULT@
-CFLAGS_WARNING = @CFLAGS_WARNING@ -Wno-deprecated-declarations
+CFLAGS_WARNING = @CFLAGS_WARNING@
EXEEXT = @EXEEXT@
LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@
MAKE_LIB = @MAKE_LIB@
MAKE_STUB_LIB = @MAKE_STUB_LIB@
OBJEXT = @OBJEXT@
@@ -155,11 +155,11 @@
# must make sure that configure.ac checks for the necessary components
# that your library may use. TCL_DEFS can actually be a problem if
# you do not compile with a similar machine setup as the Tcl core was
# compiled with.
#DEFS = $(TCL_DEFS) @DEFS@ $(PKG_CFLAGS)
-DEFS = @DEFS@ $(PKG_CFLAGS) -DNO_SSL2 -DNO_SSL3
+DEFS = @DEFS@ $(PKG_CFLAGS)
# Move pkgIndex.tcl to 'BINARIES' var if it is generated in the Makefile
CONFIG_CLEAN_FILES = Makefile pkgIndex.tcl generic/tls.tcl.h
CLEANFILES = @CLEANFILES@
@@ -320,17 +320,10 @@
od -A n -v -t xC < '@srcdir@/library/tls.tcl' > tls.tcl.h.new.1
sed 's@[^0-9A-Fa-f]@@g;s@..@0x&, @g' < tls.tcl.h.new.1 > tls.tcl.h.new.2
rm -f tls.tcl.h.new.1
mv tls.tcl.h.new.2 @srcdir@/generic/tls.tcl.h
-# Create default DH parameters
-dh_params.h: @srcdir@/gen_dh_params Makefile
- sh @srcdir@/gen_dh_params @GEN_DH_PARAMS_ARGS@ > dh_params.h.new
- mv dh_params.h.new dh_params.h
-
-tls.o: dh_params.h
-
$(srcdir)/manifest.uuid:
printf "git-" >$(srcdir)/manifest.uuid
(cd $(srcdir); git rev-parse HEAD >>$(srcdir)/manifest.uuid || \
(printf "svn-r" >$(srcdir)/manifest.uuid ; \
svn info --show-item last-changed-revision >>$(srcdir)/manifest.uuid) || \
Index: README.txt
==================================================================
--- README.txt
+++ README.txt
@@ -1,38 +1,126 @@
-TclTLS 1.7.22
-==========
+Tool Command Language (TCL) Transport Layer Security (TLS) Extension
+
+Intro
+=====
+
+This package provides an extension which implements Secure Socket Layer (SSL)
+and Transport Layer Security (TLS) over Transmission Control Protocol (TCP)
+network communication channels. It utilizes either the OpenSSL or LibreSSL
+software library.
+
+Version 2.0 also provides a cryptography library providing TCL scripts access
+to the crypto capabilities of the OpenSSL library.
+
+
+Description
+===========
+
+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.
+
+
+Documentation
+=============
+
+See the doc directory for the full usage documentation.
+
+
+Compatibility
+=============
+
+This package requires TCL 8.5 or later.
+
+This package is compatible with:
+- OpenSSL v1.1.1 or later. See (http://www.openssl.org/
+- LibreSSL (TBD version)
+
+
+Installation
+============
+
+This package uses the Tcl Extension Architecture (TEA) to build and install on
+any supported Unix, Mac, or MS Windows system. Either the OpenSSL or LibreSSL
+software libraries must be built and available prior to building TCL TLS.
+
+UNIX and Linux
+--------------
+
+The standard TEA config, make and install process is supported.
+
+ $ cd tcltls
+ $ ./configure --enable-64bit --enable-deterministic --with-builtin-dh-params-size=2048
+ $ make
+ $ make test
+ $ make install
+
+The supported configure options include all of the standard TEA configure script
+options, plus:
+
+ --disable-tls1 disable TLS1 protocol
+ --disable-tls1_1 disable TLS1.1 protocol
+ --disable-tls1_2 disable TLS1.2 protocol
+ --disable-tls1_3 disable TLS1.3 protocol
+ --enable-deterministic enable deterministic DH parameters
+ --enable-ssl-fastpath enable using the underlying file descriptor for talking directly to the SSL library
+ --enable-hardening enable hardening attempts
+ --enable-static-ssl enable static linking to the SSL library
+ --with-builtin-dh-params-size=<bits> specify the size of the built-in, precomputed, DH params
+
+If either TCL or OpenSSL are installed in non-standard locations, the following
+configure options are available. For all options, see ./configure --help.
+
+ --with-tcl=<dir> path to where tclCondig.sh file resides
+ --with-tclinclude=<dir> directory containing the public Tcl header files
+ --with-openssl-dir=<dir> path to root directory of OpenSSL or LibreSSL installation
+ --with-openssl-includedir=<dir> path to include directory of OpenSSL or LibreSSL installation
+ --with-openssl-libdir=<dir> path to lib directory of OpenSSL or LibreSSL installation
+ --with-openssl-pkgconfig=<dir> path to root directory of OpenSSL or LibreSSL pkgconfigdir
+
+
+MacOS
+-----
+
+The standard TEA installation process is supported. Use the --with-tcl option
+to set the TCL path if the ActiveState or other non-Apple version of TCL is to
+be used.
+
+ $ cd tcltls
+ $ ./configure --with-tcl=/Library/Frameworks/Tcl.framework/
+ $ make
+ $ make test
+ $ make install
+
+
+Windows
+-------
-Release Date: Mon Oct 12 15:40:16 CDT 2020
+If installing with MinGW, use the TEA build process. If using MS Visual C
+(MSVC), see the win/README.txt file for the installation instructions.
+
-https://tcltls.rkeene.org/
+Copyrights
+==========
Original TLS Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
TLS 1.4.1 Copyright (C) 2000 Ajuba Solutions
TLS 1.6 Copyright (C) 2008 ActiveState Software Inc.
TLS 1.7 Copyright (C) 2016 Matt Newman, Ajuba Solutions, ActiveState
Software Inc, Roy Keene <tcltls@rkeene.org>
-
-TLS (aka SSL) Channel - can be layered on any bi-directional Tcl_Channel.
-
-Both client and server-side sockets are possible, and this code should work
-on any platform as it uses a generic mechanism for layering on SSL and Tcl.
-
-Full filevent sematics should also be intact - see tests directory for
-blocking and non-blocking examples.
-
-The current release is TLS 1.6, with binaries built against OpenSSL 0.9.8g.
-For best security and function, always compile from source with the latest
-official release of OpenSSL (http://www.openssl.org/).
-
-TLS 1.7 and newer require Tcl 8.4.0+, older versions may be used if older
-versions of Tcl need to be used.
-
-TclTLS requires OpenSSL or LibreSSL in order to be compiled and function.
+TLS 1.9-2.0 Copyright (C) 2023 Brian O'Hagan
+
+Acknowledgments
+===============
Non-exclusive credits for TLS are:
Original work: Matt Newman @ Novadigm
Updates: Jeff Hobbs @ ActiveState
Tcl Channel mechanism: Andreas Kupries
Impetus/Related work: tclSSL (Colin McCormack, Shared Technology)
SSLtcl (Peter Antman)
+
+License
+=======
This code is licensed under the same terms as the Tcl Core.
ADDED acinclude.m4
Index: acinclude.m4
==================================================================
--- /dev/null
+++ acinclude.m4
@@ -0,0 +1,222 @@
+#
+# Include the TEA standard macro set
+#
+
+builtin(include,tclconfig/tcl.m4)
+
+#
+# Add here whatever m4 macros you want to define for your package
+#
+
+AC_DEFUN([TCLTLS_SSL_OPENSSL], [
+ AC_CHECK_TOOL([PKG_CONFIG], [pkg-config])
+
+ dnl Disable support for TLS 1.0 protocol
+ AC_ARG_ENABLE([tls1], AS_HELP_STRING([--disable-tls1], [disable TLS1 protocol]), [
+ if test "${enableval}" = "no"; then
+ AC_DEFINE([NO_TLS1], [1], [Disable TLS1 protocol])
+ AC_MSG_CHECKING([for disable TLS1 protocol])
+ AC_MSG_RESULT('yes')
+ fi
+ ])
+
+ dnl Disable support for TLS 1.1 protocol
+ AC_ARG_ENABLE([tls1_1], AS_HELP_STRING([--disable-tls1_1], [disable TLS1.1 protocol]), [
+ if test "${enableval}" = "no"; then
+ AC_DEFINE([NO_TLS1_1], [1], [Disable TLS1.1 protocol])
+ AC_MSG_CHECKING([for disable TLS1.1 protocol])
+ AC_MSG_RESULT('yes')
+ fi
+ ])
+
+ dnl Disable support for TLS 1.2 protocol
+ AC_ARG_ENABLE([tls1_2], AS_HELP_STRING([--disable-tls1_2], [disable TLS1.2 protocol]), [
+ if test "${enableval}" = "no"; then
+ AC_DEFINE([NO_TLS1_2], [1], [Disable TLS1.2 protocol])
+ AC_MSG_CHECKING([for disable TLS1.2 protocol])
+ AC_MSG_RESULT('yes')
+ fi
+ ])
+
+ dnl Disable support for TLS 1.3 protocol
+ AC_ARG_ENABLE([tls1_3], AS_HELP_STRING([--disable-tls1_3], [disable TLS1.3 protocol]), [
+ if test "${enableval}" = "no"; then
+ AC_DEFINE([NO_TLS1_3], [1], [Disable TLS1.3 protocol])
+ AC_MSG_CHECKING([for disable TLS1.3 protocol])
+ AC_MSG_RESULT('yes')
+ fi
+ ])
+
+
+ dnl Determine if we have been asked to use a fast path if possible
+ AC_ARG_ENABLE([ssl-fastpath], AS_HELP_STRING([--enable-ssl-fastpath],
+ [enable using the underlying file descriptor for talking directly to the SSL library]), [
+ tcltls_ssl_fastpath="$enableval"
+ ], [
+ tcltls_ssl_fastpath='no'
+ ])
+ if test "$tcltls_ssl_fastpath" = 'yes'; then
+ AC_DEFINE(TCLTLS_SSL_USE_FASTPATH, [1], [Enable SSL library direct use of the underlying file descriptor])
+ fi
+ AC_MSG_CHECKING([for fast path])
+ AC_MSG_RESULT([$tcltls_ssl_fastpath])
+
+
+ dnl Enable hardening
+ AC_ARG_ENABLE([hardening], AS_HELP_STRING([--enable-hardening], [enable hardening attempts]), [
+ tcltls_enable_hardening="$enableval"
+ ], [
+ tcltls_enable_hardening='yes'
+ ])
+ if test "$tcltls_enable_hardening" = 'yes'; then
+ if test "$GCC" = 'yes' -o "$CC" = 'clang'; then
+ TEA_ADD_CFLAGS([-fstack-protector-all])
+ TEA_ADD_CFLAGS([-fno-strict-overflow])
+ AC_DEFINE([_FORTIFY_SOURCE], [2], [Enable fortification])
+ fi
+ fi
+ AC_MSG_CHECKING([for enable hardening])
+ AC_MSG_RESULT([$tcltls_enable_hardening])
+
+
+ dnl Determine if we have been asked to statically link to the SSL library
+ AC_ARG_ENABLE([static-ssl], AS_HELP_STRING([--enable-static-ssl], [enable static linking to the SSL library]), [
+ TCLEXT_TLS_STATIC_SSL="$enableval"
+ ], [
+ TCLEXT_TLS_STATIC_SSL='no'
+ ])
+ AC_MSG_CHECKING([for static linking of openSSL libraries])
+ AC_MSG_RESULT([$TCLEXT_TLS_STATIC_SSL])
+
+
+ dnl Set SSL files root path
+ AC_ARG_WITH([openssl-dir],
+ AS_HELP_STRING([--with-openssl-dir=<dir>],
+ [path to root directory of OpenSSL or LibreSSL installation]
+ ), [
+ openssldir="$withval"
+ ], [
+ openssldir=''
+ ]
+ )
+
+ dnl Set SSL include files path
+ AC_ARG_WITH([openssl-includedir],
+ AS_HELP_STRING([--with-openssl-includedir=<dir>],
+ [path to include directory of OpenSSL or LibreSSL installation]
+ ), [
+ opensslincludedir="$withval"
+ ], [
+ if test -n "$openssldir"; then
+ opensslincludedir="$openssldir/include/openssl"
+ else
+ opensslincludedir=''
+ fi
+ ]
+ )
+ AC_MSG_CHECKING([for OpenSSL include directory])
+ AC_MSG_RESULT($opensslincludedir)
+
+ dnl Set SSL include vars
+ if test -n "$opensslincludedir"; then
+ if test -f "$opensslincludedir/ssl.h"; then
+ TCLTLS_SSL_CFLAGS="-I$opensslincludedir"
+ TCLTLS_SSL_INCLUDES="-I$opensslincludedir"
+ else
+ AC_MSG_ERROR([Unable to locate ssl.h])
+ fi
+ else
+ TCLTLS_SSL_CFLAGS="-I$(includedir)/openssl"
+ TCLTLS_SSL_INCLUDES="-I$(includedir)/openssl"
+ fi
+
+ dnl Set SSL lib files path
+ AC_ARG_WITH([openssl-libdir],
+ AS_HELP_STRING([--with-openssl-libdir=<dir>],
+ [path to lib directory of OpenSSL or LibreSSL installation]
+ ), [
+ openssllibdir="$withval"
+ ], [
+ if test -n "$openssldir"; then
+ if test "$do64bit" == 'yes'; then
+ openssllibdir="$openssldir/lib64"
+ else
+ openssllibdir="$openssldir/lib"
+ fi
+ else
+ openssllibdir=''
+ fi
+ ]
+ )
+ AC_MSG_CHECKING([for OpenSSL lib directory])
+ AC_MSG_RESULT($openssllibdir)
+
+ dnl Set SSL lib vars
+ if test -n "$openssllibdir"; then
+ if test -f "$openssllibdir/libssl${SHLIB_SUFFIX}"; then
+ if test "${TCLEXT_TLS_STATIC_SSL}" == 'no'; then
+ TCLTLS_SSL_LIBS="-L$openssllibdir -lcrypto -lssl"
+ else
+ # Linux and Solaris
+ TCLTLS_SSL_LIBS="-Wl,-Bstatic `$PKG_CONFIG --static --libs crypto ssl` -Wl,-Bdynamic"
+ # HPUX
+ # -Wl,-a,archive ... -Wl,-a,shared_archive
+ fi
+ else
+ AC_MSG_ERROR([Unable to locate libssl${SHLIB_SUFFIX}])
+ fi
+ else
+ TCLTLS_SSL_LIBS="-lcrypto -lssl"
+ fi
+
+
+ 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 or LibreSSL])
+ AC_ARG_VAR([TCLTLS_SSL_INCLUDES], [C compiler include paths for OpenSSL or LibreSSL])
+ AC_ARG_VAR([TCLTLS_SSL_LIBS], [libraries to pass to the linker for OpenSSL or LibreSSL])
+
+
+ dnl Set location of pkgconfig files
+ AC_ARG_WITH([openssl-pkgconfig],
+ AS_HELP_STRING([--with-openssl-pkgconfig=<dir>],
+ [path to root directory of OpenSSL or LibreSSL pkgconfigdir]
+ ), [
+ opensslpkgconfigdir="$withval"
+ ], [
+ opensslpkgconfigdir=''
+ ]
+ )
+ AC_MSG_CHECKING([for OpenSSL pkgconfig])
+ AC_MSG_RESULT($opensslpkgconfigdir)
+
+
+ # Use Package Config tool to get config
+ pkgConfigExtraArgs=''
+ if test "${SHARED_BUILD}" == 0 -o "$TCLEXT_TLS_STATIC_SSL" = 'yes'; then
+ pkgConfigExtraArgs='--static'
+ fi
+
+ dnl Use pkg-config to find the libraries
+ if test -n "${PKG_CONFIG}"; then
+ dnl Temporarily update PKG_CONFIG_PATH
+ PKG_CONFIG_PATH_SAVE="${PKG_CONFIG_PATH}"
+ if test -n "${opensslpkgconfigdir}"; then
+ if ! test -f "${opensslpkgconfigdir}/openssl.pc"; then
+ AC_MSG_ERROR([Unable to locate ${opensslpkgconfigdir}/openssl.pc])
+ fi
+
+ PKG_CONFIG_PATH="${opensslpkgconfigdir}${PATH_SEPARATOR}${PKG_CONFIG_PATH}"
+ export PKG_CONFIG_PATH
+ 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
+ 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
+ PKG_CONFIG_PATH="${PKG_CONFIG_PATH_SAVE}"
+ fi
+])
ADDED doc/tls.html
Index: doc/tls.html
==================================================================
--- /dev/null
+++ doc/tls.html
@@ -0,0 +1,826 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<meta name="Copyright" content="1999 Matt Newman / 2004 Starfish Systems">
+<title>TLS (SSL) TCL Commands</title>
+<link rel="stylesheet" href="docs.css" type="text/css" media="all">
+</head>
+
+<body class="vsc-initialized">
+
+<h2>Tcl Tls Extension Documentation</h2>
+
+<dl>
+ <dd><a href="#NAME">NAME</a>
+ <dl>
+ <dd><b>tls</b> - binding to <b>OpenSSL</b> library
+ for socket and I/O channel communications.</dd>
+ </dl>
+ </dd>
+ <dd><a href="#SYNOPSIS">SYNOPSIS</a> </dd>
+ <dd><dl>
+ <dd><b>package require Tcl</b> <em>?<b>8.5</b>?</em></dd>
+ <dd><b>package require tls</b></dd>
+ <dt> </dt>
+ <dd><b>tls::init</b> <em>?options?</em> </dd>
+ <dd><b>tls::socket</b> <em>?options? host port</em></dd>
+ <dd><b>tls::socket</b> <em>?-server command? ?options? port</em></dd>
+ <dd><b>tls::handshake</b> <em> channel</em></dd>
+ <dd><b>tls::status</b> <em>?-local? channel</em></dd>
+ <dd><b>tls::connection</b> <em>channel</em></dd>
+ <dd><b>tls::import</b> <em>channel ?options?</em></dd>
+ <dd><b>tls::unimport</b> <em>channel</em></dd>
+ <dt> </dt>
+ <dd><b>tls::protocols</b></dd>
+ <dd><b>tls::version</b></dd>
+ </dl>
+ </dd>
+ <dd><a href="#COMMANDS">COMMANDS</a></dd>
+ <dd><a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a></dd>
+ <dd><a href="#HTTPS EXAMPLE">HTTPS EXAMPLE</a></dd>
+ <dd><a href="#SEE ALSO">SPECIAL CONSIDERATIONS</a></dd>
+ <dd><a href="#SEE ALSO">SEE ALSO</a></dd>
+</dl>
+
+<hr>
+
+<h3><a name="NAME">NAME</a></h3>
+
+<p><strong>tls</strong> - binding to <strong>OpenSSL</strong> library
+for socket and I/O channel communications.</p>
+
+<h3><a name="SYNOPSIS">SYNOPSIS</a></h3>
+
+<p><b>package require Tcl</b> <em>?<b>8.5</b>?</em><br>
+<b>package require tls</b><br>
+<br>
+<a href="#tls::init"><b>tls::init</b> <i>?options?</i></a><br>
+<a href="#tls::socket"><b>tls::socket</b> <i>?options? host port</i><br>
+<a href="#tls::socket"><b>tls::socket</b> <i>?-server command? ?options? port</i></a><br>
+<a href="#tls::status"><b>tls::status</b> <i>?-local? channel</i></a><br>
+<a href="#tls::connection"><b>tls::connection</b> <i>channel</i></a><br>
+<a href="#tls::handshake"><b>tls::handshake</b> <i>channel</i></a><br>
+<a href="#tls::import"><b>tls::import</b> <i>channel ?options?</i></a><br>
+<a href="#tls::unimport"><b>tls::unimport</b> <i>channel</i></a><br>
+<br>
+<a href="#tls::protocols"><b>tls::protocols</b></a><br>
+<a href="#tls::version"><b>tls::version</b></a><br>
+</p>
+
+<h3><a name="DESCRIPTION">DESCRIPTION</a></h3>
+
+<p>This extension provides TCL script access to secure socket communications
+using the Transport Layer Security (TLS) protocol. It provides a generic
+binding to <a href="http://www.openssl.org/">OpenSSL</a>, utilizing the
+<strong>Tcl_StackChannel</strong> API in Tcl 8.4 and higher.
+These sockets behave exactly the same as channels created using the built-in
+<strong>socket</strong> command, along with additional options for controlling
+the SSL session.
+</p>
+
+<h3><a name="COMMANDS">COMMANDS</a></h3>
+
+<p>Typically one would use the <strong>tls::socket </strong>command
+which provides compatibility with the native Tcl <strong>socket</strong>
+command. In such cases <strong>tls::import</strong> should not be
+used directly.</p>
+
+<dl>
+ <dt><a name="tls::init"><b>tls::init </b><i>?options?</i></a></dt>
+ <dd>Optional function to set the default options used by
+ <strong>tls::socket</strong>. If you call <strong>tls::import</strong>
+ directly this routine has no effect. Any of the options
+ that <strong>tls::socket</strong> accepts can be set
+ using this command, though you should limit your options
+ to only TLS related ones.</dd>
+ <dt> </dt>
+ <dt><a name="tls::socket"><b>tls::socket </b><em>?options?
+ host port</em></a></dt>
+ <dt><b>tls::socket</b><em> ?-server command? ?options? port</em></dt>
+ <dd>This is a helper function that utilizes the underlying
+ commands (<strong>tls::import</strong>). It behaves
+ exactly the same as the native Tcl <strong>socket</strong>
+ command except the options can also include any of the
+ applicable <a href="#tls::import"><strong>tls:import</strong></a>
+ options with one additional option:</dd>
+<blockquote>
+ <dl>
+ <dt><strong>-autoservername</strong> <em>bool</em></dt>
+ <dd>Automatically set the -servername argument to the <em>host</em>
+ argument (default is <em>false</em>).</dd>
+ </dl>
+</blockquote>
+
+ <dt><a name="tls::import"><b>tls::import </b><i>channel
+ ?options?</i></a></dt>
+ <dd>Add SSL/TLS encryption to a regular Tcl channel. It need
+ not be a socket, but must provide bi-directional flow. Also
+ set session parameters for SSL handshake.</dd>
+
+<blockquote>
+ <dl>
+ <dt><strong>-alpn</strong> <em>list</em></dt>
+ <dd>List of protocols to offer during Application-Layer
+ Protocol Negotiation (ALPN). For example: <em>h2</em> and
+ <em>http/1.1</em>, but not <em>h3</em> or <em>quic</em>.</dd>
+ <dt><strong>-cadir</strong> <em>dir</em></dt>
+ <dd>Set the CA certificates path. The default directory is platform
+ specific and can be set at compile time. This can be overridden
+ via the <b>SSL_CERT_DIR</b> environment variable.</dd>
+ <dt><strong>-cafile </strong><em>filename</em></dt>
+ <dd>Set the certificate authority (CA) certificates file. The default
+ is the cert.pem file in the OpsnSSL directory. This can also be
+ overridden via the <b>SSL_CERT_FILE</b> environment variable.</dd>
+ <dt><strong>-certfile</strong> <em>filename</em></dt>
+ <dd>Specify the filename with the certificate to use.</dd>
+ <dt><strong>-cert</strong> <em>filename</em></dt>
+ <dd>Specify the contents of a certificate to use, as a DER
+ encoded binary value (X.509 DER).</dd>
+ <dt><strong>-cipher</strong> <em>string</em></dt>
+ <dd>List of ciphers to use. String is a colon (":") separated list
+ of ciphers. Ciphers can be combined
+ using the <b>+</b> character. Prefixes can be used to permanently
+ remove ("!"), delete ("-"), or move a cypher to the end of
+ the list ("+"). Keywords <b>@STRENGTH</b> (sort by algorithm
+ key length), <b>@SECLEVEL=</b><i>n</i> (set security level to
+ n), and <b>DEFAULT</b> (use default cipher list, at start only)
+ can also be specified. See OpenSSL documentation for the full
+ list of valid values. (TLS 1.2 and earlier only)</dd>
+ <dt><strong>-ciphersuites</strong> <em>string</em></dt>
+ <dd>List of cipher suites to use. String is a colon (":")
+ separated list of cipher suite names. (TLS 1.3 only)</dd>
+ <dt><strong>-command</strong> <em>callback</em></dt>
+ <dd>Callback command to invoke at several points during the handshake.
+ This is used to pass errors and tracing information, and
+ it can allow Tcl scripts to perform their own certificate
+ validation in place of the default validation provided by
+ OpenSSL. See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a>
+ for further discussion.</dd>
+ <dt><strong>-dhparams </strong><em>filename</em></dt>
+ <dd>Specify the Diffie-Hellman parameters file.</dd>
+ <dt><strong>-keyfile</strong> <em>filename</em></dt>
+ <dd>Specify the private key file. (default is
+ value of -certfile)</dd>
+ <dt><strong>-key</strong> <em>filename</em></dt>
+ <dd>Specify the private key to use as a DER encoded value (PKCS#1 DER)</dd>
+ <dt><strong>-model</strong> <em>channel</em></dt>
+ <dd>Force this channel to share the same <em><strong>SSL_CTX</strong></em>
+ structure as the specified <em>channel</em>, and
+ therefore share callbacks etc.</dd>
+ <dt><strong>-password</strong> <em>callback</em></dt>
+ <dd>Callback command to invoke when OpenSSL needs to obtain a password.
+ Typically used to unlock the private key of a certificate. The
+ callback should return a string which represents the password
+ to be used. See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a>
+ for further discussion.</dd>
+ <dt><strong>-post_handshake</strong> <em>bool</em></dt>
+ <dd>Allow post-handshake ticket updates.</dd>
+ <dt><strong>-request </strong><em>bool</em></dt>
+ <dd>Request a certificate from peer during SSL handshake.
+ (default is <em>true</em>)</dd>
+ <dt><strong>-require</strong> <em>bool</em></dt>
+ <dd>Require a valid certificate from peer during SSL handshake.
+ If this is set to true, then <strong>-request</strong> must
+ also be set to true and a either a -cadir, -cafile, or platform
+ default must be provided in order to validate against.
+ (default is <em>false</em>)</dd>
+ <dt><strong>-security_level</strong> <em>integer</em></dt>
+ <dd>Set security level. Must be 0 to 5. The security level affects
+ the cipher suite encryption algorithms, supported ECC curves,
+ supported signature algorithms, DH parameter sizes, certificate
+ key sizes and signature algorithms. The default is 1.
+ Level 3 and higher disable support for session tickets and only
+ accept cipher suites that provide forward secrecy.</dd>
+ <dt><strong>-server</strong> <em>bool</em></dt>
+ <dd>Set to act as a server and respond with a server handshake when
+ a client connects and provides a client handshake.
+ (default is <em>false</em>)</dd>
+ <dt><strong>-servername</strong> <em>host</em></dt>
+ <dd>Specify server's hostname. Used to set the TLS 'Server Name
+ Indication' (SNI) extension. Set to the expected servername
+ in the server's certificate or one of the subjectAltName
+ alternates.</dd>
+ <dt><strong>-session_id</strong> <em>string</em></dt>
+ <dd>Session id to resume session.</dd>
+ <dt><strong>-ssl2</strong> <em>bool</em></dt>
+ <dd>Enable use of SSL v2. (default is <em>false</em>)</dd>
+ <dt><strong>-ssl3 </strong><em>bool</em></dt>
+ <dd>Enable use of SSL v3. (default is <em>false</em>)</dd>
+ <dt>-<strong>tls1</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1. (default is <em>true</em>)</dd>
+ <dt>-<strong>tls1.1</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1.1 (default is <em>true</em>)</dd>
+ <dt>-<strong>tls1.2</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1.2 (default is <em>true</em>)</dd>
+ <dt>-<strong>tls1.3</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1.3 (default is <em>true</em>)</dd>
+ <dt><strong>-validatecommand</strong> <em>callback</em></dt>
+ <dd>Callback command to invoke to verify or validate protocol config
+ parameters during the protocol negotiation phase. See
+ <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a>
+ for further discussion.</dd>
+ </dl>
+</blockquote>
+
+ <dt><a name="tls::unimport"><b>tls::unimport </b><i>channel</i></a></dt>
+ <dd>Provided for symmetry to <strong>tls::import</strong>, this
+ unstacks the encryption of a regular Tcl channel. An error
+ is thrown if TLS is not the top stacked channel type.</dd>
+ <dt> </dt>
+ <dt><a name="tls::handshake"><strong>tls::handshake</strong>
+ <em>channel</em></a></dt>
+ <dd>Forces handshake to take place, and returns 0 if
+ handshake is still in progress (non-blocking), or 1 if
+ the handshake was successful. If the handshake failed
+ this routine will throw an error.</dd>
+ <dt> </dt>
+ <dt><a name="tls::status"><strong>tls::status</strong>
+ <em>?</em><b>-local</b><em>? channel</em></a></dt>
+ <dd>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 <b>-local</b> is specified, then the
+ local certificate is used.</dd>
+<blockquote>
+ <b>SSL Status</b>
+ <dl>
+ <dt><strong>alpn</strong> <em>protocol</em></dt>
+ <dd>The protocol selected after Application-Layer Protocol
+ Negotiation (ALPN).</dd>
+ <dt><strong>cipher</strong> <em>cipher</em></dt>
+ <dd>The current cipher in use between for the channel.</dd>
+ <dt><strong>peername</strong> <em>name</em></dt>
+ <dd>The peername from the certificate.</dd>
+ <dt><strong>protocol</strong> <em>version</em></dt>
+ <dd>The protocol version used for the connection:
+ SSL2, SSL3, TLS1, TLS1.1, TLS1.2, TLS1.3, or unknown.</dd>
+ <dt><strong>sbits</strong> <em>n</em></dt>
+ <dd>The number of bits used for the session key.</dd>
+ <dt><strong>signatureHashAlgorithm</strong> <em>algorithm</em></dt>
+ <dd>The signature hash algorithm.</dd>
+ <dt><strong>signatureType</strong> <em>type</em></dt>
+ <dd>The signature type value.</dd>
+ <dt><strong>verifyDepth</strong> <em>n</em></dt>
+ <dd>Maximum depth for the certificate chain verification.
+ Default is -1, to check all.</dd>
+ <dt><strong>verifyMode</strong> <em>list</em></dt>
+ <dd>List of certificate verification modes.</dd>
+ <dt><strong>verifyResult</strong> <em>result</em></dt>
+ <dd>Certificate verification result.</dd>
+ <dt><strong>ca_names</strong> <em>list</em></dt>
+ <dd>List of the Certificate Authorities used to create the certificate.</dd>
+ </dl>
+</blockquote>
+<blockquote>
+ <b>Certificate Status</b>
+ <dl>
+ <dt><strong>all</strong> <em>string</em></dt>
+ <dd>Dump of all certificate info.</dd>
+
+ <dt><strong>version</strong> <em>value</em></dt>
+ <dd>The certificate version.</dd>
+ <dt><strong>serialNumber</strong> <em>n</em></dt>
+ <dd>The serial number of the certificate as a hex string.</dd>
+ <dt><strong>signature</strong> <em>algorithm</em></dt>
+ <dd>Cipher algorithm used for certificate signature.</dd>
+ <dt><strong>issuer</strong> <em>dn</em></dt>
+ <dd>The distinguished name (DN) of the certificate issuer.</dd>
+ <dt><strong>notBefore</strong> <em>date</em></dt>
+ <dd>The begin date for the validity of the certificate.</dd>
+ <dt><strong>notAfter</strong> <em>date</em></dt>
+ <dd>The expiration date for the certificate.</dd>
+ <dt><strong>subject</strong> <em>dn</em></dt>
+ <dd>The distinguished name (DN) of the certificate subject.
+ Fields include: Common Name (CN), Organization (O), Locality
+ or City (L), State or Province (S), and Country Name (C).</dd>
+ <dt><strong>issuerUniqueID</strong> <em>string</em></dt>
+ <dd>The issuer unique id.</dd>
+ <dt><strong>subjectUniqueID</strong> <em>string</em></dt>
+ <dd>The subject unique id.</dd>
+
+ <dt><strong>num_extensions</strong> <em>n</em></dt>
+ <dd>Number of certificate extensions.</dd>
+ <dt><strong>extensions</strong> <em>list</em></dt>
+ <dd>List of certificate extension names.</dd>
+ <dt><strong>authorityKeyIdentifier</strong> <em>string</em></dt>
+ <dd>(AKI) Key identifier of the Issuing CA certificate that signed
+ the SSL certificate as a hex string. This value matches the SKI
+ value of the Intermediate CA certificate.</dd>
+ <dt><strong>subjectKeyIdentifier</strong> <em>string</em></dt>
+ <dd>(SKI) Hash of the public key inside the certificate as a hex
+ string. Used to identify certificates that contain a particular
+ public key.</dd>
+ <dt><strong>subjectAltName</strong> <em>list</em></dt>
+ <dd>List of all of the alternative domain names, sub domains,
+ and IP addresses that are secured by the certificate.</dd>
+ <dt><strong>ocsp</strong> <em>list</em></dt>
+ <dd>List of all Online Certificate Status Protocol (OCSP) URLs.</dd>
+
+ <dt><strong>certificate</strong> <em>cert</em></dt>
+ <dd>The PEM encoded certificate.</dd>
+
+ <dt><strong>signatureAlgorithm</strong> <em>algorithm</em></dt>
+ <dd>Cipher algorithm used for the certificate signature.</dd>
+ <dt><strong>signatureValue</strong> <em>string</em></dt>
+ <dd>Certificate signature as a hex string.</dd>
+ <dt><strong>signatureDigest</strong> <em>version</em></dt>
+ <dd>Certificate signing digest as a hex string.</dd>
+ <dt><strong>publicKeyAlgorithm</strong> <em>algorithm</em></dt>
+ <dd>Certificate signature public key algorithm.</dd>
+ <dt><strong>publicKey</strong> <em>string</em></dt>
+ <dd>Certificate signature public key as a hex string.</dd>
+ <dt><strong>bits</strong> <em>n</em></dt>
+ <dd>Number of bits used for certificate signature key.</dd>
+ <dt><strong>self_signed</strong> <em>boolean</em></dt>
+ <dd>Whether the certificate signature is self signed.</dd>
+
+ <dt><strong>sha1_hash</strong> <em>hash</em></dt>
+ <dd>The SHA1 hash of the certificate as a hex string.</dd>
+ <dt><strong>sha256_hash</strong> <em>hash</em></dt>
+ <dd>The SHA256 hash of the certificate as a hex string.</dd>
+ </dl>
+</blockquote>
+
+ <dt><a name="tls::connection"><strong>tls::connection</strong>
+ <em>channel</em></a></dt>
+ <dd>Returns the current connection status of an SSL channel. The
+ result is a list of key-value pairs describing the connection.</dd>
+<blockquote>
+ <b>SSL Status</b>
+ <dl>
+ <dt><strong>state</strong> <em>state</em></dt>
+ <dd>State of the connection.</dd>
+ <dt><strong>servername</strong> <em>name</em></dt>
+ <dd>The name of the connected to server.</dd>
+ <dt><strong>protocol</strong> <em>version</em></dt>
+ <dd>The protocol version used for the connection:
+ SSL2, SSL3, TLS1, TLS1.1, TLS1.2, TLS1.3, or unknown.</dd>
+ <dt><strong>renegotiation_allowed</strong> <em>boolean</em></dt>
+ <dd>Whether protocol renegotiation is supported or not.</dd>
+ <dt><strong>security_level</strong> <em>level</em></dt>
+ <dd>The security level used for selection of ciphers, key size, etc.</dd>
+ <dt><strong>session_reused</strong> <em>boolean</em></dt>
+ <dd>Whether the session has been reused or not.</dd>
+ <dt><strong>is_server</strong> <em>boolean</em></dt>
+ <dd>Whether the connection is configured as a server (1) or client (0).</dd>
+ <dt><strong>compression</strong> <em>mode</em></dt>
+ <dd>Compression method.</dd>
+ <dt><strong>expansion</strong> <em>mode</em></dt>
+ <dd>Expansion method.</dd>
+ <dt><strong>caList</strong> <em>list</em></dt>
+ <dd>List of Certificate Authorities (CA) for X.509 certificate.</dd>
+ </dl>
+</blockquote>
+<blockquote>
+ <b>Cipher Info</b>
+ <dl>
+ <dt><strong>cipher</strong> <em>cipher</em></dt>
+ <dd>The current cipher in use for the connection.</dd>
+ <dt><strong>standard_name</strong> <em>name</em></dt>
+ <dd>The standard RFC name of cipher.</dd>
+ <dt><strong>algorithm_bits</strong> <em>n</em></dt>
+ <dd>The number of processed bits used for cipher.</dd>
+ <dt><strong>secret_bits</strong> <em>n</em></dt>
+ <dd>The number of secret bits used for cipher.</dd>
+ <dt><strong>min_version</strong> <em>version</em></dt>
+ <dd>The minimum protocol version for cipher.</dd>
+ <dt><strong>cipher_is_aead</strong> <em>boolean</em></dt>
+ <dd>Whether the cipher is Authenticated Encryption with
+ Associated Data (AEAD).</dd>
+ <dt><strong>cipher_id</strong> <em>id</em></dt>
+ <dd>The OpenSSL cipher id.</dd>
+ <dt><strong>description</strong> <em>string</em></dt>
+ <dd>A text description of the cipher.</dd>
+ <dt><strong>handshake_digest</strong> <em>boolean</em></dt>
+ <dd>Digest used during handshake.</dd>
+ </dl>
+</blockquote>
+<blockquote>
+ <b>Session Info</b>
+ <dl>
+ <dt><strong>alpn</strong> <em>protocol</em></dt>
+ <dd>The protocol selected after Application-Layer Protocol
+ Negotiation (ALPN).</dd>
+ <dt><strong>resumable</strong> <em>boolean</em></dt>
+ <dd>Whether the session can be resumed or not.</dd>
+ <dt><strong>start_time</strong> <em>seconds</em></dt>
+ <dd>Time since session started in seconds since epoch.</dd>
+ <dt><strong>timeout</strong> <em>seconds</em></dt>
+ <dd>Max duration of session in seconds before time-out.</dd>
+ <dt><strong>lifetime</strong> <em>seconds</em></dt>
+ <dd>Session ticket lifetime hint in seconds.</dd>
+ <dt><strong>session_id</strong> <em>binary_string</em></dt>
+ <dd>Unique session id for use in resuming the session.</dd>
+ <dt><strong>session_ticket</strong> <em>binary_string</em></dt>
+ <dd>Unique session ticket for use in resuming the session.</dd>
+ <dt><strong>ticket_app_data</strong> <em>binary_string</em></dt>
+ <dd>Unique session ticket application data.</dd>
+ <dt><strong>master_key</strong> <em>binary_string</em></dt>
+ <dd>Unique session master key.</dd>
+ <dt><strong>session_cache_mode</strong> <em>mode</em></dt>
+ <dd>Server cache mode (client, server, or both).</dd>
+ </dl>
+</blockquote>
+
+ <dt><a name="tls::protocols"><strong>tls::protocols</strong></a></dt>
+ <dd>Returns a list of the supported protocols. Valid values are:
+ <b>ssl2</b>, <b>ssl3</b>, <b>tls1</b>, <b>tls1.1</b>, <b>tls1.2</b>,
+ and <b>tls1.3</b>. Exact list depends on OpenSSL version and
+ compile time flags.</dd>
+
+ <dt><a name="tls::version"><strong>tls::version</strong></a></dt>
+ <dd>Returns the OpenSSL version string.</dd>
+</dl>
+
+<h3><a name="CALLBACK OPTIONS">CALLBACK OPTIONS</a></h3>
+
+<p>
+As indicated above, individual channels can be given their own callbacks
+to handle intermediate processing by the OpenSSL library, using the
+<strong>-command</strong>, <strong>-password</strong>, and
+<strong>-validate_command</strong> options passed to either of
+<strong>tls::socket</strong> or <strong>tls::import</strong>.
+If the callback generates an error, the <b>bgerror</b> command will be
+invoked with the error information.
+</p>
+
+<blockquote>
+<dl>
+
+ <dt><strong>-command</strong> <em>callback</em></dt>
+ <dd>
+ Invokes the specified <em>callback</em> script at several points
+ during the OpenSSL handshake and use. See below for the possible
+ arguments passed to the callback script. Values returned from the
+ callback are ignored.
+
+ <br>
+ <br>
+
+ <dl>
+
+ <dt>
+ <strong>error</strong> <em>channelId message</em>
+ </dt>
+ <dd>
+ This form of callback is invoked whenever an error occurs during the
+ initial connection, handshake, or I/O operations. The <em>message</em>
+ argument can be from the Tcl_ErrnoMsg, OpenSSL function
+ <code>ERR_reason_error_string()</code>, or a custom message.
+ </dd>
+
+ <br>
+
+ <dt>
+ <strong>info</strong> <em>channelId major minor message type</em>
+ </dt>
+ <dd>
+ This form of callback is invoked by the OpenSSL function
+ <code>SSL_set_info_callback()</code> during the initial connection
+ and handshake operations. The <em>type</em> argument is new for
+ TLS 1.8. The arguments are:
+ <br>
+ <ul>
+ <li>Possible values for <em>major</em> are:
+ <code>handshake, alert, connect, accept</code>.</li>
+ <li>Possible values for <em>minor</em> are:
+ <code>start, done, read, write, loop, exit</code>.</li>
+ <li>The <em>message</em> argument is a descriptive string which may
+ be generated either by <code>SSL_state_string_long()</code> or by
+ <code>SSL_alert_desc_string_long()</code>, depending on the context.</li>
+ <li>For alerts, the possible values for <em>type</em> are:
+ <code>warning, fatal, and unknown</code>. For others,
+ <code>info</code> is used.</li>
+ </ul>
+ </dd>
+
+ <dt>
+ <strong>message</strong> <em>channelId direction version content_type message</em>
+ </dt>
+ <dd>
+ This form of callback is invoked by the OpenSSL function
+ <code>SSL_set_msg_callback()</code> whenever a message is sent or
+ received during the initial connection, handshake, or I/O operations.
+ It is only available when OpenSSL is complied with the
+ <em>enable-ssl-trace</em> option. Arguments are: <em>direction</em>
+ is <b>Sent</b> or <b>Received</b>, <em>version</em> is the protocol
+ version, <em>content_type</em> is the message content type, and
+ <em>message</em> is more info from the <code>SSL_trace</code> API.
+ This callback is new for TLS 1.8.
+ </dd>
+ <br>
+
+ <dt>
+ <strong>session</strong> <em>channelId session_id ticket lifetime</em>
+ </dt>
+ <dd>
+ This form of callback is invoked by the OpenSSL function
+ <code>SSL_CTX_sess_set_new_cb()</code> whenever a new session id is
+ sent by the server during the initial connection and handshake, but
+ can also be received later if the <b>-post_handshake</b> option is
+ used. Arguments are: <em>session_id</em> is the current
+ session identifier, <em>ticket</em> is the session ticket info, and
+ <em>lifetime</em> is the the ticket lifetime in seconds.
+ This callback is new for TLS 1.8.
+ </dd>
+ <br>
+ </dl>
+ </dd>
+
+ <br>
+
+ <dt><strong>-password</strong> <em>callback</em></dt>
+ <dd>
+ Invokes the specified <em>callback</em> script when OpenSSL needs to
+ obtain a password. See below for the possible arguments passed to
+ the callback script. See below for valid return values.
+
+ <br>
+ <br>
+
+ <dl>
+
+ <dt>
+ <strong>password</strong> <em>rwflag size</em>
+ </dt>
+ <dd>
+ Invoked when loading or storing a PEM certificate with encryption.
+ Where <em>rwflag</em> is 0 for reading/decryption or 1 for
+ writing/encryption (can prompt user to confirm) and
+ <em>size</em> is the max password length in bytes.
+ The callback should return the password as a string.
+ Both arguments are new for TLS 1.8.
+ </dd>
+ </dd>
+
+ <br>
+
+
+ <dt><strong>-validatecommand</strong> <em>callback</em></dt>
+ <dd>
+ Invokes the specified <em>callback</em> script during handshake in
+ order to validate the provided value(s). See below for the possible
+ arguments passed to the callback script. If not specified, OpenSSL
+ will accept valid certificates and extensions.
+ To reject the value and abort the connection, the callback should return 0.
+ To accept the value and continue the connection, it should return 1.
+ To reject the value, but continue the connection, it should return 2.
+
+ <br>
+ <br>
+
+ <dl>
+
+ <dt>
+ <strong>alpn</strong> <em>channelId protocol match</em>
+ </dt>
+ <dd>
+ For servers, this form of callback is invoked when the client ALPN
+ extension is received. If <em>match</em> is true, <em>protocol</em>
+ is the first <b>-alpn</b> option specified protocol common to both
+ the client and server. If not, the first client specified protocol is
+ used. It is called after the hello and ALPN callbacks.
+ This callback is new for TLS 1.8.
+ </dd>
+
+ <br>
+
+ <dt>
+ <strong>hello</strong> <em>channelId servername</em>
+ </dt>
+ <dd>
+ 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.
+ This callback is new for TLS 1.8.
+ </dd>
+
+ <br>
+
+ <dt>
+ <strong>sni</strong> <em>channelId servername</em>
+ </dt>
+ <dd>
+ For servers, this form of callback is invoked when the Server Name
+ Indication (SNI) extension is received. The <em>servername</em>
+ argument is the client provided server name in the <b>-servername</b>
+ 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 callback.
+ This callback is new for TLS 1.8.
+ </dd>
+
+ <br>
+
+ <dt>
+ <strong>verify</strong> <em>channelId depth cert status error</em>
+ </dt>
+ <dd>
+ 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 certificate in the certificate chain.
+ <ul>
+ <li>The <em>depth</em> argument is the integer depth of the
+ certificate in the certificate chain, where 0 is the peer certificate
+ and higher values going up to the Certificate Authority (CA).</li>
+ <li>The <em>cert</em> argument is a list of key-value pairs similar
+ to those returned by
+ <a href="#tls::status"><strong>tls::status</strong></a>.</li>
+ <li>The <em>status</em> argument is the boolean validity of the
+ current certificate where 0 is invalid and 1 is valid.</li>
+ <li>The <em>error</em> argument is the error message, if any, generated
+ by <code>X509_STORE_CTX_get_error()</code>.</li>
+ </ul>
+ </dd>
+ <br>
+ </dl>
+ </dd>
+</dl>
+</blockquote>
+
+<p>
+Reference implementations of these callbacks are provided in the
+distribution as <strong>tls::callback</strong>, <strong>tls::password</strong>,
+and <strong>tls::validate_command</strong> respectively. Note that these are
+<em>sample</em> implementations only. In a more realistic deployment
+you would specify your own callback scripts on each TLS channel using the
+<strong>-command</strong>, <strong>-password</strong>, and <strong>-validate_command</strong> options.
+</p>
+
+<p>
+The default behavior when the <strong>-command</strong> and <strong>-validate_command</strong>
+options are not specified is for TLS to process the associated library callbacks
+internally. The default behavior when the <strong>-password</strong> option is not
+specified is for TLS to process the associated library callbacks by attempting
+to call <strong>tls::password</strong>.
+The difference between these two behaviors is a consequence of maintaining
+compatibility with earlier implementations.
+</p>
+
+<p>
+<em>
+The use of the reference callbacks <strong>tls::callback</strong>,
+<strong>tls::password</strong>, and <strong>tls::validate_command</strong>
+is not recommended. They may be removed from future releases.
+</em>
+</p>
+
+<h3><a name="DEBUG">DEBUG</a></h3>
+
+TLS key logging can be enabled by setting the environment variable
+<b>SSLKEYLOGFILE</b> to the name of the file to log to. Then whenever TLS
+key material is generated or received it will be logged to the file. This
+is useful for logging key data for network logging tools to use to
+decrypt the data.
+
+<p>
+The <strong>tls::debug</strong> variable provides some additional
+control over these reference callbacks. Its value is zero by default.
+Higher values produce more diagnostic output, and will also force the
+verify method in <strong>tls::callback</strong> to accept the
+certificate, even when it is invalid if the <b>tls::validate_command</b>
+callback is used for the <b>-validatecommand</b> option.
+</p>
+
+<p>
+<em>
+The use of the variable <strong>tls::debug</strong> is not recommended.
+It may be removed from future releases.
+</em>
+</p>
+
+<h4><a name="DEBUG_EXAMPLES">Debug Examples</a></h4>
+
+<p>These examples use the default Unix platform SSL certificates. For standard
+installations, -cadir and -cafile should not be needed. If your certificates
+are in non-standard locations, update -cadir or use -cafile as needed.</p>
+<br>
+Example #1: Use HTTP package
+
+
+<pre><code>
+package require http
+package require tls
+set url "https://www.tcl.tk/"
+
+http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs \
+ -command ::tls::callback -password ::tls::password -validatecommand ::tls::validate_command]
+
+# Check for error
+set token [http::geturl $url]
+if {[http::status $token] ne "ok"} {
+ puts [format "Error %s" [http::status $token]]
+}
+
+# Get web page
+set data [http::data $token]
+puts [string length $data]
+
+# Cleanup
+::http::cleanup $token
+</code></pre>
+
+Example #2: Use raw socket
+<pre><code>
+package require tls
+
+set url "www.tcl-lang.org"
+set port 443
+
+set ch [tls::socket -autoservername 1 -servername $url -request 1 -require 1 \
+ -alpn {http/1.1} -cadir /etc/ssl/certs -command ::tls::callback \
+ -password ::tls::password -validatecommand ::tls::validate_command $url $port]
+chan configure $ch -buffersize 65536
+tls::handshake $ch
+
+puts $ch "GET / HTTP/1.1"
+flush $ch
+after 500
+set data [read $ch]
+
+array set status [tls::status $ch]
+array set conn [tls::connection $ch]
+array set chan [chan configure $ch]
+close $ch
+parray status
+parray conn
+parray chan
+</code></pre>
+
+
+<h3><a name="HTTPS EXAMPLE">HTTPS EXAMPLE</a></h3>
+
+<p>These examples use the default Unix platform SSL certificates. For standard
+installations, -cadir and -cafile should not be needed. If your certificates
+are in non-standard locations, update -cadir or use -cafile as needed.</p>
+
+Example #1: Get web page
+
+<pre><code>
+package require http
+package require tls
+set url "https://www.tcl.tk/"
+
+http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
+
+# Check for error
+set token [http::geturl $url]
+if {[http::status $token] ne "ok"} {
+ puts [format "Error %s" [http::status $token]]
+}
+
+# Get web page
+set data [http::data $token]
+puts $data
+
+# Cleanup
+::http::cleanup $token
+</code></pre>
+
+Example #2: Download file
+
+<pre><code>
+package require http
+package require tls
+
+set url "https://wiki.tcl-lang.org/sitemap.xml"
+set filename [file tail $url]
+
+http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
+
+# Get file
+set ch [open $filename wb]
+set token [::http::geturl $url -blocksize 65536 -channel $ch]
+
+# Cleanup
+close $ch
+::http::cleanup $token
+</code></pre>
+
+<h3><a name="SPECIAL CONSIDERATIONS">SPECIAL CONSIDERATIONS</a></h3>
+
+<p>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 <strong>tls::protocols</strong> commands to obtain the supported
+protocol versions.</p>
+
+<h3><a name="SEE ALSO">SEE ALSO</a></h3>
+
+<p><strong>socket</strong>, <strong>fileevent</strong>, <strong>http</strong>,
+<a href="http://www.openssl.org/"><strong>OpenSSL</strong></a></p>
+
+<hr>
+
+<pre>
+Copyright © 1999 Matt Newman.
+Copyright © 2004 Starfish Systems.
+Copyright © 2023 Brian O'Hagan.
+</pre>
+</body>
+</html>
Index: generic/tls.c
==================================================================
--- generic/tls.c
+++ generic/tls.c
@@ -2,10 +2,11 @@
* Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com>
* some modifications:
* Copyright (C) 2000 Ajuba Solutions
* Copyright (C) 2002 ActiveState Corporation
* Copyright (C) 2004 Starfish Systems
+ * Copyright (C) 2023 Brian O'Hagan
*
* TLS (aka SSL) Channel - can be layered on any bi-directional
* Tcl_Channel (Note: Requires Trf Core Patch)
*
* This was built (almost) from scratch based upon observation of
@@ -21,39 +22,36 @@
*
*/
#include "tlsInt.h"
#include "tclOpts.h"
+#include <stdio.h>
#include <stdlib.h>
+#include <openssl/rsa.h>
+#include <openssl/safestack.h>
+
+/* Min OpenSSL version */
+#if OPENSSL_VERSION_NUMBER < 0x10101000L
+#error "Only OpenSSL v1.1.1 or later is supported"
+#endif
/*
* External functions
*/
/*
* Forward declarations
*/
-#define F2N( key, dsp) \
+#define F2N(key, dsp) \
(((key) == NULL) ? (char *) NULL : \
Tcl_TranslateFileName(interp, (key), (dsp)))
-#define REASON() ERR_reason_error_string(ERR_get_error())
-
-static void InfoCallback(const SSL *ssl, int where, int ret);
-
-static Tcl_ObjCmdProc CiphersObjCmd;
-static Tcl_ObjCmdProc HandshakeObjCmd;
-static Tcl_ObjCmdProc ImportObjCmd;
-static Tcl_ObjCmdProc StatusObjCmd;
-static Tcl_ObjCmdProc VersionObjCmd;
-static Tcl_ObjCmdProc MiscObjCmd;
-static Tcl_ObjCmdProc UnimportObjCmd;
static SSL_CTX *CTX_Init(State *statePtr, int isServer, int proto, char *key,
- char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1,
- int key_asn1_len, int cert_asn1_len, char *CAdir, char *CAfile,
- char *ciphers, char *DHparams);
+ char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1,
+ int key_asn1_len, int cert_asn1_len, char *CApath, char *CAfile,
+ char *ciphers, char *ciphersuites, int level, char *DHparams);
static int TlsLibInit(int uninitialize);
#define TLS_PROTO_SSL2 0x01
#define TLS_PROTO_SSL3 0x02
@@ -61,36 +59,11 @@
#define TLS_PROTO_TLS1_1 0x08
#define TLS_PROTO_TLS1_2 0x10
#define TLS_PROTO_TLS1_3 0x20
#define ENABLED(flag, mask) (((flag) & (mask)) == (mask))
-/*
- * Static data structures
- */
-
-#ifndef OPENSSL_NO_DH
-#include "dh_params.h"
-#endif
-
-/*
- * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2
- * libraries instead of the current OpenSSL libraries.
- */
-
-#ifdef BSAFE
-#define PRE_OPENSSL_0_9_4 1
-#endif
-
-/*
- * Pre OpenSSL 0.9.4 Compat
- */
-
-#ifndef STACK_OF
-#define STACK_OF(x) STACK
-#define sk_SSL_CIPHER_num(sk) sk_num((sk))
-#define sk_SSL_CIPHER_value( sk, index) (SSL_CIPHER*)sk_value((sk), (index))
-#endif
+#define SSLKEYLOGFILE "SSLKEYLOGFILE"
/*
* Thread-Safe TLS Code
*/
@@ -98,90 +71,106 @@
#define OPENSSL_THREAD_DEFINES
#include <openssl/opensslconf.h>
#ifdef OPENSSL_THREADS
#include <openssl/crypto.h>
+#include <openssl/ssl.h>
/*
* Threaded operation requires locking callbacks
* Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL.
*/
static Tcl_Mutex *locks = NULL;
static int locksCount = 0;
static Tcl_Mutex init_mx;
-
-void CryptoThreadLockCallback(int mode, int n, const char *file, int line) {
-
- if (mode & CRYPTO_LOCK) {
- /* This debugging is turned off by default -- it's too noisy. */
- /* dprintf("Called to lock (n=%i of %i)", n, locksCount); */
- Tcl_MutexLock(&locks[n]);
- } else {
- /* dprintf("Called to unlock (n=%i of %i)", n, locksCount); */
- Tcl_MutexUnlock(&locks[n]);
- }
-
- /* dprintf("Returning"); */
-
- return;
- file = file;
- line = line;
-}
-
-unsigned long CryptoThreadIdCallback(void) {
- unsigned long ret;
-
- dprintf("Called");
-
- ret = (unsigned long) Tcl_GetCurrentThread();
-
- dprintf("Returning %lu", ret);
-
- return(ret);
-}
#endif /* OPENSSL_THREADS */
#endif /* TCL_THREADS */
+
+/********************/
+/* Callbacks */
+/********************/
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Eval Callback Command --
+ *
+ * Eval callback command and catch any errors
+ *
+ * Results:
+ * 0 = Command returned fail or eval returned TCL_ERROR
+ * 1 = Command returned success or eval returned TCL_OK
+ *
+ * Side effects:
+ * Evaluates callback command
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+EvalCallback(Tcl_Interp *interp, State *statePtr, Tcl_Obj *cmdPtr) {
+ int code, ok = 0;
+
+ dprintf("Called");
+
+ Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve((ClientData) 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);
+ 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);
+ } else {
+ /* Error - reject the certificate */
+ dprintf("Tcl_BackgroundError");
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
+#endif
+ }
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) interp);
+ return ok;
+}
/*
*-------------------------------------------------------------------
*
* InfoCallback --
*
- * monitors SSL connection process
+ * Monitors SSL connection process
*
* Results:
* None
*
* Side effects:
* Calls callback (if defined)
+ *
*-------------------------------------------------------------------
*/
static void
-InfoCallback(const SSL *ssl, int where, int ret)
-{
+InfoCallback(const SSL *ssl, int where, int ret) {
State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
+ Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr;
- const char *major, *minor;
+ char *major; char *minor;
dprintf("Called");
if (statePtr->callback == (Tcl_Obj*)NULL)
return;
- cmdPtr = Tcl_DuplicateObj(statePtr->callback);
-
-#if 0
- if (where & SSL_CB_ALERT) {
- sev = SSL_alert_type_string_long(ret);
- if (strcmp( sev, "fatal")==0) { /* Map to error */
- Tls_Error(statePtr, SSL_ERROR(ssl, 0));
- return;
- }
- }
-#endif
if (where & SSL_CB_HANDSHAKE_START) {
major = "handshake";
minor = "start";
} else if (where & SSL_CB_HANDSHAKE_DONE) {
major = "handshake";
@@ -197,274 +186,751 @@
else if (where & SSL_CB_LOOP) minor = "loop";
else if (where & SSL_CB_EXIT) minor = "exit";
else minor = "unknown";
}
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( "info", -1));
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) );
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( major, -1) );
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( minor, -1) );
-
- if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) {
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( SSL_state_string_long(ssl), -1) );
- } else if (where & SSL_CB_ALERT) {
- const char *cp = (char *) SSL_alert_desc_string_long(ret);
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( cp, -1) );
+ /* Create command to eval with fn, chan, major, minor, message, and type args */
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("info", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(major, -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(minor, -1));
+
+ if (where & SSL_CB_ALERT) {
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(SSL_alert_desc_string_long(ret), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(SSL_alert_type_string_long(ret), -1));
} else {
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( SSL_state_string_long(ssl), -1) );
- }
- Tcl_Preserve( (ClientData) statePtr->interp);
- Tcl_Preserve( (ClientData) statePtr);
-
- Tcl_IncrRefCount( cmdPtr);
- (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount( cmdPtr);
-
- Tcl_Release( (ClientData) statePtr);
- Tcl_Release( (ClientData) statePtr->interp);
-
-}
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(SSL_state_string_long(ssl), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("info", -1));
+ }
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ EvalCallback(interp, statePtr, cmdPtr);
+ Tcl_DecrRefCount(cmdPtr);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * MessageCallback --
+ *
+ * Monitors SSL protocol messages
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *
+ *-------------------------------------------------------------------
+ */
+#ifndef OPENSSL_NO_SSL_TRACE
+static void
+MessageCallback(int write_p, int version, int content_type, const void *buf, size_t len, SSL *ssl, void *arg) {
+ State *statePtr = (State*)arg;
+ Tcl_Interp *interp = statePtr->interp;
+ Tcl_Obj *cmdPtr;
+ char *ver, *type;
+ BIO *bio;
+ char buffer[15000];
+ buffer[0] = 0;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL)
+ return;
+
+ switch(version) {
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ case SSL2_VERSION:
+ ver = "SSLv2";
+ break;
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ case SSL3_VERSION:
+ ver = "SSLv3";
+ break;
+#endif
+ case TLS1_VERSION:
+ ver = "TLSv1";
+ break;
+ case TLS1_1_VERSION:
+ ver = "TLSv1.1";
+ break;
+ case TLS1_2_VERSION:
+ ver = "TLSv1.2";
+ break;
+ case TLS1_3_VERSION:
+ ver = "TLSv1.3";
+ break;
+ case 0:
+ ver = "none";
+ break;
+ default:
+ ver = "unknown";
+ break;
+ }
+
+ switch (content_type) {
+ case SSL3_RT_HEADER:
+ type = "Header";
+ break;
+ case SSL3_RT_INNER_CONTENT_TYPE:
+ type = "Inner Content Type";
+ break;
+ case SSL3_RT_CHANGE_CIPHER_SPEC:
+ type = "Change Cipher";
+ break;
+ case SSL3_RT_ALERT:
+ type = "Alert";
+ break;
+ case SSL3_RT_HANDSHAKE:
+ type = "Handshake";
+ break;
+ case SSL3_RT_APPLICATION_DATA:
+ type = "App Data";
+ break;
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ case DTLS1_RT_HEARTBEAT:
+ type = "Heartbeat";
+ break;
+#endif
+ default:
+ type = "unknown";
+ }
+
+ /* Needs compile time option "enable-ssl-trace". */
+ if ((bio = BIO_new(BIO_s_mem())) != NULL) {
+ int n;
+ SSL_trace(write_p, version, content_type, buf, len, ssl, (void *)bio);
+ n = BIO_read(bio, buffer, BIO_pending(bio) < 15000 ? BIO_pending(bio) : 14999);
+ n = (n<0) ? 0 : n;
+ buffer[n] = 0;
+ (void)BIO_flush(bio);
+ BIO_free(bio);
+ }
+
+ /* Create command to eval with fn, chan, direction, version, type, and message args */
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("message", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(write_p ? "Sent" : "Received", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(ver, -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(type, -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(buffer, -1));
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ EvalCallback(interp, statePtr, cmdPtr);
+ Tcl_DecrRefCount(cmdPtr);
+}
+#endif
/*
*-------------------------------------------------------------------
*
* VerifyCallback --
*
- * Monitors SSL certificate validation process.
- * This is called whenever a certificate is inspected
- * or decided invalid.
+ * Monitors SSL certificate validation process. Used to control the
+ * behavior when the SSL_VERIFY_PEER flag is set. This is called
+ * whenever a certificate is inspected or decided invalid. Called for
+ * each certificate in the cert chain.
+ *
+ * Checks:
+ * certificate chain is checked starting with the deepest nesting level
+ * (the root CA certificate) and worked upward to the peer's certificate.
+ * All signatures are valid, current time is within first and last validity time.
+ * Check that the certificate is issued by the issuer certificate issuer.
+ * Check the revocation status for each certificate.
+ * Check the validity of the given CRL and the cert revocation status.
+ * Check the policies of all the certificates
+ *
+ * Args
+ * preverify_ok indicates whether the certificate verification passed (1) or not (0)
*
* Results:
* A callback bound to the socket may return one of:
- * 0 - the certificate is deemed invalid
- * 1 - the certificate is deemed valid
+ * 0 - the certificate is deemed invalid, send verification
+ * failure alert to peer, and terminate handshake.
+ * 1 - the certificate is deemed valid, continue with handshake.
* empty string - no change to certificate validation
*
* Side effects:
* The err field of the currently operative State is set
* to a string describing the SSL negotiation failure reason
+ *
*-------------------------------------------------------------------
*/
static int
-VerifyCallback(int ok, X509_STORE_CTX *ctx)
-{
- Tcl_Obj *cmdPtr, *result;
- char *errStr, *string;
- Tcl_Size length;
+VerifyCallback(int ok, X509_STORE_CTX *ctx) {
+ Tcl_Obj *cmdPtr;
SSL *ssl = (SSL*)X509_STORE_CTX_get_ex_data(ctx, SSL_get_ex_data_X509_STORE_CTX_idx());
X509 *cert = X509_STORE_CTX_get_current_cert(ctx);
State *statePtr = (State*)SSL_get_app_data(ssl);
+ Tcl_Interp *interp = statePtr->interp;
int depth = X509_STORE_CTX_get_error_depth(ctx);
int err = X509_STORE_CTX_get_error(ctx);
- dprintf("Verify: %d", ok);
-
- if (!ok) {
- errStr = (char*)X509_verify_cert_error_string(err);
- } else {
- errStr = (char *)0;
- }
-
- if (statePtr->callback == (Tcl_Obj*)NULL) {
+ dprintf("Called");
+ dprintf("VerifyCallback: %d", ok);
+
+ if (statePtr->vcmd == (Tcl_Obj*)NULL) {
+ /* Use ok value if verification is required */
if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
return ok;
} else {
return 1;
}
- }
- cmdPtr = Tcl_DuplicateObj(statePtr->callback);
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( "verify", -1));
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) );
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewIntObj( depth) );
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tls_NewX509Obj( statePtr->interp, cert) );
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewIntObj( ok) );
-
- Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
- Tcl_NewStringObj( errStr ? errStr : "", -1) );
-
- Tcl_Preserve( (ClientData) statePtr->interp);
- Tcl_Preserve( (ClientData) statePtr);
-
- statePtr->flags |= TLS_TCL_CALLBACK;
-
- Tcl_IncrRefCount( cmdPtr);
- if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
- /* It got an error - reject the certificate. */
- Tcl_BackgroundError( statePtr->interp);
- ok = 0;
- } else {
- result = Tcl_GetObjResult(statePtr->interp);
- string = Tcl_GetStringFromObj(result, &length);
- /* An empty result leaves verification unchanged. */
- if (string != NULL && length > 0) {
- if (Tcl_GetIntFromObj(statePtr->interp, result, &ok) != TCL_OK) {
- Tcl_BackgroundError(statePtr->interp);
- ok = 0;
- }
- }
- }
- Tcl_DecrRefCount( cmdPtr);
-
- statePtr->flags &= ~(TLS_TCL_CALLBACK);
-
- Tcl_Release( (ClientData) statePtr);
- Tcl_Release( (ClientData) statePtr->interp);
-
- return(ok); /* By default, leave verification unchanged. */
+ } else if (cert == NULL || ssl == NULL) {
+ return 0;
+ }
+
+ dprintf("VerifyCallback: eval callback");
+
+ /* Create command to eval with fn, chan, depth, cert info list, status, and error args */
+ cmdPtr = Tcl_DuplicateObj(statePtr->vcmd);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("verify", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(depth));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tls_NewX509Obj(interp, cert));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(ok));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj((char*)X509_verify_cert_error_string(err), -1));
+
+ /* Prevent I/O while callback is in progress */
+ /* statePtr->flags |= TLS_TCL_CALLBACK; */
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ ok = EvalCallback(interp, statePtr, cmdPtr);
+ Tcl_DecrRefCount(cmdPtr);
+
+ dprintf("VerifyCallback: command result = %d", ok);
+
+ /* statePtr->flags &= ~(TLS_TCL_CALLBACK); */
+ return(ok); /* By default, leave verification unchanged. */
}
/*
*-------------------------------------------------------------------
*
* Tls_Error --
*
- * Calls callback with $fd and $msg - so the callback can decide
- * what to do with errors.
+ * Calls callback with list of errors.
*
* Side effects:
* The err field of the currently operative State is set
* to a string describing the SSL negotiation failure reason
+ *
*-------------------------------------------------------------------
*/
void
-Tls_Error(State *statePtr, char *msg)
-{
- Tcl_Obj *cmdPtr;
-
- dprintf("Called");
-
- if (msg && *msg) {
- Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL);
- } else {
- msg = Tcl_GetString(Tcl_GetObjResult(statePtr->interp));
- }
+Tls_Error(State *statePtr, char *msg) {
+ Tcl_Interp *interp = statePtr->interp;
+ Tcl_Obj *cmdPtr, *listPtr;
+ unsigned long err;
statePtr->err = msg;
- if (statePtr->callback == (Tcl_Obj*)NULL) {
- char buf[BUFSIZ];
- sprintf(buf, "SSL channel \"%s\": error: %s",
- Tcl_GetChannelName(statePtr->self), msg);
- Tcl_SetResult( statePtr->interp, buf, TCL_VOLATILE);
- Tcl_BackgroundError( statePtr->interp);
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL)
return;
- }
+
+ /* Create command to eval with fn, chan, and message args */
cmdPtr = Tcl_DuplicateObj(statePtr->callback);
-
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
- Tcl_NewStringObj("error", -1));
-
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("error", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ if (msg != NULL) {
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(msg, -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
- Tcl_NewStringObj(msg, -1));
+ } else if ((msg = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), (Tcl_Size *) NULL)) != NULL) {
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(msg, -1));
- Tcl_Preserve((ClientData) statePtr->interp);
- Tcl_Preserve((ClientData) statePtr);
+ } else {
+ listPtr = Tcl_NewListObj(0, NULL);
+ while ((err = ERR_get_error()) != 0) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(ERR_reason_error_string(err), -1));
+ }
+ Tcl_ListObjAppendElement(interp, cmdPtr, listPtr);
+ }
+ /* Eval callback command */
Tcl_IncrRefCount(cmdPtr);
- if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
- Tcl_BackgroundError(statePtr->interp);
- }
+ EvalCallback(interp, statePtr, cmdPtr);
Tcl_DecrRefCount(cmdPtr);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * KeyLogCallback --
+ *
+ * Write received key data to log file.
+ *
+ * Side effects:
+ * none
+ *
+ *-------------------------------------------------------------------
+ */
+void KeyLogCallback(const SSL *ssl, const char *line) {
+ char *str = getenv(SSLKEYLOGFILE);
+ FILE *fd;
- Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
+ dprintf("Called");
+
+ if (str) {
+ fd = fopen(str, "a");
+ fprintf(fd, "%s\n",line);
+ fclose(fd);
+ }
}
/*
*-------------------------------------------------------------------
*
- * PasswordCallback --
- *
- * Called when a password is needed to unpack RSA and PEM keys.
- * Evals any bound password script and returns the result as
- * the password string.
- *-------------------------------------------------------------------
- */
-#ifdef PRE_OPENSSL_0_9_4
-/*
- * No way to handle user-data therefore no way without a global
- * variable to access the Tcl interpreter.
-*/
-static int
-PasswordCallback(char *buf, int size, int verify)
-{
- return -1;
- buf = buf;
- size = size;
- verify = verify;
-}
-#else
-static int
-PasswordCallback(char *buf, int size, int verify, void *udata)
-{
+ * Password Callback --
+ *
+ * Called when a password for a private key loading/storing a PEM
+ * certificate with encryption. Evals callback script and returns
+ * the result as the password string in buf.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *
+ * Returns:
+ * Password size in bytes or -1 for an error.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+PasswordCallback(char *buf, int size, int rwflag, void *udata) {
State *statePtr = (State *) udata;
Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr;
- int result;
+ int code;
dprintf("Called");
+ /* If no callback, use default callback */
if (statePtr->password == NULL) {
- if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL)
- == TCL_OK) {
+ if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) == TCL_OK) {
char *ret = (char *) Tcl_GetStringResult(interp);
strncpy(buf, ret, (size_t) size);
return (int)strlen(ret);
} else {
return -1;
}
}
+ /* Create command to eval with fn, rwflag, and size args */
cmdPtr = Tcl_DuplicateObj(statePtr->password);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("password", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(rwflag));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(size));
- Tcl_Preserve((ClientData) statePtr->interp);
+ Tcl_Preserve((ClientData) interp);
Tcl_Preserve((ClientData) statePtr);
+ /* Eval callback command */
Tcl_IncrRefCount(cmdPtr);
- result = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
- if (result != TCL_OK) {
- Tcl_BackgroundError(statePtr->interp);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
+#endif
}
Tcl_DecrRefCount(cmdPtr);
Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
- if (result == TCL_OK) {
- char *ret = (char *) Tcl_GetStringResult(interp);
- strncpy(buf, ret, (size_t) size);
- return (int)strlen(ret);
+ /* If successful, pass back password string and truncate if too long */
+ if (code == TCL_OK) {
+ Tcl_Size len;
+ char *ret = (char *) Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
+ if (len > (Tcl_Size) size-1) {
+ len = (Tcl_Size) size-1;
+ }
+ strncpy(buf, ret, (size_t) len);
+ buf[len] = '\0';
+ Tcl_Release((ClientData) interp);
+ return((int) len);
+ }
+ Tcl_Release((ClientData) interp);
+ return -1;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Session Callback for Clients --
+ *
+ * Called when a new session is added to the cache. In TLS 1.3
+ * this may be received multiple times after the handshake. For
+ * earlier versions, this will be received during the handshake.
+ * This is the preferred way to obtain a resumable session.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *
+ * Return codes:
+ * 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_SESSION *session) {
+ State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
+ Tcl_Interp *interp = statePtr->interp;
+ Tcl_Obj *cmdPtr;
+ const unsigned char *ticket;
+ const unsigned char *session_id;
+ size_t len2;
+ unsigned int ulen;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL) {
+ return SSL_TLSEXT_ERR_OK;
+ } else if (ssl == NULL) {
+ return SSL_TLSEXT_ERR_NOACK;
+ }
+
+ /* Create command to eval with fn, chan, session id, session ticket, and lifetime args */
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("session", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+
+ /* Session id */
+ session_id = SSL_SESSION_get_id(session, &ulen);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(session_id, (Tcl_Size) ulen));
+
+ /* Session ticket */
+ SSL_SESSION_get0_ticket(session, &ticket, &len2);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(ticket, (Tcl_Size) len2));
+
+ /* Lifetime - number of seconds */
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewLongObj((long) SSL_SESSION_get_ticket_lifetime_hint(session)));
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ EvalCallback(interp, statePtr, cmdPtr);
+ Tcl_DecrRefCount(cmdPtr);
+ return 0;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ALPN Callback for Servers and NPN Callback for Clients --
+ *
+ * Perform protocol (http/1.1, h2, h3, etc.) selection for the
+ * incoming connection. Called after Hello and server callbacks.
+ * Where 'out' is selected protocol and 'in' is the peer advertised list.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *
+ * Return codes:
+ * SSL_TLSEXT_ERR_OK: ALPN protocol selected. The connection continues.
+ * SSL_TLSEXT_ERR_ALERT_FATAL: There was no overlap between the client's
+ * supplied list and the server configuration. The connection will be aborted.
+ * 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, const unsigned char **out, unsigned char *outlen,
+ const unsigned char *in, unsigned int inlen, void *arg) {
+ State *statePtr = (State*)arg;
+ Tcl_Interp *interp = statePtr->interp;
+ Tcl_Obj *cmdPtr;
+ int code, res;
+
+ dprintf("Called");
+
+ 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,
+ 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 */
+ res = SSL_TLSEXT_ERR_NOACK;
+ }
+
+ if (statePtr->vcmd == (Tcl_Obj*)NULL) {
+ return res;
+ }
+
+ /* Create command to eval with fn, chan, depth, cert info list, status, and error args */
+ cmdPtr = Tcl_DuplicateObj(statePtr->vcmd);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("alpn", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj((const char *) *out, -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewBooleanObj(res == SSL_TLSEXT_ERR_OK));
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ if ((code = EvalCallback(interp, statePtr, cmdPtr)) > 1) {
+ res = SSL_TLSEXT_ERR_NOACK;
+ } else if (code == 1) {
+ res = SSL_TLSEXT_ERR_OK;
+ } else {
+ res = SSL_TLSEXT_ERR_ALERT_FATAL;
+ }
+ Tcl_DecrRefCount(cmdPtr);
+ return res;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Advertise Protocols Callback for Next Protocol Negotiation (NPN) in ServerHello --
+ *
+ * called when a TLS server needs a list of supported protocols for Next
+ * Protocol Negotiation.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ *
+ * Return codes:
+ * 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, const unsigned char **out, unsigned int *outlen, void *arg) {
+ State *statePtr = (State*)arg;
+
+ dprintf("Called");
+
+ if (ssl == NULL || arg == NULL) {
+ return SSL_TLSEXT_ERR_NOACK;
+ }
+
+ /* Set protocols list */
+ if (statePtr->protos != NULL) {
+ *out = statePtr->protos;
+ *outlen = statePtr->protos_len;
+ } else {
+ *out = NULL;
+ *outlen = 0;
+ return SSL_TLSEXT_ERR_NOACK;
+ }
+ return SSL_TLSEXT_ERR_OK;
+}
+#endif
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *
+ * Return codes:
+ * SSL_TLSEXT_ERR_OK: SNI hostname is accepted. The connection continues.
+ * SSL_TLSEXT_ERR_ALERT_FATAL: SNI hostname is not accepted. The connection
+ * is aborted. Default for alert is SSL_AD_UNRECOGNIZED_NAME.
+ * SSL_TLSEXT_ERR_ALERT_WARNING: SNI hostname is not accepted, warning alert
+ * sent (not supported in TLSv1.3). The connection continues.
+ * 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, int *alert, void *arg) {
+ State *statePtr = (State*)arg;
+ Tcl_Interp *interp = statePtr->interp;
+ Tcl_Obj *cmdPtr;
+ int code, res;
+ const char *servername = NULL;
+
+ dprintf("Called");
+
+ 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 (!servername || servername[0] == '\0') {
+ return SSL_TLSEXT_ERR_NOACK;
+ }
+
+ if (statePtr->vcmd == (Tcl_Obj*)NULL) {
+ return SSL_TLSEXT_ERR_OK;
+ }
+
+ /* Create command to eval with fn, chan, and server name args */
+ cmdPtr = Tcl_DuplicateObj(statePtr->vcmd);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("sni", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(servername , -1));
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ if ((code = EvalCallback(interp, statePtr, cmdPtr)) > 1) {
+ res = SSL_TLSEXT_ERR_ALERT_WARNING;
+ *alert = SSL_AD_UNRECOGNIZED_NAME; /* Not supported by TLS 1.3 */
+ } else if (code == 1) {
+ res = SSL_TLSEXT_ERR_OK;
+ } else {
+ res = SSL_TLSEXT_ERR_ALERT_FATAL;
+ *alert = SSL_AD_UNRECOGNIZED_NAME; /* Not supported by TLS 1.3 */
+ }
+ Tcl_DecrRefCount(cmdPtr);
+ return res;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ClientHello Handshake Callback for Servers --
+ *
+ * Used by server to examine the server name indication (SNI) extension
+ * provided by the client in order to select an appropriate certificate to
+ * present, and make other configuration adjustments relevant to that server
+ * name and its configuration. This includes swapping out the associated
+ * SSL_CTX pointer, modifying the server's list of permitted TLS versions,
+ * changing the server's cipher list in response to the client's cipher list, etc.
+ * Called before SNI and ALPN callbacks.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *
+ * Return codes:
+ * SSL_CLIENT_HELLO_RETRY: suspend the handshake, and the handshake function will return immediately
+ * SSL_CLIENT_HELLO_ERROR: failure, terminate connection. Set alert to error code.
+ * SSL_CLIENT_HELLO_SUCCESS: success
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+HelloCallback(SSL *ssl, int *alert, void *arg) {
+ 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;
+
+ dprintf("Called");
+
+ if (statePtr->vcmd == (Tcl_Obj*)NULL) {
+ return SSL_CLIENT_HELLO_SUCCESS;
+ } else if (ssl == (const SSL *)NULL || arg == (void *)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 */
+ 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));
+
+ /* Eval callback command */
+ Tcl_IncrRefCount(cmdPtr);
+ if ((code = EvalCallback(interp, statePtr, cmdPtr)) > 1) {
+ res = SSL_CLIENT_HELLO_RETRY;
+ *alert = SSL_R_TLSV1_ALERT_USER_CANCELLED;
+ } else if (code == 1) {
+ res = SSL_CLIENT_HELLO_SUCCESS;
} else {
- return -1;
+ res = SSL_CLIENT_HELLO_ERROR;
+ *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR;
}
- verify = verify;
+ Tcl_DecrRefCount(cmdPtr);
+ return res;
}
-#endif
+/********************/
+/* Commands */
+/********************/
+
/*
*-------------------------------------------------------------------
*
* CiphersObjCmd -- list available ciphers
*
@@ -477,134 +943,207 @@
* 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
+};
+
static int
-CiphersObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- 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
- };
- Tcl_Obj *objPtr;
+CiphersObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Obj *objPtr = NULL;
SSL_CTX *ctx = NULL;
SSL *ssl = NULL;
STACK_OF(SSL_CIPHER) *sk;
char *cp, buf[BUFSIZ];
- int index, verbose = 0;
+ int index, verbose = 0, use_supported = 0;
+ const SSL_METHOD *method;
+ (void) clientData;
dprintf("Called");
- if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?");
+ if ((objc < 2) || (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 > 2) && Tcl_GetBooleanFromObj(interp, objv[2], &verbose) != TCL_OK) {
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj( interp, objv[1], protocols, "protocol", 0,
- &index) != TCL_OK) {
+ if ((objc > 3) && Tcl_GetBooleanFromObj(interp, objv[3], &use_supported) != TCL_OK) {
return TCL_ERROR;
}
- if (objc > 2 && Tcl_GetBooleanFromObj( interp, objv[2],
- &verbose) != TCL_OK) {
- return TCL_ERROR;
- }
+
+ ERR_clear_error();
+
switch ((enum protocol)index) {
- case TLS_SSL2:
-#if defined(NO_SSL2)
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(SSLv2_method()); break;
-#endif
- case TLS_SSL3:
-#if defined(NO_SSL3)
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(SSLv3_method()); break;
-#endif
- case TLS_TLS1:
-#if defined(NO_TLS1)
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLSv1_method()); break;
-#endif
- case TLS_TLS1_1:
-#if defined(NO_TLS1_1)
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLSv1_1_method()); break;
-#endif
- case TLS_TLS1_2:
-#if defined(NO_TLS1_2)
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLSv1_2_method()); break;
-#endif
- case TLS_TLS1_3:
-#if defined(NO_TLS1_3)
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLS_method()); break;
- SSL_CTX_set_min_proto_version (ctx, TLS1_3_VERSION);
- SSL_CTX_set_max_proto_version (ctx, TLS1_3_VERSION);
-#endif
- default:
- break;
- }
+ case TLS_SSL2:
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+ Tcl_AppendResult(interp, protocols[index], ": protocol not supported", 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", 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", 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", 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", 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", 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, REASON(), (char *) NULL);
+ Tcl_AppendResult(interp, GET_ERR_REASON(), NULL);
return TCL_ERROR;
}
+
ssl = SSL_new(ctx);
if (ssl == NULL) {
- Tcl_AppendResult(interp, REASON(), (char *) NULL);
+ Tcl_AppendResult(interp, GET_ERR_REASON(), NULL);
SSL_CTX_free(ctx);
return TCL_ERROR;
}
- objPtr = Tcl_NewListObj( 0, NULL);
-
- if (!verbose) {
- for (index = 0; ; index++) {
- cp = (char*)SSL_get_cipher_list( ssl, index);
- if (cp == NULL) break;
- Tcl_ListObjAppendElement( interp, objPtr,
- Tcl_NewStringObj( cp, -1) );
- }
+
+ /* Use list and order as would be sent in a ClientHello or all available ciphers */
+ if (use_supported) {
+ sk = SSL_get1_supported_ciphers(ssl);
} else {
sk = SSL_get_ciphers(ssl);
-
- for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) {
- size_t i;
- SSL_CIPHER_description( sk_SSL_CIPHER_value( sk, index),
- buf, sizeof(buf));
- for (i = strlen(buf) - 1; i ; i--) {
- if (buf[i] == ' ' || buf[i] == '\n' ||
- buf[i] == '\r' || buf[i] == '\t') {
- buf[i] = '\0';
- } else {
- break;
- }
- }
- Tcl_ListObjAppendElement( interp, objPtr,
- Tcl_NewStringObj( buf, -1) );
+ }
+
+ if (sk != NULL) {
+ if (!verbose) {
+ objPtr = Tcl_NewListObj(0, NULL);
+ for (int i = 0; i < sk_SSL_CIPHER_num(sk); i++) {
+ const SSL_CIPHER *c = sk_SSL_CIPHER_value(sk, i);
+ if (c == NULL) continue;
+
+ /* cipher name or (NONE) */
+ cp = SSL_CIPHER_get_name(c);
+ if (cp == NULL) break;
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(cp, -1));
+ }
+
+ } else {
+ objPtr = Tcl_NewStringObj("",0);
+ for (int i = 0; i < sk_SSL_CIPHER_num(sk); i++) {
+ const SSL_CIPHER *c = sk_SSL_CIPHER_value(sk, i);
+ if (c == NULL) continue;
+
+ /* textual description of the cipher */
+ if (SSL_CIPHER_description(c, buf, sizeof(buf)) != NULL) {
+ Tcl_AppendToObj(objPtr, buf, (Tcl_Size) strlen(buf));
+ } else {
+ Tcl_AppendToObj(objPtr, "UNKNOWN\n", 8);
+ }
+ }
+ }
+ if (use_supported) {
+ sk_SSL_CIPHER_free(sk);
}
}
SSL_free(ssl);
SSL_CTX_free(ctx);
- Tcl_SetObjResult( interp, objPtr);
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ProtocolsObjCmd -- list available protocols
+ *
+ * This procedure is invoked to process the "tls::protocols" command
+ * to list available protocols.
+ *
+ * Results:
+ * A standard Tcl result list.
+ *
+ * Side effects:
+ * none
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+ProtocolsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Obj *objPtr;
+ (void) clientData;
+
+ dprintf("Called");
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ ERR_clear_error();
+
+ objPtr = Tcl_NewListObj(0, NULL);
+
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL2], -1));
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) && !defined(OPENSSL_NO_SSL3_METHOD)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL3], -1));
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) && !defined(OPENSSL_NO_TLS1_METHOD)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1], -1));
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1_METHOD)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_1], -1));
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2_METHOD)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_2], -1));
+#endif
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_3], -1));
+#endif
+
+ Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*-------------------------------------------------------------------
@@ -620,78 +1159,76 @@
* Side effects:
* May force SSL negotiation to take place.
*
*-------------------------------------------------------------------
*/
-
-static int HandshakeObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Channel chan; /* The channel to set a mode on. */
- State *statePtr; /* client state for ssl socket */
- const char *errStr = NULL;
- int ret = 1;
- int err = 0;
-
- dprintf("Called");
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "channel");
- return(TCL_ERROR);
- }
-
- chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
- if (chan == (Tcl_Channel) NULL) {
- return(TCL_ERROR);
- }
-
- /*
- * Make sure to operate on the topmost channel
- */
- chan = Tcl_GetTopChannel(chan);
- if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
- Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", (char *)NULL);
- return(TCL_ERROR);
- }
- statePtr = (State *)Tcl_GetChannelInstanceData(chan);
-
- dprintf("Calling Tls_WaitForConnect");
- ret = Tls_WaitForConnect(statePtr, &err, 1);
- dprintf("Tls_WaitForConnect returned: %i", ret);
-
- if (
- ret < 0 && \
- ((statePtr->flags & TLS_TCL_ASYNC) && err == EAGAIN)
- ) {
- dprintf("Async set and err = EAGAIN");
- ret = 0;
- } else if (ret < 0) {
- errStr = statePtr->err;
- Tcl_ResetResult(interp);
- Tcl_SetErrno(err);
-
- if (!errStr || *errStr == 0) {
- errStr = Tcl_PosixError(interp);
- }
-
- Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL);
- dprintf("Returning TCL_ERROR with handshake failed: %s", errStr);
- return(TCL_ERROR);
- } else {
- if (err != 0) {
- dprintf("Got an error with a completed handshake: err = %i", err);
- }
-
- ret = 1;
- }
-
- dprintf("Returning TCL_OK with data \"%i\"", ret);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
- return(TCL_OK);
+static int HandshakeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Channel chan; /* The channel to set a mode on. */
+ State *statePtr; /* client state for ssl socket */
+ const char *errStr = NULL;
+ int ret = 1;
+ int err = 0;
+ (void) clientData;
+
+ dprintf("Called");
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel");
+ return(TCL_ERROR);
+ }
+
+ ERR_clear_error();
+
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], (Tcl_Size *) NULL), NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return(TCL_ERROR);
+ }
+
+ /* Make sure to operate on the topmost channel */
+ chan = Tcl_GetTopChannel(chan);
+ if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
+ Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
+ "\": not a TLS channel", NULL);
+ Tcl_SetErrorCode(interp, "TLS", "HANDSHAKE", "CHANNEL", "INVALID", (char *) NULL);
+ return(TCL_ERROR);
+ }
+ statePtr = (State *)Tcl_GetChannelInstanceData(chan);
+
+ dprintf("Calling Tls_WaitForConnect");
+ ret = Tls_WaitForConnect(statePtr, &err, 1);
+ dprintf("Tls_WaitForConnect returned: %i", ret);
+
+ if (ret < 0 && ((statePtr->flags & TLS_TCL_ASYNC) && (err == EAGAIN))) {
+ dprintf("Async set and err = EAGAIN");
+ ret = 0;
+ } else if (ret < 0) {
+ long result;
+ errStr = statePtr->err;
+ Tcl_ResetResult(interp);
+ Tcl_SetErrno(err);
+
+ if (!errStr || (*errStr == 0)) {
+ errStr = Tcl_PosixError(interp);
+ }
+
+ Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL);
+ if ((result = SSL_get_verify_result(statePtr->ssl)) != X509_V_OK) {
+ Tcl_AppendResult(interp, " due to \"", X509_verify_cert_error_string(result), "\"", (char *) NULL);
+ }
+ Tcl_SetErrorCode(interp, "TLS", "HANDSHAKE", "FAILED", (char *) NULL);
+ dprintf("Returning TCL_ERROR with handshake failed: %s", errStr);
+ return(TCL_ERROR);
+ } else {
+ if (err != 0) {
+ dprintf("Got an error with a completed handshake: err = %i", err);
+ }
+ ret = 1;
+ }
+
+ dprintf("Returning TCL_OK with data \"%i\"", ret);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
+ return(TCL_OK);
}
/*
*-------------------------------------------------------------------
*
@@ -707,121 +1244,118 @@
* Side effects:
* May modify the behavior of an IO channel.
*
*-------------------------------------------------------------------
*/
-
static int
-ImportObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
+ImportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
Tcl_Channel chan; /* The channel to set a mode on. */
State *statePtr; /* client state for ssl socket */
- SSL_CTX *ctx = NULL;
- Tcl_Obj *script = NULL;
- Tcl_Obj *password = NULL;
+ SSL_CTX *ctx = NULL;
+ Tcl_Obj *script = NULL;
+ Tcl_Obj *password = NULL;
+ Tcl_Obj *vcmd = NULL;
Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar;
int idx;
Tcl_Size len;
- int flags = TLS_TCL_INIT;
- int server = 0; /* is connection incoming or outgoing? */
- char *keyfile = NULL;
- char *certfile = NULL;
- unsigned char *key = NULL;
- Tcl_Size key_len = 0;
- unsigned char *cert = NULL;
- Tcl_Size cert_len = 0;
- char *ciphers = NULL;
- char *CAfile = NULL;
- char *CAdir = NULL;
- char *DHparams = NULL;
- char *model = NULL;
-#ifndef OPENSSL_NO_TLSEXT
- char *servername = NULL; /* hostname for Server Name Indication */
-#endif
+ int flags = TLS_TCL_INIT;
+ int server = 0; /* is connection incoming or outgoing? */
+ char *keyfile = NULL;
+ char *certfile = NULL;
+ unsigned char *key = NULL;
+ Tcl_Size key_len = 0;
+ unsigned char *cert = NULL;
+ Tcl_Size cert_len = 0;
+ char *ciphers = NULL;
+ char *ciphersuites = NULL;
+ char *CAfile = NULL;
+ char *CApath = NULL;
+ char *DHparams = NULL;
+ char *model = NULL;
+ char *servername = NULL; /* hostname for Server Name Indication */
+ const unsigned char *session_id = NULL;
+ Tcl_Obj *alpn = NULL;
int ssl2 = 0, ssl3 = 0;
int tls1 = 1, tls1_1 = 1, tls1_2 = 1, tls1_3 = 1;
- int proto = 0;
- int verify = 0, require = 0, request = 1;
+ int proto = 0, level = -1;
+ int verify = 0, require = 0, request = 1, post_handshake = 0;
+ (void) clientData;
dprintf("Called");
-#if defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_SSL3) && !defined(NO_SSL2)
- ssl2 = 1;
-#endif
-#if defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_SSL2) && !defined(NO_SSL3)
- ssl3 = 1;
-#endif
-#if defined(NO_TLS1)
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
tls1 = 0;
#endif
-#if defined(NO_TLS1_1)
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
tls1_1 = 0;
#endif
-#if defined(NO_TLS1_2)
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
tls1_2 = 0;
#endif
-#if defined(NO_TLS1_3)
+#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
tls1_3 = 0;
#endif
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
+ ERR_clear_error();
+
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], (Tcl_Size *) NULL), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
for (idx = 2; idx < objc; idx++) {
- char *opt = Tcl_GetString(objv[idx]);
+ char *opt = Tcl_GetStringFromObj(objv[idx], (Tcl_Size *)NULL);
if (opt[0] != '-')
break;
- OPTSTR( "-cadir", CAdir);
- OPTSTR( "-cafile", CAfile);
- OPTSTR( "-certfile", certfile);
- OPTSTR( "-cipher", ciphers);
- OPTOBJ( "-command", script);
- OPTSTR( "-dhparams", DHparams);
- OPTSTR( "-keyfile", keyfile);
- OPTSTR( "-model", model);
- OPTOBJ( "-password", password);
- OPTBOOL( "-require", require);
- OPTBOOL( "-request", request);
- OPTBOOL( "-server", server);
-#ifndef OPENSSL_NO_TLSEXT
- OPTSTR( "-servername", servername);
-#endif
-
- OPTBOOL( "-ssl2", ssl2);
- OPTBOOL( "-ssl3", ssl3);
- OPTBOOL( "-tls1", tls1);
- OPTBOOL( "-tls1.1", tls1_1);
- OPTBOOL( "-tls1.2", tls1_2);
- OPTBOOL( "-tls1.3", tls1_3)
+ OPTOBJ("-alpn", alpn);
+ OPTSTR("-cadir", CApath);
+ OPTSTR("-cafile", CAfile);
OPTBYTE("-cert", cert, cert_len);
+ OPTSTR("-certfile", certfile);
+ OPTSTR("-cipher", ciphers);
+ OPTSTR("-ciphers", ciphers);
+ OPTSTR("-ciphersuites", ciphersuites);
+ OPTOBJ("-command", script);
+ OPTSTR("-dhparams", DHparams);
OPTBYTE("-key", key, key_len);
+ OPTSTR("-keyfile", keyfile);
+ OPTSTR("-model", model);
+ OPTOBJ("-password", password);
+ OPTBOOL("-post_handshake", post_handshake);
+ OPTBOOL("-request", request);
+ OPTBOOL("-require", require);
+ OPTINT("-security_level", level);
+ OPTBOOL("-server", server);
+ OPTSTR("-servername", servername);
+ OPTSTR("-session_id", session_id);
+ OPTBOOL("-ssl2", ssl2);
+ OPTBOOL("-ssl3", ssl3);
+ OPTBOOL("-tls1", tls1);
+ OPTBOOL("-tls1.1", tls1_1);
+ OPTBOOL("-tls1.2", tls1_2);
+ OPTBOOL("-tls1.3", tls1_3);
+ OPTOBJ("-validatecommand", vcmd);
+ OPTOBJ("-vcmd", vcmd);
- OPTBAD( "option", "-cadir, -cafile, -cert, -certfile, -cipher, -command, -dhparams, -key, -keyfile, -model, -password, -require, -request, -server, -servername, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, or tls1.3");
+ OPTBAD("option", "-alpn, -cadir, -cafile, -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;
}
- if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
- if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
- if (verify == 0) verify = SSL_VERIFY_NONE;
+ if (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;
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);
@@ -832,12 +1366,13 @@
if (cert && !*cert) cert = NULL;
if (key && !*key) key = NULL;
if (certfile && !*certfile) certfile = NULL;
if (keyfile && !*keyfile) keyfile = NULL;
if (ciphers && !*ciphers) ciphers = NULL;
+ if (ciphersuites && !*ciphersuites) ciphersuites = NULL;
if (CAfile && !*CAfile) CAfile = NULL;
- if (CAdir && !*CAdir) CAdir = NULL;
+ if (CApath && !*CApath) CApath = NULL;
if (DHparams && !*DHparams) DHparams = NULL;
/* new SSL state */
statePtr = (State *) ckalloc((unsigned) sizeof(State));
memset(statePtr, 0, sizeof(State));
@@ -862,36 +1397,45 @@
if (len) {
statePtr->password = password;
Tcl_IncrRefCount(statePtr->password);
}
}
+
+ /* allocate validate command */
+ if (vcmd) {
+ (void) Tcl_GetStringFromObj(vcmd, &len);
+ if (len) {
+ statePtr->vcmd = vcmd;
+ Tcl_IncrRefCount(statePtr->vcmd);
+ }
+ }
if (model != NULL) {
int mode;
/* Get the "model" context */
chan = Tcl_GetChannel(interp, model, &mode);
if (chan == (Tcl_Channel) NULL) {
- Tls_Free((void *)statePtr);
+ Tls_Free((char *) statePtr);
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
- chan = Tcl_GetTopChannel(chan);
+ /*
+ * Make sure to operate on the topmost channel
+ */
+ chan = Tcl_GetTopChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
- Tcl_AppendResult(interp, "bad channel \"",
- Tcl_GetChannelName(chan), "\": not a TLS channel", (char *)NULL);
- Tls_Free((void *)statePtr);
+ Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
+ "\": not a TLS channel", NULL);
+ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "CHANNEL", "INVALID", (char *) NULL);
+ Tls_Free((char *) statePtr);
return TCL_ERROR;
}
ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx;
} else {
- if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key,
- cert, key_len, cert_len, CAdir, CAfile, ciphers,
- DHparams)) == (SSL_CTX*)0) {
- Tls_Free((void *)statePtr);
+ if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, cert, (int) key_len,
+ (int) cert_len, CApath, CAfile, ciphers, ciphersuites, level, DHparams)) == NULL) {
+ Tls_Free((char *) statePtr);
return TCL_ERROR;
}
}
statePtr->ctx = ctx;
@@ -911,78 +1455,204 @@
Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation);
Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking);
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
Tcl_SetChannelOption(interp, chan, "-blocking", "true");
dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan));
- statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), statePtr, (TCL_READABLE | TCL_WRITABLE), chan);
+ statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr,
+ (TCL_READABLE | TCL_WRITABLE), chan);
dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self));
if (statePtr->self == (Tcl_Channel) NULL) {
/*
* No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
*/
- Tls_Free((void *)statePtr);
+ Tls_Free((char *) statePtr);
return TCL_ERROR;
}
Tcl_SetChannelOption(interp, statePtr->self, "-translation", Tcl_DStringValue(&upperChannelTranslation));
Tcl_SetChannelOption(interp, statePtr->self, "-encoding", Tcl_DStringValue(&upperChannelEncoding));
Tcl_SetChannelOption(interp, statePtr->self, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar));
Tcl_SetChannelOption(interp, statePtr->self, "-blocking", Tcl_DStringValue(&upperChannelBlocking));
+ Tcl_DStringFree(&upperChannelTranslation);
+ Tcl_DStringFree(&upperChannelEncoding);
+ Tcl_DStringFree(&upperChannelEOFChar);
+ Tcl_DStringFree(&upperChannelBlocking);
/*
* SSL Initialization
*/
-
statePtr->ssl = SSL_new(statePtr->ctx);
if (!statePtr->ssl) {
/* SSL library error */
- Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(),
- (char *) NULL);
- Tls_Free((void *)statePtr);
+ Tcl_AppendResult(interp, "couldn't construct ssl session: ", GET_ERR_REASON(), (char *) NULL);
+ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "INIT", "FAILED", (char *) NULL);
+ Tls_Free((char *) statePtr);
return TCL_ERROR;
}
-#ifndef OPENSSL_NO_TLSEXT
+ /* Set host server name */
if (servername) {
- if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) {
- Tcl_AppendResult(interp, "setting TLS host name extension failed",
- (char *) NULL);
- Tls_Free((void *)statePtr);
- return TCL_ERROR;
- }
- }
-#endif
+ /* Sets the server name indication (SNI) in ClientHello extension */
+ /* Per RFC 6066, hostname is a ASCII encoded string, though RFC 4366 says UTF-8. */
+ if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) {
+ Tcl_AppendResult(interp, "Set SNI extension failed: ", GET_ERR_REASON(), (char *) NULL);
+ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "SNI", "FAILED", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+
+ /* Set hostname for peer certificate hostname verification in clients.
+ Don't use SSL_set1_host since it has limitations. */
+ if (!SSL_add1_host(statePtr->ssl, servername)) {
+ Tcl_AppendResult(interp, "Set DNS hostname failed: ", GET_ERR_REASON(), (char *) NULL);
+ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "HOSTNAME", "FAILED", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ }
+
+ /* Resume session id */
+ if (session_id && strlen(session_id) <= SSL_MAX_SID_CTX_LENGTH) {
+ /* SSL_set_session() */
+ if (!SSL_SESSION_set1_id_context(SSL_get_session(statePtr->ssl), session_id, (unsigned int) strlen(session_id))) {
+ Tcl_AppendResult(interp, "Resume session failed: ", GET_ERR_REASON(), (char *) NULL);
+ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "SESSION", "FAILED", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ }
+
+ /* 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;
+ Tcl_Size cnt, i;
+ int j;
+ Tcl_Obj **list;
+
+ if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+
+ /* Determine the memory required for the protocol-list */
+ 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((char *) statePtr);
+ return TCL_ERROR;
+ }
+ protos_len += 1 + (int) len;
+ }
+
+ /* Build the complete protocol-list */
+ protos = 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);
+ *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 functions reverses the return value convention */
+ if (SSL_set_alpn_protos(statePtr->ssl, protos, protos_len)) {
+ Tcl_AppendResult(interp, "Set ALPN protocols failed: ", GET_ERR_REASON(), (char *) NULL);
+ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "ALPN", "FAILED", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ ckfree(protos);
+ return TCL_ERROR;
+ }
+
+ /* Store protocols list */
+ statePtr->protos = protos;
+ statePtr->protos_len = protos_len;
+ } else {
+ statePtr->protos = NULL;
+ statePtr->protos_len = 0;
+ }
/*
* SSL Callbacks
*/
-
SSL_set_app_data(statePtr->ssl, (void *)statePtr); /* point back to us */
-
SSL_set_verify(statePtr->ssl, verify, VerifyCallback);
+ SSL_set_info_callback(statePtr->ssl, InfoCallback);
- SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);
+ /* Callback for observing protocol messages */
+#ifndef OPENSSL_NO_SSL_TRACE
+ /* void SSL_CTX_set_msg_callback_arg(statePtr->ctx, (void *)statePtr);
+ void SSL_CTX_set_msg_callback(statePtr->ctx, MessageCallback); */
+ SSL_set_msg_callback_arg(statePtr->ssl, (void *)statePtr);
+ SSL_set_msg_callback(statePtr->ssl, MessageCallback);
+#endif
/* Create Tcl_Channel BIO Handler */
statePtr->p_bio = BIO_new_tcl(statePtr, BIO_NOCLOSE);
statePtr->bio = BIO_new(BIO_f_ssl());
if (server) {
+ /* Server callbacks */
+ SSL_CTX_set_tlsext_servername_arg(statePtr->ctx, (void *)statePtr);
+ SSL_CTX_set_tlsext_servername_callback(statePtr->ctx, SNICallback);
+ SSL_CTX_set_client_hello_cb(statePtr->ctx, HelloCallback, (void *)statePtr);
+ if (statePtr->protos != NULL) {
+ SSL_CTX_set_alpn_select_cb(statePtr->ctx, ALPNCallback, (void *)statePtr);
+#ifdef USE_NPN
+ if (tls1_2 == 0 && tls1_3 == 0) {
+ SSL_CTX_set_next_protos_advertised_cb(statePtr->ctx, NPNCallback, (void *)statePtr);
+ }
+#endif
+ }
+
+ /* Enable server to send cert request after handshake (TLS 1.3 only) */
+ /* A write operation must take place for the Certificate Request to be
+ sent to the client, this can be done with SSL_do_handshake(). */
+ if (request && post_handshake && tls1_3) {
+ SSL_verify_client_post_handshake(statePtr->ssl);
+ }
+
+ /* set automatic curve selection */
+ SSL_set_ecdh_auto(statePtr->ssl, 1);
+
+ /* 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);
+ }
+#endif
+
+ /* Session caching */
+ SSL_CTX_set_session_cache_mode(statePtr->ctx, SSL_SESS_CACHE_CLIENT | SSL_SESS_CACHE_NO_INTERNAL_STORE);
+ SSL_CTX_sess_set_new_cb(statePtr->ctx, SessionCallback);
+
+ /* Enable post handshake Authentication extension. TLS 1.3 only, not http/2. */
+ if (request && post_handshake) {
+ SSL_set_post_handshake_auth(statePtr->ssl, 1);
+ }
+
+ /* Set client mode */
SSL_set_connect_state(statePtr->ssl);
}
SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio);
BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE);
/*
* End of SSL Init
*/
dprintf("Returning %s", Tcl_GetChannelName(statePtr->self));
- Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self),
- TCL_VOLATILE);
+ Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), TCL_VOLATILE);
+
return TCL_OK;
}
/*
*-------------------------------------------------------------------
@@ -997,19 +1667,14 @@
* Side effects:
* May modify the behavior of an IO channel.
*
*-------------------------------------------------------------------
*/
-
static int
-UnimportObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
+UnimportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
Tcl_Channel chan; /* The channel to set a mode on. */
+ (void) clientData;
dprintf("Called");
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
@@ -1019,18 +1684,17 @@
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
- "\": not a TLS channel", (char *)NULL);
+ "\": not a TLS channel", NULL);
+ Tcl_SetErrorCode(interp, "TLS", "UNIMPORT", "CHANNEL", "INVALID", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) {
return TCL_ERROR;
@@ -1050,249 +1714,259 @@
* Side effects:
* constructs SSL context (CTX)
*
*-------------------------------------------------------------------
*/
-
static SSL_CTX *
-CTX_Init(
- State *statePtr,
- TCL_UNUSED(int) /* isServer */,
- int proto,
- char *keyfile,
- char *certfile,
- unsigned char *key,
- unsigned char *cert,
- int key_len,
- int cert_len,
- char *CAdir,
- char *CAfile,
- char *ciphers,
- char *DHparams)
-{
+CTX_Init(State *statePtr, int isServer, int proto, char *keyfile, char *certfile,
+ unsigned char *key, unsigned char *cert, int key_len, int cert_len, char *CApath,
+ char *CAfile, char *ciphers, char *ciphersuites, int level, char *DHparams) {
Tcl_Interp *interp = statePtr->interp;
SSL_CTX *ctx = NULL;
Tcl_DString ds;
Tcl_DString ds1;
- int off = 0;
+ int off = 0, abort = 0;
int load_private_key;
const SSL_METHOD *method;
dprintf("Called");
if (!proto) {
- Tcl_AppendResult(interp, "no valid protocol selected", (char *)NULL);
- return (SSL_CTX *)0;
+ Tcl_AppendResult(interp, "no valid protocol selected", (char *) NULL);
+ return NULL;
}
/* create SSL context */
-#if defined(NO_SSL2)
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
if (ENABLED(proto, TLS_PROTO_SSL2)) {
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return (SSL_CTX *)0;
+ Tcl_AppendResult(interp, "SSL2 protocol not supported", (char *) NULL);
+ return NULL;
}
#endif
-#if defined(NO_SSL3)
+#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
if (ENABLED(proto, TLS_PROTO_SSL3)) {
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return (SSL_CTX *)0;
+ Tcl_AppendResult(interp, "SSL3 protocol not supported", (char *) NULL);
+ return NULL;
}
#endif
-#if defined(NO_TLS1)
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
if (ENABLED(proto, TLS_PROTO_TLS1)) {
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return (SSL_CTX *)0;
+ Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", (char *) NULL);
+ return NULL;
}
#endif
-#if defined(NO_TLS1_1)
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return (SSL_CTX *)0;
+ Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", (char *) NULL);
+ return NULL;
}
#endif
-#if defined(NO_TLS1_2)
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return (SSL_CTX *)0;
+ Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", (char *) NULL);
+ return NULL;
}
#endif
-#if defined(NO_TLS1_3)
+#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
if (ENABLED(proto, TLS_PROTO_TLS1_3)) {
- Tcl_AppendResult(interp, "protocol not supported", (char *)NULL);
- return (SSL_CTX *)0;
+ 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 !defined(NO_SSL2)
- case TLS_PROTO_SSL2:
- method = SSLv2_method ();
- break;
-#endif
-#if !defined(NO_SSL3)
- case TLS_PROTO_SSL3:
- method = SSLv3_method ();
- break;
-#endif
-#if !defined(NO_TLS1)
- case TLS_PROTO_TLS1:
- method = TLSv1_method ();
- break;
-#endif
-#if !defined(NO_TLS1_1)
- case TLS_PROTO_TLS1_1:
- method = TLSv1_1_method ();
- break;
-#endif
-#if !defined(NO_TLS1_2)
- case TLS_PROTO_TLS1_2:
- method = TLSv1_2_method ();
- break;
-#endif
-#if !defined(NO_TLS1_3)
- case TLS_PROTO_TLS1_3:
- /*
- * The version range is constrained below,
- * after the context is created. Use the
- * generic method here.
- */
- method = TLS_method ();
+#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:
-#ifdef HAVE_TLS_METHOD
- method = TLS_method ();
-#else
- method = SSLv23_method ();
-#endif
-#if !defined(NO_SSL2)
+ /* 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)
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3);
#endif
-#if !defined(NO_TLS1)
+#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)
+#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)
+#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)
+#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;
}
- ctx = SSL_CTX_new (method);
+ ERR_clear_error();
+ ctx = SSL_CTX_new(method);
if (!ctx) {
- return(NULL);
+ return(NULL);
+ }
+
+ if (getenv(SSLKEYLOGFILE)) {
+ SSL_CTX_set_keylog_callback(ctx, KeyLogCallback);
}
-#if !defined(NO_TLS1_3)
+#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);
+ 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 */
+ if (!isServer) {
+ SSL_CTX_set_options(ctx, SSL_OP_CIPHER_SERVER_PREFERENCE);
}
+
+#if OPENSSL_VERSION_NUMBER < 0x10100000L
+ OpenSSL_add_all_algorithms(); /* Load ciphers and digests */
+#endif
+
+ SSL_CTX_set_app_data(ctx, (void*)interp); /* remember the interpreter */
+ SSL_CTX_set_options(ctx, SSL_OP_ALL); /* 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 protocol versions */
+#if OPENSSL_VERSION_NUMBER < 0x10101000L
+ SSL_CTX_set_mode(ctx, SSL_MODE_AUTO_RETRY); /* handle new handshakes in background. On by default in OpenSSL 1.1.1. */
#endif
-
- SSL_CTX_set_app_data( ctx, (void*)interp); /* remember the interpreter */
- SSL_CTX_set_options( ctx, SSL_OP_ALL); /* all SSL bug workarounds */
- SSL_CTX_set_options( ctx, off); /* all SSL bug workarounds */
- SSL_CTX_sess_set_cache_size( ctx, 128);
-
- if (ciphers != NULL)
- SSL_CTX_set_cipher_list(ctx, ciphers);
+ SSL_CTX_sess_set_cache_size(ctx, 128);
+
+ /* Set user defined ciphers, cipher suites, and security level */
+ 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);
+ SSL_CTX_free(ctx);
+ return NULL;
+ }
+
+ /* Set security level */
+ if (level > -1 && level < 6) {
+ /* SSL_set_security_level */
+ SSL_CTX_set_security_level(ctx, level);
+ }
/* set some callbacks */
SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback);
-
-#ifndef BSAFE
SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr);
-#endif
/* read a Diffie-Hellman parameters file, or use the built-in one */
#ifdef OPENSSL_NO_DH
if (DHparams != NULL) {
- Tcl_AppendResult(interp,
- "DH parameter support not available", (char *) NULL);
+ Tcl_AppendResult(interp, "DH parameter support not available", (char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
}
#else
{
DH* dh;
if (DHparams != NULL) {
BIO *bio;
- Tcl_DStringInit(&ds);
bio = BIO_new_file(F2N(DHparams, &ds), "r");
if (!bio) {
Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp,
- "Could not find DH parameters file", (char *) NULL);
+ Tcl_AppendResult(interp, "Could not find DH parameters file", (char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
}
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", (char *) NULL);
+ Tcl_AppendResult(interp, "Could not read DH parameters from file", (char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
}
+ SSL_CTX_set_tmp_dh(ctx, dh);
+ DH_free(dh);
+
} else {
- dh = get_dhParams();
+ /* 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(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return NULL;
+ }
}
- SSL_CTX_set_tmp_dh(ctx, dh);
- DH_free(dh);
}
#endif
/* set our certificate */
load_private_key = 0;
if (certfile != NULL) {
load_private_key = 1;
- Tcl_DStringInit(&ds);
-
- if (SSL_CTX_use_certificate_file(ctx, F2N( certfile, &ds),
- SSL_FILETYPE_PEM) <= 0) {
+ if (SSL_CTX_use_certificate_file(ctx, F2N(certfile, &ds), SSL_FILETYPE_PEM) <= 0) {
Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp,
- "unable to set certificate file ", certfile, ": ",
- REASON(), (char *) NULL);
+ Tcl_AppendResult(interp, "unable to set certificate file ", certfile, ": ",
+ GET_ERR_REASON(), (char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
}
+ Tcl_DStringFree(&ds);
+
} else if (cert != NULL) {
load_private_key = 1;
if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) {
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp,
- "unable to set certificate: ",
- REASON(), (char *) NULL);
+ Tcl_AppendResult(interp, "unable to set certificate: ",
+ GET_ERR_REASON(), (char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
}
} else {
certfile = (char*)X509_get_default_cert_file();
- if (SSL_CTX_use_certificate_file(ctx, certfile,
- SSL_FILETYPE_PEM) <= 0) {
+ if (SSL_CTX_use_certificate_file(ctx, certfile, SSL_FILETYPE_PEM) <= 0) {
#if 0
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp,
- "unable to use default certificate file ", certfile, ": ",
- REASON(), (char *) NULL);
+ Tcl_AppendResult(interp, "unable to use default certificate file ", certfile, ": ",
+ GET_ERR_REASON(), (char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
#endif
}
}
/* set our private key */
@@ -1305,72 +1979,91 @@
/* get the private key associated with this certificate */
if (keyfile == NULL) {
keyfile = certfile;
}
- if (SSL_CTX_use_PrivateKey_file(ctx, F2N( keyfile, &ds), SSL_FILETYPE_PEM) <= 0) {
- Tcl_DStringFree(&ds);
- /* flush the passphrase which might be left in the result */
- Tcl_SetResult(interp, NULL, TCL_STATIC);
- Tcl_AppendResult(interp,
- "unable to set public key file ", keyfile, " ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
-
- Tcl_DStringFree(&ds);
- } else if (key != NULL) {
- if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 0) {
- Tcl_DStringFree(&ds);
- /* flush the passphrase which might be left in the result */
- Tcl_SetResult(interp, NULL, TCL_STATIC);
- Tcl_AppendResult(interp,
- "unable to set public key: ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ if (SSL_CTX_use_PrivateKey_file(ctx, F2N(keyfile, &ds), SSL_FILETYPE_PEM) <= 0) {
+ Tcl_DStringFree(&ds);
+ /* flush the passphrase which might be left in the result */
+ Tcl_SetResult(interp, NULL, TCL_STATIC);
+ Tcl_AppendResult(interp, "unable to set public key file ", keyfile, " ",
+ GET_ERR_REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return NULL;
+ }
+ Tcl_DStringFree(&ds);
+
+ } else if (key != NULL) {
+ if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 0) {
+ /* flush the passphrase which might be left in the result */
+ Tcl_SetResult(interp, NULL, TCL_STATIC);
+ Tcl_AppendResult(interp, "unable to set public key: ", GET_ERR_REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return NULL;
}
}
/* Now we know that a key and cert have been set against
* the SSL context */
if (!SSL_CTX_check_private_key(ctx)) {
- Tcl_AppendResult(interp,
- "private key does not match the certificate public key",
+ Tcl_AppendResult(interp, "private key does not match the certificate public key",
(char *) NULL);
SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- }
-
- /* Set verification CAs */
- Tcl_DStringInit(&ds);
- Tcl_DStringInit(&ds1);
- if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) ||
- !SSL_CTX_set_default_verify_paths(ctx)) {
-#if 0
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&ds1);
- /* Don't currently care if this fails */
- Tcl_AppendResult(interp, "SSL default verify paths: ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
+ return NULL;
+ }
+ }
+
+ /* Set to use default location and file for Certificate Authority (CA) certificates. The
+ * verify path and store can be overridden by the SSL_CERT_DIR env var. The verify file can
+ * be overridden by the SSL_CERT_FILE env var. */
+ if (!SSL_CTX_set_default_verify_paths(ctx)) {
+ abort++;
+ }
+
+ /* Overrides for the CA verify path and file */
+ {
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ if (CApath != NULL || CAfile != NULL) {
+ Tcl_DString ds1;
+ if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CApath, &ds1))) {
+ abort++;
+ }
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&ds1);
+
+ /* Set list of CAs to send to client when requesting a client certificate */
+ /* https://sourceforge.net/p/tls/bugs/57/ */
+ /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */
+ STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file(F2N(CAfile, &ds));
+ if (certNames != NULL) {
+ SSL_CTX_set_client_CA_list(ctx, certNames);
+ }
+ Tcl_DStringFree(&ds);
+ }
+
+#else
+ if (CApath != NULL) {
+ if (!SSL_CTX_load_verify_dir(ctx, F2N(CApath, &ds))) {
+ abort++;
+ }
+ Tcl_DStringFree(&ds);
+ }
+ if (CAfile != NULL) {
+ if (!SSL_CTX_load_verify_file(ctx, F2N(CAfile, &ds))) {
+ abort++;
+ }
+ Tcl_DStringFree(&ds);
+
+ /* Set list of CAs to send to client when requesting a client certificate */
+ STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file(F2N(CAfile, &ds));
+ if (certNames != NULL) {
+ SSL_CTX_set_client_CA_list(ctx, certNames);
+ }
+ Tcl_DStringFree(&ds);
+ }
#endif
}
- /* https://sourceforge.net/p/tls/bugs/57/ */
- /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */
- if ( CAfile != NULL ) {
- STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file( F2N(CAfile, &ds) );
- if ( certNames != NULL ) {
- SSL_CTX_set_client_CA_list(ctx, certNames );
- }
- }
-
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&ds1);
return ctx;
}
/*
*-------------------------------------------------------------------
@@ -1384,86 +2077,356 @@
* None.
*
*-------------------------------------------------------------------
*/
static int
-StatusObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
+StatusObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
State *statePtr;
X509 *peer;
Tcl_Obj *objPtr;
Tcl_Channel chan;
char *channelName, *ciphers;
int mode;
+ const unsigned char *proto;
+ unsigned int len;
+ int nid, res;
+ (void) clientData;
dprintf("Called");
- switch (objc) {
- case 2:
- channelName = Tcl_GetString(objv[1]);
- break;
-
- case 3:
- if (!strcmp (Tcl_GetString (objv[1]), "-local")) {
- channelName = Tcl_GetString(objv[2]);
- break;
- }
- /* fallthrough */
- default:
- Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel");
- return TCL_ERROR;
- }
-
+ if (objc < 2 || objc > 3 || (objc == 3 && !strcmp(Tcl_GetString(objv[1]), "-local"))) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel");
+ return TCL_ERROR;
+ }
+
+ /* Get channel Id */
+ channelName = Tcl_GetStringFromObj(objv[(objc == 2 ? 1 : 2)], (Tcl_Size *) NULL);
chan = Tcl_GetChannel(interp, channelName, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
+
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
- "\": not a TLS channel", (char *)NULL);
+ "\": not a TLS channel", NULL);
+ Tcl_SetErrorCode(interp, "TLS", "STATUS", "CHANNEL", "INVALID", (char *) NULL);
return TCL_ERROR;
}
statePtr = (State *) Tcl_GetChannelInstanceData(chan);
+
+ /* Get certificate for peer or self */
if (objc == 2) {
peer = SSL_get_peer_certificate(statePtr->ssl);
} else {
peer = SSL_get_certificate(statePtr->ssl);
}
+ /* Get X509 certificate info */
if (peer) {
objPtr = Tls_NewX509Obj(interp, peer);
- if (objc == 2) { X509_free(peer); }
+ if (objc == 2) {
+ X509_free(peer);
+ peer = NULL;
+ }
} else {
objPtr = Tcl_NewListObj(0, NULL);
}
- Tcl_ListObjAppendElement (interp, objPtr,
- Tcl_NewStringObj ("sbits", -1));
- Tcl_ListObjAppendElement (interp, objPtr,
- Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, NULL)));
+ /* Peer name */
+ LAPPEND_STR(interp, objPtr, "peername", SSL_get0_peername(statePtr->ssl), -1);
+ LAPPEND_INT(interp, objPtr, "sbits", SSL_get_cipher_bits(statePtr->ssl, NULL));
ciphers = (char*)SSL_get_cipher(statePtr->ssl);
- if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) {
- Tcl_ListObjAppendElement(interp, objPtr,
- Tcl_NewStringObj("cipher", -1));
- Tcl_ListObjAppendElement(interp, objPtr,
- Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1));
- }
-
- Tcl_ListObjAppendElement(interp, objPtr,
- Tcl_NewStringObj("version", -1));
- Tcl_ListObjAppendElement(interp, objPtr,
- Tcl_NewStringObj(SSL_get_version(statePtr->ssl), -1));
-
- Tcl_SetObjResult( interp, objPtr);
+ LAPPEND_STR(interp, objPtr, "cipher", ciphers, -1);
+
+ /* Verify the X509 certificate presented by the peer */
+ LAPPEND_STR(interp, objPtr, "verifyResult",
+ X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl)), -1);
+
+ /* Verify mode */
+ mode = SSL_get_verify_mode(statePtr->ssl);
+ if (mode && SSL_VERIFY_NONE) {
+ LAPPEND_STR(interp, objPtr, "verifyMode", "none", -1);
+ } else {
+ Tcl_Obj *listObjPtr = Tcl_NewListObj(0, NULL);
+ if (mode && SSL_VERIFY_PEER) {
+ Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj("peer", -1));
+ }
+ if (mode && SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
+ Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj("fail if no peer cert", -1));
+ }
+ if (mode && SSL_VERIFY_CLIENT_ONCE) {
+ Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj("client once", -1));
+ }
+ if (mode && SSL_VERIFY_POST_HANDSHAKE) {
+ Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj("post handshake", -1));
+ }
+ LAPPEND_OBJ(interp, objPtr, "verifyMode", listObjPtr)
+ }
+
+ /* Verify mode depth */
+ LAPPEND_INT(interp, objPtr, "verifyDepth", SSL_get_verify_depth(statePtr->ssl));
+
+ /* Report the selected protocol as a result of the negotiation */
+ SSL_get0_alpn_selected(statePtr->ssl, &proto, &len);
+ LAPPEND_STR(interp, objPtr, "alpn", (char *)proto, (Tcl_Size) len);
+ LAPPEND_STR(interp, objPtr, "protocol", SSL_get_version(statePtr->ssl), -1);
+
+ /* Valid for non-RSA signature and TLS 1.3 */
+ if (objc == 2) {
+ res = SSL_get_peer_signature_nid(statePtr->ssl, &nid);
+ } else {
+ res = SSL_get_signature_nid(statePtr->ssl, &nid);
+ }
+ if (!res) {nid = 0;}
+ LAPPEND_STR(interp, objPtr, "signatureHashAlgorithm", OBJ_nid2ln(nid), -1);
+
+ if (objc == 2) {
+ res = SSL_get_peer_signature_type_nid(statePtr->ssl, &nid);
+ } else {
+ res = SSL_get_signature_type_nid(statePtr->ssl, &nid);
+ }
+ if (!res) {nid = 0;}
+ LAPPEND_STR(interp, objPtr, "signatureType", OBJ_nid2ln(nid), -1);
+
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ConnectionInfoObjCmd -- return connection info from OpenSSL.
+ *
+ * Results:
+ * A list of connection info
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int ConnectionInfoObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Channel chan; /* The channel to set a mode on */
+ State *statePtr; /* client state for ssl socket */
+ Tcl_Obj *objPtr, *listPtr;
+ const SSL *ssl;
+ const SSL_CIPHER *cipher;
+ const SSL_SESSION *session;
+ const EVP_MD *md;
+ (void) clientData;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel");
+ return(TCL_ERROR);
+ }
+
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], (Tcl_Size *)NULL), NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return(TCL_ERROR);
+ }
+
+ /* Make sure to operate on the topmost channel */
+ chan = Tcl_GetTopChannel(chan);
+ if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
+ Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
+ "\": not a TLS channel", NULL);
+ Tcl_SetErrorCode(interp, "TLS", "CONNECTION", "CHANNEL", "INVALID", (char *) NULL);
+ return(TCL_ERROR);
+ }
+
+ objPtr = Tcl_NewListObj(0, NULL);
+
+ /* Connection info */
+ statePtr = (State *)Tcl_GetChannelInstanceData(chan);
+ ssl = statePtr->ssl;
+ if (ssl != NULL) {
+ /* connection state */
+ LAPPEND_STR(interp, objPtr, "state", SSL_state_string_long(ssl), -1);
+
+ /* Get SNI requested server name */
+ LAPPEND_STR(interp, objPtr, "servername", SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name), -1);
+
+ /* Get protocol */
+ LAPPEND_STR(interp, objPtr, "protocol", SSL_get_version(ssl), -1);
+
+ /* Renegotiation allowed */
+ LAPPEND_BOOL(interp, objPtr, "renegotiation_allowed", SSL_get_secure_renegotiation_support((SSL *) ssl));
+
+ /* Get security level */
+ LAPPEND_INT(interp, objPtr, "security_level", SSL_get_security_level(ssl));
+
+ /* Session info */
+ LAPPEND_BOOL(interp, objPtr, "session_reused", SSL_session_reused(ssl));
+
+ /* Is server info */
+ LAPPEND_BOOL(interp, objPtr, "is_server", SSL_is_server(ssl));
+
+ /* Is DTLS */
+ LAPPEND_BOOL(interp, objPtr, "is_dtls", SSL_is_dtls(ssl));
+ }
+
+ /* Cipher info */
+ cipher = SSL_get_current_cipher(ssl);
+ if (cipher != NULL) {
+ char buf[BUFSIZ] = {0};
+ int bits, alg_bits;
+
+ /* Cipher name */
+ LAPPEND_STR(interp, objPtr, "cipher", SSL_CIPHER_get_name(cipher), -1);
+
+ /* RFC name of cipher */
+ LAPPEND_STR(interp, objPtr, "standard_name", SSL_CIPHER_standard_name(cipher), -1);
+
+ /* OpenSSL name of cipher */
+ LAPPEND_STR(interp, objPtr, "openssl_name", OPENSSL_cipher_name(SSL_CIPHER_standard_name(cipher)), -1);
+
+ /* number of secret bits used for cipher */
+ bits = SSL_CIPHER_get_bits(cipher, &alg_bits);
+ LAPPEND_INT(interp, objPtr, "secret_bits", bits);
+ LAPPEND_INT(interp, objPtr, "algorithm_bits", alg_bits);
+ /* alg_bits is actual key secret bits. If use bits and secret (algorithm) bits differ,
+ the rest of the bits are fixed, i.e. for limited export ciphers (bits < 56) */
+
+ /* Indicates which SSL/TLS protocol version first defined the cipher */
+ LAPPEND_STR(interp, objPtr, "min_version", SSL_CIPHER_get_version(cipher), -1);
+
+ /* Cipher NID */
+ LAPPEND_STR(interp, objPtr, "cipherNID", (char *)OBJ_nid2ln(SSL_CIPHER_get_cipher_nid(cipher)), -1);
+ LAPPEND_STR(interp, objPtr, "digestNID", (char *)OBJ_nid2ln(SSL_CIPHER_get_digest_nid(cipher)), -1);
+ LAPPEND_STR(interp, objPtr, "keyExchangeNID", (char *)OBJ_nid2ln(SSL_CIPHER_get_kx_nid(cipher)), -1);
+ LAPPEND_STR(interp, objPtr, "authenticationNID", (char *)OBJ_nid2ln(SSL_CIPHER_get_auth_nid(cipher)), -1);
+
+ /* message authentication code - Cipher is AEAD (e.g. GCM or ChaCha20/Poly1305) or not */
+ /* Authenticated Encryption with associated data (AEAD) check */
+ LAPPEND_BOOL(interp, objPtr, "cipher_is_aead", SSL_CIPHER_is_aead(cipher));
+
+ /* Digest used during the SSL/TLS handshake when using the cipher. */
+ md = SSL_CIPHER_get_handshake_digest(cipher);
+ LAPPEND_STR(interp, objPtr, "handshake_digest", (char *)EVP_MD_name(md), -1);
+
+ /* Get OpenSSL-specific ID, not IANA ID */
+ LAPPEND_INT(interp, objPtr, "cipher_id", (int) SSL_CIPHER_get_id(cipher));
+
+ /* Two-byte ID used in the TLS protocol of the given cipher */
+ LAPPEND_INT(interp, objPtr, "protocol_id", (int) SSL_CIPHER_get_protocol_id(cipher));
+
+ /* Textual description of the cipher */
+ if (SSL_CIPHER_description(cipher, buf, sizeof(buf)) != NULL) {
+ LAPPEND_STR(interp, objPtr, "description", buf, -1);
+ }
+ }
+
+ /* Session info */
+ session = SSL_get_session(ssl);
+ if (session != NULL) {
+ const unsigned char *ticket;
+ size_t len2;
+ unsigned int ulen;
+ const unsigned char *session_id, *proto;
+ unsigned char buffer[SSL_MAX_MASTER_KEY_LENGTH];
+
+ /* Report the selected protocol as a result of the ALPN negotiation */
+ SSL_SESSION_get0_alpn_selected(session, &proto, &len2);
+ LAPPEND_STR(interp, objPtr, "alpn", (char *) proto, (Tcl_Size) len2);
+
+ /* Report the selected protocol as a result of the NPN negotiation */
+#ifdef USE_NPN
+ SSL_get0_next_proto_negotiated(ssl, &proto, &ulen);
+ LAPPEND_STR(interp, objPtr, "npn", (char *) proto, (Tcl_Size) ulen);
+#endif
+
+ /* Resumable session */
+ LAPPEND_BOOL(interp, objPtr, "resumable", SSL_SESSION_is_resumable(session));
+
+ /* Session start time (seconds since epoch) */
+ LAPPEND_LONG(interp, objPtr, "start_time", SSL_SESSION_get_time(session));
+
+ /* 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 */
+ session_id = SSL_SESSION_get_id(session, &ulen);
+ LAPPEND_BARRAY(interp, objPtr, "session_id", session_id, (Tcl_Size) ulen);
+
+ /* Session context */
+ session_id = SSL_SESSION_get0_id_context(session, &ulen);
+ LAPPEND_BARRAY(interp, objPtr, "session_context", session_id, (Tcl_Size) ulen);
+
+ /* Session ticket - client only */
+ SSL_SESSION_get0_ticket(session, &ticket, &len2);
+ LAPPEND_BARRAY(interp, objPtr, "session_ticket", ticket, (Tcl_Size) len2);
+
+ /* Session ticket lifetime hint (in seconds) */
+ LAPPEND_LONG(interp, objPtr, "lifetime", SSL_SESSION_get_ticket_lifetime_hint(session));
+
+ /* Ticket app data */
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ SSL_SESSION_get0_ticket_appdata((SSL_SESSION *) session, &ticket, &len2);
+ LAPPEND_BARRAY(interp, objPtr, "ticket_app_data", ticket, (Tcl_Size) len2);
+#endif
+
+ /* Get master key */
+ len2 = SSL_SESSION_get_master_key(session, buffer, SSL_MAX_MASTER_KEY_LENGTH);
+ LAPPEND_BARRAY(interp, objPtr, "master_key", buffer, (Tcl_Size) len2);
+
+ /* Compression id */
+ unsigned int id = SSL_SESSION_get_compress_id(session);
+ LAPPEND_STR(interp, objPtr, "compression_id", id == 1 ? "zlib" : "none", -1);
+ }
+
+ /* Compression info */
+ if (ssl != NULL) {
+#ifdef HAVE_SSL_COMPRESSION
+ const COMP_METHOD *comp, *expn;
+ comp = SSL_get_current_compression(ssl);
+ expn = SSL_get_current_expansion(ssl);
+
+ LAPPEND_STR(interp, objPtr, "compression", comp ? SSL_COMP_get_name(comp) : "none", -1);
+ LAPPEND_STR(interp, objPtr, "expansion", expn ? SSL_COMP_get_name(expn) : "none", -1);
+#else
+ LAPPEND_STR(interp, objPtr, "compression", "none", -1);
+ LAPPEND_STR(interp, objPtr, "expansion", "none", -1);
+#endif
+ }
+
+ /* Server info */
+ {
+ long mode = SSL_CTX_get_session_cache_mode(statePtr->ctx);
+ char *msg;
+
+ if (mode & SSL_SESS_CACHE_OFF) {
+ msg = "off";
+ } else if (mode & SSL_SESS_CACHE_CLIENT) {
+ msg = "client";
+ } else if (mode & SSL_SESS_CACHE_SERVER) {
+ msg = "server";
+ } else if (mode & SSL_SESS_CACHE_BOTH) {
+ msg = "both";
+ } else {
+ msg = "unknown";
+ }
+ LAPPEND_STR(interp, objPtr, "session_cache_mode", msg, -1);
+ }
+
+ /* CA List */
+ /* IF not a server, same as SSL_get0_peer_CA_list. If server same as SSL_CTX_get_client_CA_list */
+ listPtr = Tcl_NewListObj(0, NULL);
+ STACK_OF(X509_NAME) *ca_list;
+ if ((ca_list = SSL_get_client_CA_list(ssl)) != NULL) {
+ char buffer[BUFSIZ];
+ for (int i = 0; i < sk_X509_NAME_num(ca_list); i++) {
+ X509_NAME *name = sk_X509_NAME_value(ca_list, i);
+ if (name) {
+ X509_NAME_oneline(name, buffer, BUFSIZ);
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(buffer, -1));
+ }
+ }
+ }
+ LAPPEND_OBJ(interp, objPtr, "caList", listPtr);
+ LAPPEND_INT(interp, objPtr, "caListCount", sk_X509_NAME_num(ca_list));
+
+ Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*-------------------------------------------------------------------
@@ -1477,23 +2440,21 @@
* None.
*
*-------------------------------------------------------------------
*/
static int
-VersionObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- TCL_UNUSED(int) /* objc */,
- TCL_UNUSED(Tcl_Obj *const *) /* objv */)
-{
+VersionObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
Tcl_Obj *objPtr;
+ (void) clientData;
+ (void) objc;
+ (void) objv;
dprintf("Called");
objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1);
-
Tcl_SetObjResult(interp, objPtr);
+
return TCL_OK;
}
/*
*-------------------------------------------------------------------
@@ -1507,44 +2468,53 @@
* None.
*
*-------------------------------------------------------------------
*/
static int
-MiscObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- static const char *commands [] = { "req", NULL };
- enum command { C_REQ, C_DUMMY };
- int cmd;
+MiscObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ static const char *commands [] = { "req", "strreq", NULL };
+ enum command { C_REQ, C_STRREQ, C_DUMMY };
+ Tcl_Size cmd;
+ int isStr;
+ char buffer[16384];
+ (void) clientData;
dprintf("Called");
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], commands,
- "command", 0,&cmd) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0, &cmd) != TCL_OK) {
return TCL_ERROR;
}
+ ERR_clear_error();
+
+ isStr = (cmd == C_STRREQ);
switch ((enum command) cmd) {
- case C_REQ: {
+ case C_REQ:
+ case C_STRREQ: {
EVP_PKEY *pkey=NULL;
X509 *cert=NULL;
X509_NAME *name=NULL;
Tcl_Obj **listv;
- Tcl_Size listc,i;
+ Tcl_Size listc;
+ int i;
BIO *out=NULL;
- const char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email="";
+ char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email="";
char *keyout,*pemout,*str;
int keysize,serial=0,days=365;
+
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ BIGNUM *bne = NULL;
+ RSA *rsa = NULL;
+#else
+ EVP_PKEY_CTX *ctx = NULL;
+#endif
if ((objc<5) || (objc>6)) {
Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?");
return TCL_ERROR;
}
@@ -1552,14 +2522,17 @@
if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) {
return TCL_ERROR;
}
keyout=Tcl_GetString(objv[3]);
pemout=Tcl_GetString(objv[4]);
+ if (isStr) {
+ Tcl_SetVar(interp,keyout,"",0);
+ Tcl_SetVar(interp,pemout,"",0);
+ }
if (objc>=6) {
- if (Tcl_ListObjGetElements(interp, objv[5],
- &listc, &listv) != TCL_OK) {
+ if (Tcl_ListObjGetElements(interp, objv[5], &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if ((listc%2) != 0) {
Tcl_SetResult(interp,"Information list must have even number of arguments",NULL);
@@ -1568,13 +2541,10 @@
for (i=0; i<listc; i+=2) {
str=Tcl_GetString(listv[i]);
if (strcmp(str,"days")==0) {
if (Tcl_GetIntFromObj(interp,listv[i+1],&days)!=TCL_OK)
return TCL_ERROR;
- } else if (strcmp(str,"serial")==0) {
- if (Tcl_GetIntFromObj(interp,listv[i+1],&serial)!=TCL_OK)
- return TCL_ERROR;
} else if (strcmp(str,"serial")==0) {
if (Tcl_GetIntFromObj(interp,listv[i+1],&serial)!=TCL_OK)
return TCL_ERROR;
} else if (strcmp(str,"C")==0) {
k_C=Tcl_GetString(listv[i+1]);
@@ -1594,73 +2564,119 @@
Tcl_SetResult(interp,"Unknown parameter",NULL);
return TCL_ERROR;
}
}
}
- if ((pkey = EVP_PKEY_new()) != NULL) {
- if (!EVP_PKEY_assign_RSA(pkey,
- RSA_generate_key(keysize, 0x10001, NULL, NULL))) {
- Tcl_SetResult(interp,"Error generating private key",NULL);
- EVP_PKEY_free(pkey);
- return TCL_ERROR;
- }
- out=BIO_new(BIO_s_file());
- BIO_write_filename(out,keyout);
- PEM_write_bio_PrivateKey(out,pkey,NULL,NULL,0,NULL,NULL);
- BIO_free_all(out);
+
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ bne = BN_new();
+ rsa = RSA_new();
+ pkey = EVP_PKEY_new();
+ if (bne == NULL || rsa == NULL || pkey == NULL || !BN_set_word(bne,RSA_F4) ||
+ !RSA_generate_key_ex(rsa, keysize, bne, NULL) || !EVP_PKEY_assign_RSA(pkey, rsa)) {
+ EVP_PKEY_free(pkey);
+ /* RSA_free(rsa); freed by EVP_PKEY_free */
+ BN_free(bne);
+#else
+ pkey = EVP_RSA_gen((unsigned int) keysize);
+ ctx = EVP_PKEY_CTX_new(pkey,NULL);
+ if (pkey == NULL || ctx == NULL || !EVP_PKEY_keygen_init(ctx) ||
+ !EVP_PKEY_CTX_set_rsa_keygen_bits(ctx, keysize) || !EVP_PKEY_keygen(ctx, &pkey)) {
+ EVP_PKEY_free(pkey);
+ EVP_PKEY_CTX_free(ctx);
+#endif
+ Tcl_SetResult(interp,"Error generating private key",NULL);
+ return TCL_ERROR;
+ } else {
+ if (isStr) {
+ out=BIO_new(BIO_s_mem());
+ PEM_write_bio_PrivateKey(out,pkey,NULL,NULL,0,NULL,NULL);
+ i=BIO_read(out,buffer,sizeof(buffer)-1);
+ i=(i<0) ? 0 : i;
+ buffer[i]='\0';
+ Tcl_SetVar(interp,keyout,buffer,0);
+ BIO_flush(out);
+ BIO_free(out);
+ } else {
+ out=BIO_new(BIO_s_file());
+ BIO_write_filename(out,keyout);
+ PEM_write_bio_PrivateKey(out,pkey,NULL,NULL,0,NULL,NULL);
+ /* PEM_write_bio_RSAPrivateKey(out, rsa, NULL, NULL, 0, NULL, NULL); */
+ BIO_free_all(out);
+ }
if ((cert=X509_new())==NULL) {
Tcl_SetResult(interp,"Error generating certificate request",NULL);
EVP_PKEY_free(pkey);
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
return(TCL_ERROR);
}
X509_set_version(cert,2);
ASN1_INTEGER_set(X509_get_serialNumber(cert),serial);
- X509_gmtime_adj(X509_get_notBefore(cert),0);
- X509_gmtime_adj(X509_get_notAfter(cert),(long)60*60*24*days);
+ X509_gmtime_adj(X509_getm_notBefore(cert),0);
+ X509_gmtime_adj(X509_getm_notAfter(cert),(long)60*60*24*days);
X509_set_pubkey(cert,pkey);
name=X509_get_subject_name(cert);
- X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, (unsigned char *) k_C, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, (unsigned char *) k_ST, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, (unsigned char *) k_L, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, (unsigned char *) k_O, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, (unsigned char *) k_OU, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, (unsigned char *) k_CN, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, (unsigned char *) k_Email, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, (const unsigned char *) k_C, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, (const unsigned char *) k_ST, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, (const unsigned char *) k_L, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, (const unsigned char *) k_O, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, (const unsigned char *) k_OU, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, (const unsigned char *) k_CN, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, (const unsigned char *) k_Email, -1, -1, 0);
X509_set_subject_name(cert,name);
- if (!X509_sign(cert,pkey,EVP_md5())) {
+ if (!X509_sign(cert,pkey,EVP_sha256())) {
X509_free(cert);
EVP_PKEY_free(pkey);
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
Tcl_SetResult(interp,"Error signing certificate",NULL);
return TCL_ERROR;
}
- out=BIO_new(BIO_s_file());
- BIO_write_filename(out,pemout);
-
- PEM_write_bio_X509(out,cert);
- BIO_free_all(out);
+ if (isStr) {
+ out=BIO_new(BIO_s_mem());
+ PEM_write_bio_X509(out,cert);
+ i=BIO_read(out,buffer,sizeof(buffer)-1);
+ i=(i<0) ? 0 : i;
+ buffer[i]='\0';
+ Tcl_SetVar(interp,pemout,buffer,0);
+ BIO_flush(out);
+ BIO_free(out);
+ } else {
+ out=BIO_new(BIO_s_file());
+ BIO_write_filename(out,pemout);
+ PEM_write_bio_X509(out,cert);
+ BIO_free_all(out);
+ }
X509_free(cert);
EVP_PKEY_free(pkey);
- } else {
- Tcl_SetResult(interp,"Error generating private key",NULL);
- return TCL_ERROR;
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
}
}
break;
default:
break;
}
return TCL_OK;
}
+/********************/
+/* Init */
+/********************/
+
/*
*-------------------------------------------------------------------
*
* Tls_Free --
*
@@ -1674,16 +2690,11 @@
* Frees all the state
*
*-------------------------------------------------------------------
*/
void
-#if TCL_MAJOR_VERSION > 8
-Tls_Free( void *blockPtr )
-#else
-Tls_Free( char *blockPtr )
-#endif
-{
+Tls_Free(char *blockPtr) {
State *statePtr = (State *)blockPtr;
dprintf("Called");
Tls_Clean(statePtr);
@@ -1717,10 +2728,14 @@
if (statePtr->timer != (Tcl_TimerToken) NULL) {
Tcl_DeleteTimerHandler(statePtr->timer);
statePtr->timer = NULL;
}
+ if (statePtr->protos) {
+ ckfree(statePtr->protos);
+ statePtr->protos = NULL;
+ }
if (statePtr->bio) {
/* This will call SSL_shutdown. Bug 1414045 */
dprintf("BIO_free_all(%p)", statePtr->bio);
BIO_free_all(statePtr->bio);
statePtr->bio = NULL;
@@ -1740,14 +2755,24 @@
}
if (statePtr->password) {
Tcl_DecrRefCount(statePtr->password);
statePtr->password = NULL;
}
+ if (statePtr->vcmd) {
+ Tcl_DecrRefCount(statePtr->vcmd);
+ statePtr->vcmd = NULL;
+ }
dprintf("Returning");
}
+#if TCL_MAJOR_VERSION > 8
+#define MIN_VERSION "9.0"
+#else
+#define MIN_VERSION "8.5"
+#endif
+
/*
*-------------------------------------------------------------------
*
* Tls_Init --
*
@@ -1755,54 +2780,51 @@
* by Tcl when this package is to be added to an interpreter.
*
* Results: Ssl configured and loaded
*
* Side effects:
- * create the ssl command, initialise ssl context
+ * create the ssl command, initialize ssl context
*
*-------------------------------------------------------------------
*/
-
DLLEXPORT int Tls_Init(Tcl_Interp *interp) {
- const char tlsTclInitScript[] = {
+ const char tlsTclInitScript[] = {
#include "tls.tcl.h"
- 0x00
- };
-
- dprintf("Called");
-
- /*
- * We only support Tcl 8.4 or newer
- */
- if (
+ 0x00
+ };
+
+ dprintf("Called");
+
#ifdef USE_TCL_STUBS
- Tcl_InitStubs(interp, "8.6-", 0)
-#else
- Tcl_PkgRequire(interp, "Tcl", "8.6-", 0)
+ if (Tcl_InitStubs(interp, MIN_VERSION, 0) == NULL) {
+ return TCL_ERROR;
+ }
#endif
- == NULL) {
- return TCL_ERROR;
- }
-
- if (TlsLibInit(0) != TCL_OK) {
- Tcl_AppendResult(interp, "could not initialize SSL library", (char *)NULL);
- return TCL_ERROR;
- }
-
- Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
-
- if (interp) {
- Tcl_Eval(interp, tlsTclInitScript);
- }
-
- return(Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION));
+ if (Tcl_PkgRequire(interp, "Tcl", MIN_VERSION, 0) == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (TlsLibInit(0) != TCL_OK) {
+ Tcl_AppendResult(interp, "could not initialize SSL library", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ 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::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);
+
+ if (interp) {
+ Tcl_Eval(interp, tlsTclInitScript);
+ }
+
+ return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);
}
/*
*------------------------------------------------------*
*
@@ -1811,22 +2833,21 @@
* ------------------------------------------------*
* Standard procedure required by 'load'.
* Initializes this extension for a safe interpreter.
* ------------------------------------------------*
*
- * Sideeffects:
+ * Side effects:
* As of 'Tls_Init'
*
* Result:
* A standard Tcl error code.
*
*------------------------------------------------------*
*/
-
DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp) {
- dprintf("Called");
- return(Tls_Init(interp));
+ dprintf("Called");
+ return(Tls_Init(interp));
}
/*
*------------------------------------------------------*
*
@@ -1835,92 +2856,82 @@
* ------------------------------------------------*
* Initializes SSL library once per application
* ------------------------------------------------*
*
* Side effects:
- * initilizes SSL library
+ * initializes SSL library
*
* Result:
* none
*
*------------------------------------------------------*
*/
static int TlsLibInit(int uninitialize) {
- static int initialized = 0;
- int status = TCL_OK;
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- size_t num_locks;
-#endif
-
- if (uninitialize) {
- if (!initialized) {
- dprintf("Asked to uninitialize, but we are not initialized");
-
- return(TCL_OK);
- }
-
- dprintf("Asked to uninitialize");
-
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- Tcl_MutexLock(&init_mx);
-
- CRYPTO_set_locking_callback(NULL);
- CRYPTO_set_id_callback(NULL);
-
- if (locks) {
- free(locks);
- locks = NULL;
- locksCount = 0;
- }
-#endif
- initialized = 0;
-
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- Tcl_MutexUnlock(&init_mx);
-#endif
-
- return(TCL_OK);
- }
-
- if (initialized) {
- dprintf("Called, but using cached value");
- return(status);
- }
-
- dprintf("Called");
-
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- Tcl_MutexLock(&init_mx);
-#endif
- initialized = 1;
-
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- num_locks = CRYPTO_num_locks();
- locksCount = num_locks;
- locks = malloc(sizeof(*locks) * num_locks);
- memset(locks, 0, sizeof(*locks) * num_locks);
-
- CRYPTO_set_locking_callback(CryptoThreadLockCallback);
- CRYPTO_set_id_callback(CryptoThreadIdCallback);
-#endif
-
- if (SSL_library_init() != 1) {
- status = TCL_ERROR;
- goto done;
- }
-
- SSL_load_error_strings();
- ERR_load_crypto_strings();
-
- BIO_new_tcl(NULL, 0);
-
-#if 0
- /*
- * XXX:TODO: Remove this code and replace it with a check
- * for enough entropy and do not try to create our own
- * terrible entropy
- */
+ static int initialized = 0;
+ int status = TCL_OK;
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ size_t num_locks;
+#endif
+
+ if (uninitialize) {
+ if (!initialized) {
+ dprintf("Asked to uninitialize, but we are not initialized");
+
+ return(TCL_OK);
+ }
+
+ dprintf("Asked to uninitialize");
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ Tcl_MutexLock(&init_mx);
+
+ if (locks) {
+ free(locks);
+ locks = NULL;
+ locksCount = 0;
+ }
+#endif
+ initialized = 0;
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ Tcl_MutexUnlock(&init_mx);
+#endif
+
+ return(TCL_OK);
+ }
+
+ if (initialized) {
+ dprintf("Called, but using cached value");
+ return(status);
+ }
+
+ dprintf("Called");
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ Tcl_MutexLock(&init_mx);
+#endif
+ initialized = 1;
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ num_locks = 1;
+ locksCount = (int) num_locks;
+ locks = malloc(sizeof(*locks) * num_locks);
+ memset(locks, 0, sizeof(*locks) * num_locks);
+#endif
+
+ /* Initialize BOTH libcrypto and libssl. */
+ OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS | OPENSSL_INIT_LOAD_CRYPTO_STRINGS
+ | OPENSSL_INIT_ADD_ALL_CIPHERS | OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);
+
+ BIO_new_tcl(NULL, 0);
+
+#if 0
+ /*
+ * XXX:TODO: Remove this code and replace it with a check
+ * for enough entropy and do not try to create our own
+ * terrible entropy
+ */
/*
* Seed the random number generator in the SSL library,
* using the do/while construct because of the bug note in the
* OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1
*
@@ -1936,12 +2947,11 @@
}
RAND_seed(rnd_seed, sizeof(rnd_seed));
} while (RAND_status() != 1);
#endif
-done:
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
Tcl_MutexUnlock(&init_mx);
#endif
- return(status);
+ return(status);
}
Index: generic/tls.h
==================================================================
--- generic/tls.h
+++ generic/tls.h
@@ -13,10 +13,11 @@
* Also work done by the follow people provided the impetus to do this "right":-
* tclSSL (Colin McCormack, Shared Technology)
* SSLtcl (Peter Antman)
*
*/
+
#ifndef _TLS_H
#define _TLS_H
#include <tcl.h>
Index: generic/tlsBIO.c
==================================================================
--- generic/tlsBIO.c
+++ generic/tlsBIO.c
@@ -1,323 +1,325 @@
/*
* Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
*
- * Provides BIO layer to interface openssl to Tcl.
+ * Provides BIO layer to interface OpenSSL to TCL.
*/
#include "tlsInt.h"
-#ifdef TCLTLS_OPENSSL_PRE_1_1_API
-#define BIO_get_data(bio) ((bio)->ptr)
-#define BIO_get_init(bio) ((bio)->init)
-#define BIO_get_shutdown(bio) ((bio)->shutdown)
-#define BIO_set_data(bio, val) (bio)->ptr = (val)
-#define BIO_set_init(bio, val) (bio)->init = (val)
-#define BIO_set_shutdown(bio, val) (bio)->shutdown = (val)
-
-/* XXX: This assumes the variable being assigned to is BioMethods */
-#define BIO_meth_new(type_, name_) (BIO_METHOD *)Tcl_Alloc(sizeof(BIO_METHOD)); \
- memset(BioMethods, 0, sizeof(BIO_METHOD)); \
- BioMethods->type = type_; \
- BioMethods->name = name_;
-#define BIO_meth_set_write(bio, val) (bio)->bwrite = val;
-#define BIO_meth_set_read(bio, val) (bio)->bread = val;
-#define BIO_meth_set_puts(bio, val) (bio)->bputs = val;
-#define BIO_meth_set_ctrl(bio, val) (bio)->ctrl = val;
-#define BIO_meth_set_create(bio, val) (bio)->create = val;
-#define BIO_meth_set_destroy(bio, val) (bio)->destroy = val;
-#endif
-
-/*
- * Forward declarations
- */
-
-static int BioWrite (BIO *h, const char *buf, int num);
-static int BioRead (BIO *h, char *buf, int num);
-static int BioPuts (BIO *h, const char *str);
-static long BioCtrl (BIO *h, int cmd, long arg1, void *ptr);
-static int BioNew (BIO *h);
-static int BioFree (BIO *h);
-
-BIO *BIO_new_tcl(State *statePtr, int flags) {
- BIO *bio;
- static BIO_METHOD *BioMethods = NULL;
-#ifdef TCLTLS_SSL_USE_FASTPATH
- Tcl_Channel parentChannel;
- const Tcl_ChannelType *parentChannelType;
- void *parentChannelFdIn_p, *parentChannelFdOut_p;
- int parentChannelFdIn, parentChannelFdOut, parentChannelFd;
- int validParentChannelFd;
- int tclGetChannelHandleRet;
-#endif
-
- dprintf("BIO_new_tcl() called");
-
- if (BioMethods == NULL) {
- BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl");
- BIO_meth_set_write(BioMethods, BioWrite);
- BIO_meth_set_read(BioMethods, BioRead);
- BIO_meth_set_puts(BioMethods, BioPuts);
- BIO_meth_set_ctrl(BioMethods, BioCtrl);
- BIO_meth_set_create(BioMethods, BioNew);
- BIO_meth_set_destroy(BioMethods, BioFree);
- }
-
- if (statePtr == NULL) {
- dprintf("Asked to setup a NULL state, just creating the initial configuration");
-
- return(NULL);
- }
-
-#ifdef TCLTLS_SSL_USE_FASTPATH
- /*
- * If the channel can be mapped back to a file descriptor, just use the file descriptor
- * with the SSL library since it will likely be optimized for this.
- */
- parentChannel = Tls_GetParent(statePtr, 0);
- parentChannelType = Tcl_GetChannelType(parentChannel);
-
- validParentChannelFd = 0;
- if (strcmp(parentChannelType->typeName, "tcp") == 0) {
- tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, &parentChannelFdIn_p);
- if (tclGetChannelHandleRet == TCL_OK) {
- tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, &parentChannelFdOut_p);
- if (tclGetChannelHandleRet == TCL_OK) {
- parentChannelFdIn = PTR2INT(parentChannelFdIn_p);
- parentChannelFdOut = PTR2INT(parentChannelFdOut_p);
- if (parentChannelFdIn == parentChannelFdOut) {
- parentChannelFd = parentChannelFdIn;
- validParentChannelFd = 1;
- }
- }
- }
- }
-
- if (validParentChannelFd) {
- dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn);
- bio = BIO_new_socket(parentChannelFd, flags);
- statePtr->flags |= TLS_TCL_FASTPATH;
- return(bio);
- }
-
- dprintf("Falling back to Tcl I/O for this channel");
-#endif
-
- bio = BIO_new(BioMethods);
- BIO_set_data(bio, statePtr);
- BIO_set_shutdown(bio, flags);
- BIO_set_init(bio, 1);
-
- return(bio);
-}
-
-static int BioWrite(BIO *bio, const char *buf, int bufLen) {
- Tcl_Channel chan;
- int ret;
- int tclEofChan, tclErrno;
-
- chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
-
- dprintf("[chan=%p] BioWrite(%p, <buf>, %d)", (void *)chan, (void *) bio, bufLen);
-
- ret = Tcl_WriteRaw(chan, buf, bufLen);
-
- tclEofChan = Tcl_Eof(chan);
- tclErrno = Tcl_GetErrno();
-
- dprintf("[chan=%p] BioWrite(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno());
-
- BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY);
-
- if (tclEofChan && ret <= 0) {
- dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
- Tcl_SetErrno(ECONNRESET);
- ret = 0;
- } else if (ret == 0) {
- dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0");
- dprintf("Setting retry read flag");
- BIO_set_retry_read(bio);
- } else if (ret < 0) {
- dprintf("We got some kind of I/O error");
-
- if (tclErrno == EAGAIN) {
- dprintf("It's EAGAIN");
- } else {
- dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
- }
- } else {
- dprintf("Successfully wrote some data");
- }
-
- if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
- if (BIO_should_read(bio)) {
- dprintf("Setting should retry read flag");
-
- BIO_set_retry_read(bio);
- }
- }
-
- return(ret);
-}
-
-static int BioRead(BIO *bio, char *buf, int bufLen) {
- Tcl_Channel chan;
- int ret = 0;
- int tclEofChan, tclErrno;
-
- chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
-
- dprintf("[chan=%p] BioRead(%p, <buf>, %d)", (void *) chan, (void *) bio, bufLen);
-
- if (buf == NULL) {
- return 0;
- }
-
- ret = Tcl_ReadRaw(chan, buf, bufLen);
-
- tclEofChan = Tcl_Eof(chan);
- tclErrno = Tcl_GetErrno();
-
- dprintf("[chan=%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, tclErrno);
-
- BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY);
-
- if (tclEofChan && ret <= 0) {
- dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
- Tcl_SetErrno(ECONNRESET);
- ret = 0;
- } else if (ret == 0) {
- dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0");
- dprintf("Setting retry read flag");
- BIO_set_retry_read(bio);
- } else if (ret < 0) {
- dprintf("We got some kind of I/O error");
-
- if (tclErrno == EAGAIN) {
- dprintf("It's EAGAIN");
- } else {
- dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
- }
- } else {
- dprintf("Successfully read some data");
- }
-
- if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
- if (BIO_should_write(bio)) {
- dprintf("Setting should retry write flag");
-
- BIO_set_retry_write(bio);
- }
- }
-
- dprintf("BioRead(%p, <buf>, %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret);
-
- return(ret);
+/* Called by SSL_write() */
+static int BioWrite(BIO *bio, const char *buf, int bufLen) {
+ Tcl_Channel chan;
+ Tcl_Size ret;
+ int tclEofChan, tclErrno;
+
+ chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
+
+ dprintf("[chan=%p] BioWrite(%p, <buf>, %d)", (void *)chan, (void *) bio, bufLen);
+
+ ret = Tcl_WriteRaw(chan, buf, (Tcl_Size) bufLen);
+
+ tclEofChan = Tcl_Eof(chan);
+ tclErrno = Tcl_GetErrno();
+
+ dprintf("[chan=%p] BioWrite(%d) -> %" TCL_SIZE_MODIFIER "d [tclEof=%d; tclErrno=%d]",
+ (void *) chan, bufLen, ret, tclEofChan, tclErrno);
+
+ BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY);
+
+ if (tclEofChan && ret <= 0) {
+ dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
+ Tcl_SetErrno(ECONNRESET);
+ ret = 0;
+
+ } else if (ret == 0) {
+ dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0");
+ dprintf("Setting retry read flag");
+ BIO_set_retry_read(bio);
+
+ } else if (ret < 0) {
+ dprintf("We got some kind of I/O error");
+
+ if (tclErrno == EAGAIN) {
+ dprintf("It's EAGAIN");
+ } else {
+ dprintf("It's an unexpected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
+ }
+
+ } else {
+ dprintf("Successfully wrote %" TCL_SIZE_MODIFIER "d bytes of data", ret);
+ }
+
+ if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
+ if (BIO_should_read(bio)) {
+ dprintf("Setting should retry read flag");
+
+ BIO_set_retry_read(bio);
+ }
+ }
+ return((int) ret);
+}
+
+/* Called by SSL_read()*/
+static int BioRead(BIO *bio, char *buf, int bufLen) {
+ Tcl_Channel chan;
+ Tcl_Size ret = 0;
+ int tclEofChan, tclErrno;
+
+ chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
+
+ dprintf("[chan=%p] BioRead(%p, <buf>, %d)", (void *) chan, (void *) bio, bufLen);
+
+ if (buf == NULL) {
+ return 0;
+ }
+
+ ret = Tcl_ReadRaw(chan, buf, (Tcl_Size) bufLen);
+
+ tclEofChan = Tcl_Eof(chan);
+ tclErrno = Tcl_GetErrno();
+
+ dprintf("[chan=%p] BioRead(%d) -> %" TCL_SIZE_MODIFIER "d [tclEof=%d; tclErrno=%d]",
+ (void *) chan, bufLen, ret, tclEofChan, tclErrno);
+
+ BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY);
+
+ if (tclEofChan && ret <= 0) {
+ dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
+ Tcl_SetErrno(ECONNRESET);
+ ret = 0;
+
+ } else if (ret == 0) {
+ dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0");
+ dprintf("Setting retry read flag");
+ BIO_set_retry_read(bio);
+
+ } else if (ret < 0) {
+ dprintf("We got some kind of I/O error");
+
+ if (tclErrno == EAGAIN) {
+ dprintf("It's EAGAIN");
+ } else {
+ dprintf("It's an unexpected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
+ }
+
+ } else {
+ dprintf("Successfully read %" TCL_SIZE_MODIFIER "d bytes of data", ret);
+ }
+
+ if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
+ if (BIO_should_write(bio)) {
+ dprintf("Setting should retry write flag");
+
+ BIO_set_retry_write(bio);
+ }
+ }
+
+ dprintf("BioRead(%p, <buf>, %d) [%p] returning %" TCL_SIZE_MODIFIER "d", (void *) bio,
+ bufLen, (void *) chan, ret);
+
+ return((int) ret);
}
static int BioPuts(BIO *bio, const char *str) {
- dprintf("BioPuts(%p, <string:%p>) called", bio, str);
+ dprintf("BioPuts(%p, <string:%p>) called", bio, str);
- return BioWrite(bio, str, (int) strlen(str));
+ return(BioWrite(bio, str, (int) strlen(str)));
}
static long BioCtrl(BIO *bio, int cmd, long num, void *ptr) {
- Tcl_Channel chan;
- long ret = 1;
-
- chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
-
- dprintf("BioCtrl(%p, 0x%x, 0x%lx, %p)", bio, cmd, num, ptr);
-
- switch (cmd) {
- case BIO_CTRL_RESET:
- dprintf("Got BIO_CTRL_RESET");
- num = 0;
- ret = 0;
- break;
- case BIO_C_FILE_SEEK:
- dprintf("Got BIO_C_FILE_SEEK");
- ret = 0;
- break;
- case BIO_C_FILE_TELL:
- dprintf("Got BIO_C_FILE_TELL");
- ret = 0;
- break;
- case BIO_CTRL_INFO:
- dprintf("Got BIO_CTRL_INFO");
- ret = 1;
- break;
- case BIO_C_SET_FD:
- dprintf("Unsupported call: BIO_C_SET_FD");
- ret = -1;
- break;
- case BIO_C_GET_FD:
- dprintf("Unsupported call: BIO_C_GET_FD");
- ret = -1;
- break;
- case BIO_CTRL_GET_CLOSE:
- dprintf("Got BIO_CTRL_CLOSE");
- ret = BIO_get_shutdown(bio);
- break;
- case BIO_CTRL_SET_CLOSE:
- dprintf("Got BIO_SET_CLOSE");
- BIO_set_shutdown(bio, num);
- break;
- case BIO_CTRL_EOF:
- dprintf("Got BIO_CTRL_EOF");
- ret = Tcl_Eof(chan);
- break;
- case BIO_CTRL_PENDING:
- dprintf("Got BIO_CTRL_PENDING");
- ret = ((chan) ? Tcl_InputBuffered(chan) : 0);
- dprintf("BIO_CTRL_PENDING(%d)", (int) ret);
- break;
- case BIO_CTRL_WPENDING:
- dprintf("Got BIO_CTRL_WPENDING");
- ret = 0;
- break;
- case BIO_CTRL_DUP:
- dprintf("Got BIO_CTRL_DUP");
- break;
- case BIO_CTRL_FLUSH:
- dprintf("Got BIO_CTRL_FLUSH");
- ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
- dprintf("BIO_CTRL_FLUSH returning value %li", ret);
- break;
- default:
- dprintf("Got unknown control command (%i)", cmd);
- ret = -2;
- break;
- }
-
- return(ret);
+ Tcl_Channel chan;
+ long ret = 1;
+
+ chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
+
+ dprintf("BioCtrl(%p, 0x%x, 0x%lx, %p)", (void *) bio, cmd, num, ptr);
+
+ switch (cmd) {
+ case BIO_CTRL_RESET:
+ dprintf("Got BIO_CTRL_RESET");
+ num = 0;
+ ret = 0;
+ break;
+ case BIO_C_FILE_SEEK:
+ dprintf("Got BIO_C_FILE_SEEK");
+ ret = 0;
+ break;
+ case BIO_C_FILE_TELL:
+ dprintf("Got BIO_C_FILE_TELL");
+ ret = 0;
+ break;
+ case BIO_CTRL_INFO:
+ dprintf("Got BIO_CTRL_INFO");
+ ret = 1;
+ break;
+ case BIO_C_SET_FD:
+ dprintf("Unsupported call: BIO_C_SET_FD");
+ ret = -1;
+ break;
+ case BIO_C_GET_FD:
+ dprintf("Unsupported call: BIO_C_GET_FD");
+ ret = -1;
+ break;
+ case BIO_CTRL_GET_CLOSE:
+ dprintf("Got BIO_CTRL_CLOSE");
+ ret = BIO_get_shutdown(bio);
+ break;
+ case BIO_CTRL_SET_CLOSE:
+ dprintf("Got BIO_SET_CLOSE");
+ BIO_set_shutdown(bio, num);
+ break;
+ case BIO_CTRL_EOF:
+ dprintf("Got BIO_CTRL_EOF");
+ ret = ((chan) ? Tcl_Eof(chan) : 1);
+ break;
+ case BIO_CTRL_PENDING:
+ dprintf("Got BIO_CTRL_PENDING");
+ ret = ((chan) ? ((Tcl_InputBuffered(chan) ? 1 : 0)) : 0);
+ dprintf("BIO_CTRL_PENDING(%d)", (int) ret);
+ break;
+ case BIO_CTRL_WPENDING:
+ dprintf("Got BIO_CTRL_WPENDING");
+ ret = 0;
+ break;
+ case BIO_CTRL_DUP:
+ dprintf("Got BIO_CTRL_DUP");
+ break;
+ case BIO_CTRL_FLUSH:
+ dprintf("Got BIO_CTRL_FLUSH");
+ ret = ((chan) && (Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
+ dprintf("BIO_CTRL_FLUSH returning value %li", ret);
+ break;
+ case BIO_CTRL_PUSH:
+ dprintf("Got BIO_CTRL_PUSH");
+ ret = 0;
+ break;
+ case BIO_CTRL_POP:
+ dprintf("Got BIO_CTRL_POP");
+ ret = 0;
+ break;
+ case BIO_CTRL_SET:
+ dprintf("Got BIO_CTRL_SET");
+ ret = 0;
+ break;
+ case BIO_CTRL_GET :
+ dprintf("Got BIO_CTRL_GET ");
+ ret = 0;
+ break;
+#ifdef BIO_CTRL_GET_KTLS_SEND
+ case BIO_CTRL_GET_KTLS_SEND:
+ dprintf("Got BIO_CTRL_GET_KTLS_SEND");
+ ret = 0;
+ break;
+#endif
+#ifdef BIO_CTRL_GET_KTLS_RECV
+ case BIO_CTRL_GET_KTLS_RECV:
+ dprintf("Got BIO_CTRL_GET_KTLS_RECV");
+ ret = 0;
+ break;
+#endif
+ default:
+ dprintf("Got unknown control command (%i)", cmd);
+ ret = 0;
+ break;
+ }
+ return(ret);
}
static int BioNew(BIO *bio) {
- dprintf("BioNew(%p) called", bio);
+ dprintf("BioNew(%p) called", bio);
- BIO_set_init(bio, 0);
- BIO_set_data(bio, NULL);
- BIO_clear_flags(bio, -1);
-
- return(1);
+ BIO_set_init(bio, 0);
+ BIO_set_data(bio, NULL);
+ BIO_clear_flags(bio, -1);
+ return(1);
}
static int BioFree(BIO *bio) {
- if (bio == NULL) {
- return(0);
- }
-
- dprintf("BioFree(%p) called", bio);
-
- if (BIO_get_shutdown(bio)) {
- if (BIO_get_init(bio)) {
- /*shutdown(bio->num, 2) */
- /*closesocket(bio->num) */
- }
-
- BIO_set_init(bio, 0);
- BIO_clear_flags(bio, -1);
- }
-
- return(1);
+ if (bio == NULL) {
+ return(0);
+ }
+
+ dprintf("BioFree(%p) called", bio);
+
+ if (BIO_get_shutdown(bio)) {
+ if (BIO_get_init(bio)) {
+ /*shutdown(bio->num, 2) */
+ /*closesocket(bio->num) */
+ }
+
+ BIO_set_init(bio, 0);
+ BIO_clear_flags(bio, -1);
+ }
+ return(1);
+}
+
+BIO *BIO_new_tcl(State *statePtr, int flags) {
+ BIO *bio;
+ static BIO_METHOD *BioMethods = NULL;
+#ifdef TCLTLS_SSL_USE_FASTPATH
+ Tcl_Channel parentChannel;
+ const Tcl_ChannelType *parentChannelType;
+ void *parentChannelFdIn_p, *parentChannelFdOut_p;
+ int parentChannelFdIn, parentChannelFdOut, parentChannelFd;
+ int validParentChannelFd;
+ int tclGetChannelHandleRet;
+#endif
+
+ dprintf("BIO_new_tcl() called");
+
+ if (BioMethods == NULL) {
+ BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl");
+ BIO_meth_set_write(BioMethods, BioWrite);
+ BIO_meth_set_read(BioMethods, BioRead);
+ BIO_meth_set_puts(BioMethods, BioPuts);
+ BIO_meth_set_ctrl(BioMethods, BioCtrl);
+ BIO_meth_set_create(BioMethods, BioNew);
+ BIO_meth_set_destroy(BioMethods, BioFree);
+ }
+
+ if (statePtr == NULL) {
+ dprintf("Asked to setup a NULL state, just creating the initial configuration");
+
+ return(NULL);
+ }
+
+#ifdef TCLTLS_SSL_USE_FASTPATH
+ /*
+ * If the channel can be mapped back to a file descriptor, just use the file descriptor
+ * with the SSL library since it will likely be optimized for this.
+ */
+ parentChannel = Tls_GetParent(statePtr, 0);
+ parentChannelType = Tcl_GetChannelType(parentChannel);
+
+ validParentChannelFd = 0;
+ if (strcmp(parentChannelType->typeName, "tcp") == 0) {
+ tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, (ClientData) &parentChannelFdIn_p);
+ if (tclGetChannelHandleRet == TCL_OK) {
+ tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, (ClientData) &parentChannelFdOut_p);
+ if (tclGetChannelHandleRet == TCL_OK) {
+ parentChannelFdIn = PTR2INT(parentChannelFdIn_p);
+ parentChannelFdOut = PTR2INT(parentChannelFdOut_p);
+ if (parentChannelFdIn == parentChannelFdOut) {
+ parentChannelFd = parentChannelFdIn;
+ validParentChannelFd = 1;
+ }
+ }
+ }
+ }
+
+ if (validParentChannelFd) {
+ dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn);
+ bio = BIO_new_socket(parentChannelFd, flags);
+ statePtr->flags |= TLS_TCL_FASTPATH;
+ return(bio);
+ }
+
+ dprintf("Falling back to Tcl I/O for this channel");
+#endif
+
+ bio = BIO_new(BioMethods);
+ BIO_set_data(bio, statePtr);
+ BIO_set_shutdown(bio, flags);
+ BIO_set_init(bio, 1);
+ return(bio);
}
Index: generic/tlsIO.c
==================================================================
--- generic/tlsIO.c
+++ generic/tlsIO.c
@@ -10,937 +10,949 @@
* Addition 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.
*
* Also work done by the follow people provided the impetus to do this "right":
- * tclSSL (Colin McCormack, Shared Technology)
- * SSLtcl (Peter Antman)
+ * tclSSL (Colin McCormack, Shared Technology)
+ * SSLtcl (Peter Antman)
*
*/
#include "tlsInt.h"
+#include <errno.h>
/*
* Forward declarations
*/
-static int TlsBlockModeProc (void *instanceData, int mode);
-static int TlsCloseProc (void *instanceData, Tcl_Interp *interp);
-static int TlsClose2Proc (void *instanceData, Tcl_Interp *interp, int flags);
-static int TlsInputProc (void *instanceData, char *buf, int bufSize, int *errorCodePtr);
-static int TlsOutputProc (void *instanceData, const char *buf, int toWrite, int *errorCodePtr);
-static int TlsGetOptionProc (void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr);
-static void TlsWatchProc (void *instanceData, int mask);
-static int TlsGetHandleProc (void *instanceData, int direction, void **handlePtr);
-static int TlsNotifyProc (void *instanceData, int mask);
-static void TlsChannelHandlerTimer (void *clientData);
-
-/*
- * TLS Channel Type
- */
-static const Tcl_ChannelType tlsChannelType = {
- "tls", /* typeName */
- TCL_CHANNEL_VERSION_5, /* version */
- TlsCloseProc, /* closeProc */
- TlsInputProc, /* inputProc */
- TlsOutputProc, /* outputProc */
- 0, /* seekProc */
- 0, /* setOptionProc */
- TlsGetOptionProc, /* getOptionProc */
- TlsWatchProc, /* watchProc */
- TlsGetHandleProc, /* getHandleProc */
- TlsClose2Proc, /* close2Proc */
- TlsBlockModeProc, /* blockModeProc */
- 0, /* flushProc */
- TlsNotifyProc, /* handlerProc */
- 0, /* wideSeekProc */
- 0, /* threadActionProc */
- 0 /* truncateProc */
-};
-
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_ChannelType --
- *
- * Return the correct TLS channel driver info
- *
- * Results:
- * The correct channel driver for the current version of Tcl.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-const Tcl_ChannelType *Tls_ChannelType(void) {
- return &tlsChannelType;
-}
+static void TlsChannelHandlerTimer(ClientData clientData);
/*
*-------------------------------------------------------------------
*
* TlsBlockModeProc --
*
- * This procedure is invoked by the generic IO level
+ * This procedure is invoked by the generic IO level
* to set blocking and nonblocking modes
+ *
* Results:
- * 0 if successful, errno when failed.
+ * 0 if successful or POSIX error code if failed.
*
* Side effects:
- * Sets the device into blocking or nonblocking mode.
+ * Sets the device into blocking or nonblocking mode.
*
*-------------------------------------------------------------------
*/
-static int TlsBlockModeProc(void *instanceData, int mode) {
- State *statePtr = (State *) instanceData;
-
- if (mode == TCL_MODE_NONBLOCKING) {
- statePtr->flags |= TLS_TCL_ASYNC;
- } else {
- statePtr->flags &= ~(TLS_TCL_ASYNC);
- }
-
- return(0);
+static int TlsBlockModeProc(ClientData instanceData, int mode) {
+ State *statePtr = (State *) instanceData;
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ statePtr->flags |= TLS_TCL_ASYNC;
+ } else {
+ statePtr->flags &= ~(TLS_TCL_ASYNC);
+ }
+ return(0);
}
/*
*-------------------------------------------------------------------
*
* TlsCloseProc --
*
- * This procedure is invoked by the generic IO level to perform
- * channel-type-specific cleanup when a SSL socket based channel
- * is closed.
+ * This procedure is invoked by the generic IO level to perform
+ * channel-type-specific cleanup when a SSL socket based channel
+ * is closed.
*
- * Note: we leave the underlying socket alone, is this right?
+ * Note: we leave the underlying socket alone, is this right?
*
* Results:
- * 0 if successful, the value of Tcl_GetErrno() if failed.
+ * 0 if successful or POSIX error code if failed.
*
* Side effects:
- * Closes the socket of the channel.
+ * Closes the socket of the channel.
*
*-------------------------------------------------------------------
*/
-static int TlsCloseProc(void *instanceData, TCL_UNUSED(Tcl_Interp *)) {
- State *statePtr = (State *) instanceData;
-
- dprintf("TlsCloseProc(%p)", statePtr);
-
- Tls_Clean(statePtr);
- Tcl_EventuallyFree(statePtr, Tls_Free);
-
- dprintf("Returning TCL_OK");
-
- return(TCL_OK);
-}
-
-static int TlsClose2Proc(void *instanceData, Tcl_Interp *interp, int flags) {
- if (!(flags&(TCL_CLOSE_READ|TCL_CLOSE_WRITE))) {
- return TlsCloseProc(instanceData, interp);
- }
- return EINVAL;
+static int TlsCloseProc(ClientData instanceData, Tcl_Interp *interp) {
+ State *statePtr = (State *) instanceData;
+
+ dprintf("TlsCloseProc(%p)", (void *) statePtr);
+
+ Tls_Clean(statePtr);
+ Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
+ return(0);
+}
+
+static int TlsClose2Proc(ClientData instanceData, /* The socket state. */
+ Tcl_Interp *interp, /* For errors - can be NULL. */
+ int flags) /* Flags to close read and/or write side of channel */
+{
+ State *statePtr = (State *) instanceData;
+
+ dprintf("TlsClose2Proc(%p)", (void *) statePtr);
+
+ if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
+ return TlsCloseProc(instanceData, interp);
+ }
+ return EINVAL;
}
/*
*------------------------------------------------------*
*
- * Tls_WaitForConnect --
+ * Tls_WaitForConnect --
*
- * Sideeffects:
- * Issues SSL_accept or SSL_connect
+ * Result:
+ * 0 if successful, -1 if failed.
*
- * Result:
- * None.
+ * Side effects:
+ * Issues SSL_accept or SSL_connect
*
*------------------------------------------------------*
*/
int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) {
- unsigned long backingError;
- int err, rc;
- int bioShouldRetry;
-
- dprintf("WaitForConnect(%p)", statePtr);
- dprintFlags(statePtr);
-
- if (!(statePtr->flags & TLS_TCL_INIT)) {
- dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success");
- *errorCodePtr = 0;
- return(0);
- }
-
- if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
- /*
- * Different types of operations have different requirements
- * SSL being established
- */
- 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");
- *errorCodePtr = ECONNRESET;
- }
- return(-1);
- }
-
- for (;;) {
- /* Not initialized yet! */
- if (statePtr->flags & TLS_TCL_SERVER) {
- dprintf("Calling SSL_accept()");
-
- err = SSL_accept(statePtr->ssl);
- } else {
- dprintf("Calling SSL_connect()");
-
- err = SSL_connect(statePtr->ssl);
- }
-
- if (err > 0) {
- dprintf("That seems to have gone okay");
-
- err = BIO_flush(statePtr->bio);
-
- if (err <= 0) {
- dprintf("Flushing the lower layers failed, this will probably terminate this session");
- }
- }
-
- rc = SSL_get_error(statePtr->ssl, err);
-
- dprintf("Got error: %i (rc = %i)", err, rc);
-
- bioShouldRetry = 0;
- if (err <= 0) {
- if (rc == SSL_ERROR_WANT_CONNECT || rc == SSL_ERROR_WANT_ACCEPT || rc == SSL_ERROR_WANT_READ || rc == SSL_ERROR_WANT_WRITE) {
- bioShouldRetry = 1;
- } else if (BIO_should_retry(statePtr->bio)) {
- bioShouldRetry = 1;
- } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) {
- bioShouldRetry = 1;
- }
- } else {
- if (!SSL_is_init_finished(statePtr->ssl)) {
- bioShouldRetry = 1;
- }
- }
-
- if (bioShouldRetry) {
- dprintf("The I/O did not complete -- but we should try it again");
-
- if (statePtr->flags & TLS_TCL_ASYNC) {
- dprintf("Returning EAGAIN so that it can be retried later");
-
- *errorCodePtr = EAGAIN;
-
- return(-1);
- } else {
- dprintf("Doing so now");
-
- continue;
- }
- }
-
- dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though");
- break;
- }
-
-
- *errorCodePtr = EINVAL;
-
- switch (rc) {
- case SSL_ERROR_NONE:
- /* The connection is up, we are done here */
- dprintf("The connection is up");
- break;
- case SSL_ERROR_ZERO_RETURN:
- dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...")
- return(-1);
- case SSL_ERROR_SYSCALL:
- backingError = ERR_get_error();
-
- if (backingError == 0 && err == 0) {
- dprintf("EOF reached")
- *errorCodePtr = ECONNRESET;
- } else if (backingError == 0 && err == -1) {
- dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- if (*errorCodePtr == ECONNRESET) {
- *errorCodePtr = ECONNABORTED;
- }
- } else {
- dprintf("I/O error occured (backingError = %lu)", backingError);
- *errorCodePtr = backingError;
- if (*errorCodePtr == ECONNRESET) {
- *errorCodePtr = ECONNABORTED;
- }
- }
-
- statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
-
- return(-1);
- case SSL_ERROR_SSL:
- dprintf("Got permanent fatal SSL error, aborting immediately");
- Tls_Error(statePtr, (char *)ERR_reason_error_string(ERR_get_error()));
- statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
- *errorCodePtr = ECONNABORTED;
- return(-1);
- case SSL_ERROR_WANT_CONNECT:
- case SSL_ERROR_WANT_ACCEPT:
- case SSL_ERROR_WANT_X509_LOOKUP:
- default:
- dprintf("We got a confusing reply: %i", rc);
- *errorCodePtr = Tcl_GetErrno();
- dprintf("ERR(%d, %d) ", rc, *errorCodePtr);
- return(-1);
- }
-
-#if 0
- if (statePtr->flags & TLS_TCL_SERVER) {
- dprintf("This is an TLS server, checking the certificate for the peer");
-
- err = SSL_get_verify_result(statePtr->ssl);
- if (err != X509_V_OK) {
- dprintf("Invalid certificate, returning in failure");
-
- Tls_Error(statePtr, (char *)X509_verify_cert_error_string(err));
- statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
- *errorCodePtr = ECONNABORTED;
- return(-1);
- }
- }
-#endif
-
- dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake");
- statePtr->flags &= ~TLS_TCL_INIT;
-
- dprintf("Returning in success");
- *errorCodePtr = 0;
-
- return(0);
+ unsigned long backingError;
+ int err, rc;
+ int bioShouldRetry;
+ *errorCodePtr = 0;
+
+ dprintf("WaitForConnect(%p)", (void *) statePtr);
+ dprintFlags(statePtr);
+
+ if (!(statePtr->flags & TLS_TCL_INIT)) {
+ dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success");
+ return(0);
+ }
+
+ if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
+ /*
+ * Different types of operations have different requirements
+ * SSL being established
+ */
+ 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");
+ *errorCodePtr = ECONNRESET;
+ }
+ Tls_Error(statePtr, "Wait for failed handshake");
+ return(-1);
+ }
+
+ for (;;) {
+ ERR_clear_error();
+
+ /* Not initialized yet! Also calls SSL_do_handshake. */
+ if (statePtr->flags & TLS_TCL_SERVER) {
+ dprintf("Calling SSL_accept()");
+ err = SSL_accept(statePtr->ssl);
+
+ } else {
+ dprintf("Calling SSL_connect()");
+ err = SSL_connect(statePtr->ssl);
+ }
+
+ if (err > 0) {
+ dprintf("Accept or connect was successful");
+
+ err = BIO_flush(statePtr->bio);
+ if (err <= 0) {
+ dprintf("Flushing the lower layers failed, this will probably terminate this session");
+ }
+ } else {
+ dprintf("Accept or connect failed");
+ }
+
+ 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));
+ }
+
+ bioShouldRetry = 0;
+ if (err <= 0) {
+ if (rc == SSL_ERROR_WANT_CONNECT || rc == SSL_ERROR_WANT_ACCEPT || rc == SSL_ERROR_WANT_READ || rc == SSL_ERROR_WANT_WRITE) {
+ bioShouldRetry = 1;
+ } else if (BIO_should_retry(statePtr->bio)) {
+ bioShouldRetry = 1;
+ } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) {
+ bioShouldRetry = 1;
+ }
+ } else {
+ if (!SSL_is_init_finished(statePtr->ssl)) {
+ bioShouldRetry = 1;
+ }
+ }
+
+ if (bioShouldRetry) {
+ dprintf("The I/O did not complete -- but we should try it again");
+
+ if (statePtr->flags & TLS_TCL_ASYNC) {
+ dprintf("Returning EAGAIN so that it can be retried later");
+ *errorCodePtr = EAGAIN;
+ Tls_Error(statePtr, "Handshake not complete, will retry later");
+ return(-1);
+ } else {
+ dprintf("Doing so now");
+ continue;
+ }
+ }
+
+ dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though");
+ break;
+ }
+
+ switch (rc) {
+ case SSL_ERROR_NONE:
+ /* The TLS/SSL I/O operation completed */
+ dprintf("The connection is good");
+ *errorCodePtr = 0;
+ break;
+
+ case SSL_ERROR_ZERO_RETURN:
+ /* The TLS/SSL peer has closed the connection for writing by sending the close_notify alert */
+ dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...");
+ *errorCodePtr = EINVAL;
+ Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert");
+ return(-1);
+
+ case SSL_ERROR_SYSCALL:
+ /* Some non-recoverable, fatal I/O error occurred */
+ dprintf("SSL_ERROR_SYSCALL");
+
+ if (backingError == 0 && err == 0) {
+ dprintf("EOF reached")
+ *errorCodePtr = ECONNRESET;
+ Tls_Error(statePtr, "(unexpected) EOF reached");
+
+ } else if (backingError == 0 && err == -1) {
+ dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ if (*errorCodePtr == ECONNRESET) {
+ *errorCodePtr = ECONNABORTED;
+ }
+ Tls_Error(statePtr, (char *) Tcl_ErrnoMsg(*errorCodePtr));
+
+ } else {
+ dprintf("I/O error occurred (backingError = %lu)", backingError);
+ *errorCodePtr = Tcl_GetErrno();
+ if (*errorCodePtr == ECONNRESET) {
+ *errorCodePtr = ECONNABORTED;
+ }
+ Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError));
+ }
+
+ statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+ return(-1);
+
+ case SSL_ERROR_SSL:
+ /* A non-recoverable, fatal error in the SSL library occurred, usually a protocol error */
+ dprintf("SSL_ERROR_SSL: Got permanent fatal SSL error, aborting immediately");
+ if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) {
+ Tls_Error(statePtr, (char *) X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl)));
+ }
+ if (backingError != 0) {
+ Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError));
+ }
+ statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+ *errorCodePtr = ECONNABORTED;
+ return(-1);
+
+ case SSL_ERROR_WANT_READ:
+ case SSL_ERROR_WANT_WRITE:
+ case SSL_ERROR_WANT_X509_LOOKUP:
+ case SSL_ERROR_WANT_CONNECT:
+ case SSL_ERROR_WANT_ACCEPT:
+ case SSL_ERROR_WANT_ASYNC:
+ case SSL_ERROR_WANT_ASYNC_JOB:
+ case SSL_ERROR_WANT_CLIENT_HELLO_CB:
+ default:
+ /* The operation did not complete and should be retried later. */
+ dprintf("Operation did not complete, call function again later: %i", rc);
+ *errorCodePtr = EAGAIN;
+ dprintf("ERR(%d, %d) ", rc, *errorCodePtr);
+ Tls_Error(statePtr, "Operation did not complete, call function again later");
+ return(-1);
+ }
+
+ dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake");
+ statePtr->flags &= ~TLS_TCL_INIT;
+
+ dprintf("Returning in success");
+ *errorCodePtr = 0;
+ return(0);
}
/*
*-------------------------------------------------------------------
*
* TlsInputProc --
*
- * This procedure is invoked by the generic IO level
+ * This procedure is invoked by the generic IO level
* to read input from a SSL socket based channel.
*
* Results:
- * The number of bytes read is returned or -1 on error. An output
- * argument contains the POSIX error code on error, or zero if no
- * error occurred.
- *
- * Side effects:
- * Reads input from the input device of the channel.
- *
- *-------------------------------------------------------------------
- */
-
-static int TlsInputProc(void *instanceData, char *buf, int bufSize, int *errorCodePtr) {
- unsigned long backingError;
- State *statePtr = (State *) instanceData;
- int bytesRead;
- int tlsConnect;
- int err;
-
- *errorCodePtr = 0;
-
- dprintf("BIO_read(%d)", bufSize);
-
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- /* don't process any bytes while verify callback is running */
- dprintf("Callback is running, reading 0 bytes");
- return(0);
- }
-
- dprintf("Calling Tls_WaitForConnect");
- tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 0);
- if (tlsConnect < 0) {
- dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
-
- bytesRead = -1;
- if (*errorCodePtr == ECONNRESET) {
- dprintf("Got connection reset");
- /* Soft EOF */
- *errorCodePtr = 0;
- bytesRead = 0;
- }
-
- return(bytesRead);
- }
-
- /*
- * We need to clear the SSL error stack now because we sometimes reach
- * this function with leftover errors in the stack. If BIO_read
- * returns -1 and intends EAGAIN, there is a leftover error, it will be
- * misconstrued as an error, not EAGAIN.
- *
- * Alternatively, we may want to handle the <0 return codes from
- * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO
- * functions play with the retry flags though, and this seems to work
- * correctly. Similar fix in TlsOutputProc. - hobbs
- */
- ERR_clear_error();
- bytesRead = BIO_read(statePtr->bio, buf, bufSize);
- dprintf("BIO_read -> %d", bytesRead);
-
- err = SSL_get_error(statePtr->ssl, bytesRead);
-
-#if 0
- if (bytesRead <= 0) {
- if (BIO_should_retry(statePtr->bio)) {
- dprintf("I/O failed, will retry based on EAGAIN");
- *errorCodePtr = EAGAIN;
- }
- }
-#endif
-
- switch (err) {
- case SSL_ERROR_NONE:
- dprintBuffer(buf, bytesRead);
- break;
- case SSL_ERROR_SSL:
- dprintf("SSL negotiation error, indicating that the connection has been aborted");
-
- Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, bytesRead));
- *errorCodePtr = ECONNABORTED;
- bytesRead = -1;
-
- break;
- case SSL_ERROR_SYSCALL:
- backingError = ERR_get_error();
-
- if (backingError == 0 && bytesRead == 0) {
- dprintf("EOF reached")
- *errorCodePtr = 0;
- bytesRead = 0;
- } else if (backingError == 0 && bytesRead == -1) {
- dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- bytesRead = -1;
- } else {
- dprintf("I/O error occured (backingError = %lu)", backingError);
- *errorCodePtr = backingError;
- bytesRead = -1;
- }
-
- break;
- case SSL_ERROR_ZERO_RETURN:
- dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached");
- bytesRead = 0;
- *errorCodePtr = 0;
- break;
- case SSL_ERROR_WANT_READ:
- dprintf("Got SSL_ERROR_WANT_READ, mapping this to EAGAIN");
- bytesRead = -1;
- *errorCodePtr = EAGAIN;
- break;
- default:
- dprintf("Unknown error (err = %i), mapping to EOF", err);
- *errorCodePtr = 0;
- bytesRead = 0;
- break;
- }
-
- dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
- return(bytesRead);
+ * 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.
+ *
+ * Side effects:
+ * Reads input from the input device of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsInputProc(ClientData instanceData, char *buf, int bufSize, int *errorCodePtr) {
+ unsigned long backingError;
+ State *statePtr = (State *) instanceData;
+ int bytesRead;
+ int tlsConnect;
+ int err;
+
+ *errorCodePtr = 0;
+
+ dprintf("BIO_read(%d)", bufSize);
+
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ /* don't process any bytes while verify callback is running */
+ dprintf("Callback is running, reading 0 bytes");
+ return(0);
+ }
+
+ dprintf("Calling Tls_WaitForConnect");
+ tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 0);
+ if (tlsConnect < 0) {
+ dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
+ Tls_Error(statePtr, strerror(*errorCodePtr));
+
+ bytesRead = -1;
+ if (*errorCodePtr == ECONNRESET) {
+ dprintf("Got connection reset");
+ /* Soft EOF */
+ *errorCodePtr = 0;
+ bytesRead = 0;
+ }
+ return(bytesRead);
+ }
+
+ /*
+ * We need to clear the SSL error stack now because we sometimes reach
+ * this function with leftover errors in the stack. If BIO_read
+ * returns -1 and intends EAGAIN, there is a leftover error, it will be
+ * misconstrued as an error, not EAGAIN.
+ *
+ * Alternatively, we may want to handle the <0 return codes from
+ * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO
+ * functions play with the retry flags though, and this seems to work
+ * correctly. Similar fix in TlsOutputProc. - hobbs
+ */
+ ERR_clear_error();
+ bytesRead = BIO_read(statePtr->bio, buf, bufSize);
+ dprintf("BIO_read -> %d", bytesRead);
+
+ err = SSL_get_error(statePtr->ssl, bytesRead);
+ backingError = ERR_get_error();
+
+#if 0
+ if (bytesRead <= 0) {
+ if (BIO_should_retry(statePtr->bio)) {
+ dprintf("I/O failed, will retry based on EAGAIN");
+ *errorCodePtr = EAGAIN;
+ }
+ }
+#endif
+
+ switch (err) {
+ case SSL_ERROR_NONE:
+ dprintBuffer(buf, bytesRead);
+ break;
+
+ case SSL_ERROR_SSL:
+ /* A non-recoverable, fatal error in the SSL library occurred, usually a protocol error */
+ dprintf("SSL error, indicating that the connection has been aborted");
+ if (backingError != 0) {
+ Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError));
+ } else if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) {
+ Tls_Error(statePtr, (char *) X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl)));
+ } else {
+ Tls_Error(statePtr, "Unknown SSL error");
+ }
+ *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) {
+ dprintf("(Unexpected) EOF reached")
+ *errorCodePtr = 0;
+ bytesRead = 0;
+ Tls_Error(statePtr, "EOF reached");
+ }
+#endif
+ break;
+
+ case SSL_ERROR_SYSCALL:
+ /* Some non-recoverable, fatal I/O error occurred */
+
+ if (backingError == 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());
+ *errorCodePtr = Tcl_GetErrno();
+ bytesRead = -1;
+ Tls_Error(statePtr, (char *) Tcl_ErrnoMsg(*errorCodePtr));
+
+ } else {
+ dprintf("I/O error occurred (backingError = %lu)", backingError);
+ *errorCodePtr = Tcl_GetErrno();
+ bytesRead = -1;
+ Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError));
+ }
+ break;
+
+ case SSL_ERROR_ZERO_RETURN:
+ dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached");
+ bytesRead = 0;
+ *errorCodePtr = 0;
+ Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert");
+ break;
+
+ case SSL_ERROR_WANT_READ:
+ dprintf("Got SSL_ERROR_WANT_READ, mapping this to EAGAIN");
+ bytesRead = -1;
+ *errorCodePtr = EAGAIN;
+ Tls_Error(statePtr, "SSL_ERROR_WANT_READ");
+ break;
+
+ default:
+ dprintf("Unknown error (err = %i), mapping to EOF", err);
+ *errorCodePtr = 0;
+ bytesRead = 0;
+ Tls_Error(statePtr, "Unknown error");
+ break;
+ }
+
+ dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
+ return(bytesRead);
}
/*
*-------------------------------------------------------------------
*
* TlsOutputProc --
*
- * This procedure is invoked by the generic IO level
+ * This procedure is invoked by the generic IO level
* to write output to a SSL socket based channel.
*
* Results:
- * The number of bytes written is returned. An output argument is
- * set to a POSIX error code if an error occurred, or zero.
- *
- * Side effects:
- * Writes output on the output device of the channel.
- *
- *-------------------------------------------------------------------
- */
-
-static int TlsOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCodePtr) {
- unsigned long backingError;
- State *statePtr = (State *) instanceData;
- int written, err;
- int tlsConnect;
-
- *errorCodePtr = 0;
-
- dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite);
- dprintBuffer(buf, toWrite);
-
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- dprintf("Don't process output while callbacks are running")
- written = -1;
- *errorCodePtr = EAGAIN;
- return(-1);
- }
-
- dprintf("Calling Tls_WaitForConnect");
- tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 1);
- if (tlsConnect < 0) {
- dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
-
- written = -1;
- if (*errorCodePtr == ECONNRESET) {
- dprintf("Got connection reset");
- /* Soft EOF */
- *errorCodePtr = 0;
- written = 0;
- }
-
- return(written);
- }
-
- if (toWrite == 0) {
- dprintf("zero-write");
- err = BIO_flush(statePtr->bio);
-
- if (err <= 0) {
- dprintf("Flushing failed");
-
- *errorCodePtr = EIO;
- written = 0;
- return(-1);
- }
-
- written = 0;
- *errorCodePtr = 0;
- return(0);
- }
-
- /*
- * We need to clear the SSL error stack now because we sometimes reach
- * this function with leftover errors in the stack. If BIO_write
- * returns -1 and intends EAGAIN, there is a leftover error, it will be
- * misconstrued as an error, not EAGAIN.
- *
- * Alternatively, we may want to handle the <0 return codes from
- * BIO_write specially (as advised in the RSA docs). TLS's lower level
- * BIO functions play with the retry flags though, and this seems to
- * work correctly. Similar fix in TlsInputProc. - hobbs
- */
- ERR_clear_error();
- written = BIO_write(statePtr->bio, buf, toWrite);
- dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written);
-
- err = SSL_get_error(statePtr->ssl, written);
- switch (err) {
- case SSL_ERROR_NONE:
- if (written < 0) {
- written = 0;
- }
- break;
- case SSL_ERROR_WANT_WRITE:
- dprintf("Got SSL_ERROR_WANT_WRITE, mapping it to EAGAIN");
- *errorCodePtr = EAGAIN;
- written = -1;
- break;
- case SSL_ERROR_WANT_READ:
- dprintf(" write R BLOCK");
- break;
- case SSL_ERROR_WANT_X509_LOOKUP:
- dprintf(" write X BLOCK");
- break;
- case SSL_ERROR_ZERO_RETURN:
- dprintf(" closed");
- written = 0;
- *errorCodePtr = 0;
- break;
- case SSL_ERROR_SYSCALL:
- backingError = ERR_get_error();
-
- if (backingError == 0 && written == 0) {
- dprintf("EOF reached")
- *errorCodePtr = 0;
- written = 0;
- } else if (backingError == 0 && written == -1) {
- dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- written = -1;
- } else {
- dprintf("I/O error occured (backingError = %lu)", backingError);
- *errorCodePtr = backingError;
- written = -1;
- }
-
- break;
- case SSL_ERROR_SSL:
- Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written));
- *errorCodePtr = ECONNABORTED;
- written = -1;
- break;
- default:
- dprintf(" unknown err: %d", err);
- break;
- }
-
- dprintf("Output(%d) -> %d", toWrite, written);
- return(written);
+ * 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.
+ *
+ * Side effects:
+ * Writes output on the output device of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) {
+ unsigned long backingError;
+ State *statePtr = (State *) instanceData;
+ int written, err;
+ int tlsConnect;
+
+ *errorCodePtr = 0;
+
+ dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite);
+ dprintBuffer(buf, toWrite);
+
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ dprintf("Don't process output while callbacks are running");
+ written = -1;
+ *errorCodePtr = EAGAIN;
+ return(-1);
+ }
+
+ dprintf("Calling Tls_WaitForConnect");
+ tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 1);
+ if (tlsConnect < 0) {
+ dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
+ Tls_Error(statePtr, strerror(*errorCodePtr));
+
+ written = -1;
+ if (*errorCodePtr == ECONNRESET) {
+ dprintf("Got connection reset");
+ /* Soft EOF */
+ *errorCodePtr = 0;
+ written = 0;
+ }
+ return(written);
+ }
+
+ if (toWrite == 0) {
+ dprintf("zero-write");
+ err = BIO_flush(statePtr->bio);
+
+ if (err <= 0) {
+ dprintf("Flushing failed");
+ Tls_Error(statePtr, "Flush failed");
+
+ *errorCodePtr = EIO;
+ written = 0;
+ return(-1);
+ }
+
+ written = 0;
+ *errorCodePtr = 0;
+ return(0);
+ }
+
+ /*
+ * We need to clear the SSL error stack now because we sometimes reach
+ * this function with leftover errors in the stack. If BIO_write
+ * returns -1 and intends EAGAIN, there is a leftover error, it will be
+ * misconstrued as an error, not EAGAIN.
+ *
+ * Alternatively, we may want to handle the <0 return codes from
+ * BIO_write specially (as advised in the RSA docs). TLS's lower level
+ * BIO functions play with the retry flags though, and this seems to
+ * work correctly. Similar fix in TlsInputProc. - hobbs
+ */
+ ERR_clear_error();
+ written = BIO_write(statePtr->bio, buf, toWrite);
+ dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written);
+
+ err = SSL_get_error(statePtr->ssl, written);
+ backingError = ERR_get_error();
+
+ switch (err) {
+ case SSL_ERROR_NONE:
+ if (written < 0) {
+ written = 0;
+ }
+ break;
+
+ case SSL_ERROR_WANT_WRITE:
+ dprintf("Got SSL_ERROR_WANT_WRITE, mapping it to EAGAIN");
+ *errorCodePtr = EAGAIN;
+ written = -1;
+ Tls_Error(statePtr, "SSL_ERROR_WANT_WRITE");
+ break;
+
+ case SSL_ERROR_WANT_READ:
+ dprintf(" write R BLOCK");
+ Tls_Error(statePtr, "SSL_ERROR_WANT_READ");
+ break;
+
+ case SSL_ERROR_WANT_X509_LOOKUP:
+ dprintf(" write X BLOCK");
+ Tls_Error(statePtr, "SSL_ERROR_WANT_X509_LOOKUP");
+ break;
+
+ case SSL_ERROR_ZERO_RETURN:
+ dprintf(" closed");
+ written = 0;
+ *errorCodePtr = 0;
+ Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert");
+ break;
+
+ case SSL_ERROR_SYSCALL:
+ /* Some non-recoverable, fatal I/O error occurred */
+
+ if (backingError == 0 && written == 0) {
+ dprintf("EOF reached")
+ *errorCodePtr = 0;
+ written = 0;
+ Tls_Error(statePtr, "EOF reached");
+
+ } else if (backingError == 0 && written == -1) {
+ dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ written = -1;
+ Tls_Error(statePtr, (char *) Tcl_ErrnoMsg(*errorCodePtr));
+
+ } else {
+ dprintf("I/O error occurred (backingError = %lu)", backingError);
+ *errorCodePtr = Tcl_GetErrno();
+ written = -1;
+ Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError));
+ }
+ break;
+
+ case SSL_ERROR_SSL:
+ /* A non-recoverable, fatal error in the SSL library occurred, usually a protocol error */
+ dprintf("SSL error, indicating that the connection has been aborted");
+ if (backingError != 0) {
+ Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError));
+ } else if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) {
+ Tls_Error(statePtr, (char *) X509_verify_cert_error_string(SSL_get_verify_result(statePtr->ssl)));
+ } else {
+ Tls_Error(statePtr, "Unknown SSL error");
+ }
+ *errorCodePtr = ECONNABORTED;
+ written = -1;
+ break;
+
+ default:
+ dprintf("unknown error: %d", err);
+ Tls_Error(statePtr, "Unknown error");
+ break;
+ }
+
+ dprintf("Output(%d) -> %d", toWrite, written);
+ return(written);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsSetOptionProc --
+ *
+ * Sets an option value for a SSL socket based channel, or a
+ * list of all options and their values.
+ *
+ * Results:
+ * TCL_OK if successful or TCL_ERROR if failed.
+ *
+ * Side effects:
+ * Updates channel option to new value.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+TlsSetOptionProc(ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For errors - can be NULL. */
+ const char *optionName, /* Name of the option to set the value for, or
+ * NULL to get all options and their values. */
+ const char *optionValue) /* Value for option. */
+{
+ State *statePtr = (State *) instanceData;
+
+ Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
+ Tcl_DriverSetOptionProc *setOptionProc;
+
+ setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
+ if (setOptionProc != NULL) {
+ return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue);
+ } else if (optionName == (char*) NULL) {
+ /*
+ * Request is query for all options, this is ok.
+ */
+ return TCL_OK;
+ }
+ /*
+ * Request for a specific option has to fail, we don't have any.
+ */
+ return Tcl_BadChannelOption(interp, optionName, "");
}
/*
*-------------------------------------------------------------------
*
* TlsGetOptionProc --
*
- * Computes an option value for a SSL socket based channel, or a
- * list of all options and their values.
+ * Gets an option value for a SSL socket based channel, or a
+ * list of all options and their values.
*
* 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.
+ * 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.
*
* Side effects:
- * None.
+ * None.
*
*-------------------------------------------------------------------
*/
static int
-TlsGetOptionProc(void *instanceData, /* Socket state. */
- Tcl_Interp *interp, /* For errors - can be NULL. */
- const char *optionName, /* Name of the option to
- * retrieve the value for, or
- * NULL to get all options and
- * their values. */
- Tcl_DString *dsPtr) /* Where to store the computed value
- * initialized by caller. */
+TlsGetOptionProc(ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For errors - can be NULL. */
+ const char *optionName, /* Name of the option to retrieve the value for, or
+ * NULL to get all options and their values. */
+ Tcl_DString *optionValue) /* Where to store the computed value initialized by caller. */
{
State *statePtr = (State *) instanceData;
- Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
- Tcl_DriverGetOptionProc *getOptionProc;
+ Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
+ Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
if (getOptionProc != NULL) {
- return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr);
+ return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue);
} else if (optionName == (char*) NULL) {
- /*
- * Request is query for all options, this is ok.
- */
- return TCL_OK;
+ /*
+ * Request is query for all options, this is ok.
+ */
+ return TCL_OK;
}
/*
* Request for a specific option has to fail, we don't have any.
*/
- return TCL_ERROR;
+ return Tcl_BadChannelOption(interp, optionName, "");
}
/*
*-------------------------------------------------------------------
*
* TlsWatchProc --
*
- * Initialize the notifier to watch Tcl_Files from this channel.
+ * Initialize the notifier to watch Tcl_Files from this channel.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Sets up the notifier so that a future event on the channel
- * will be seen by Tcl.
+ * Sets up the notifier so that a future event on the channel
+ * will be seen by Tcl.
*
*-------------------------------------------------------------------
*/
-
static void
-TlsWatchProc(void *instanceData, /* The socket state. */
- int mask) /* Events of interest; an OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+TlsWatchProc(ClientData instanceData, /* The socket state. */
+ int mask) /* Events of interest; an OR-ed combination of
+ * TCL_READABLE, TCL_WRITABLE and TCL_EXCEPTION. */
{
Tcl_Channel downChan;
State *statePtr = (State *) instanceData;
+ Tcl_DriverWatchProc *watchProc;
dprintf("TlsWatchProc(0x%x)", mask);
/* Pretend to be dead as long as the verify callback is running.
* Otherwise that callback could be invoked recursively. */
if (statePtr->flags & TLS_TCL_CALLBACK) {
- dprintf("Callback is on-going, doing nothing");
- return;
+ dprintf("Callback is on-going, doing nothing");
+ return;
}
dprintFlags(statePtr);
downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
- dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here");
-
- dprintf("Unregistering interest in the lower channel");
- (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), 0);
-
- statePtr->watchMask = 0;
-
- return;
- }
-
- statePtr->watchMask = mask;
-
- /* No channel handlers any more. We will be notified automatically
- * about events on the channel below via a call to our
- * 'TransformNotifyProc'. But we have to pass the interest down now.
- * We are allowed to add additional 'interest' to the mask if we want
- * to. But this transformation has no such interest. It just passes
- * the request down, unchanged.
- */
-
-
- dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan);
- (Tcl_GetChannelType(downChan))
- ->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
-
- /*
- * Management of the internal timer.
- */
-
- if (statePtr->timer != (Tcl_TimerToken) NULL) {
- dprintf("A timer was found, deleting it");
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = (Tcl_TimerToken) NULL;
- }
-
- if (mask & TCL_READABLE) {
- if (Tcl_InputBuffered(statePtr->self) > 0 || BIO_ctrl_pending(statePtr->bio) > 0) {
- /*
- * There is interest in readable events and we actually have
- * data waiting, so generate a timer to flush that.
- */
- dprintf("Creating a new timer since data appears to be waiting");
- statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, statePtr);
- }
- }
+ 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(downChan));
+ watchProc(Tcl_GetChannelInstanceData(downChan), 0);
+ statePtr->watchMask = 0;
+ return;
+ }
+
+ statePtr->watchMask = mask;
+
+ /* No channel handlers any more. We will be notified automatically
+ * about events on the channel below via a call to our
+ * 'TransformNotifyProc'. But we have to pass the interest down now.
+ * We are allowed to add additional 'interest' to the mask if we want
+ * to. But this transformation has no such interest. It just passes
+ * the request down, unchanged.
+ */
+ dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan);
+ watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(downChan));
+ watchProc(Tcl_GetChannelInstanceData(downChan), mask);
+
+
+ /*
+ * Management of the internal timer.
+ */
+ if (statePtr->timer != (Tcl_TimerToken) NULL) {
+ dprintf("A timer was found, deleting it");
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ statePtr->timer = (Tcl_TimerToken) NULL;
+ }
+
+ if ((mask & TCL_READABLE) &&
+ ((Tcl_InputBuffered(statePtr->self) > 0) || (BIO_ctrl_pending(statePtr->bio) > 0))) {
+ /*
+ * There is interest in readable events and we actually have
+ * data waiting, so generate a timer to flush that.
+ */
+ dprintf("Creating a new timer since data appears to be waiting");
+ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr);
+ }
}
/*
*-------------------------------------------------------------------
*
* TlsGetHandleProc --
*
- * Called from Tcl_GetChannelFile to retrieve o/s file handler
- * from the SSL socket based channel.
+ * Called from Tcl_GetChannelFile to retrieve o/s file handler
+ * from the SSL socket based channel.
*
* Results:
- * The appropriate Tcl_File or NULL if not present.
+ * The appropriate Tcl_File handle or NULL if none.
*
* Side effects:
- * None.
+ * None.
*
*-------------------------------------------------------------------
*/
-static int TlsGetHandleProc(void *instanceData, int direction, void **handlePtr) {
- State *statePtr = (State *) instanceData;
+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;
- return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr));
+ return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr));
}
/*
*-------------------------------------------------------------------
*
* TlsNotifyProc --
*
- * Handler called by Tcl to inform us of activity
- * on the underlying channel.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May process the incoming event by itself.
- *
- *-------------------------------------------------------------------
- */
-
-static int TlsNotifyProc(void *instanceData, int mask) {
- State *statePtr = (State *) instanceData;
- int errorCode;
-
- /*
- * An event occured in the underlying channel. This
- * transformation doesn't process such events thus returns the
- * incoming mask unchanged.
- */
- if (statePtr->timer != (Tcl_TimerToken) NULL) {
- /*
- * Delete an existing timer. It was not fired, yet we are
- * here, so the channel below generated such an event and we
- * don't have to. The renewal of the interest after the
- * execution of channel handlers will eventually cause us to
- * recreate the timer (in WatchProc).
- */
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = (Tcl_TimerToken) NULL;
- }
-
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- dprintf("Returning 0 due to callback");
- return 0;
- }
-
- dprintf("Calling Tls_WaitForConnect");
- errorCode = 0;
- if (Tls_WaitForConnect(statePtr, &errorCode, 1) < 0) {
- if (errorCode == EAGAIN) {
- dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0");
-
- return 0;
- }
-
- dprintf("Tls_WaitForConnect returned an error");
- }
-
- dprintf("Returning %i", mask);
-
- return(mask);
-}
-
-#if 0
-/*
- *------------------------------------------------------*
- *
- * TlsChannelHandler --
- *
- * ------------------------------------------------*
- * Handler called by Tcl as a result of
- * Tcl_CreateChannelHandler - to inform us of activity
- * on the underlying channel.
- * ------------------------------------------------*
- *
- * Sideeffects:
- * May generate subsequent calls to
- * Tcl_NotifyChannel.
- *
- * Result:
- * None.
- *
- *------------------------------------------------------*
- */
-
-static void
-TlsChannelHandler (clientData, mask)
- void * clientData;
- int mask;
-{
- State *statePtr = (State *) clientData;
-
- dprintf("HANDLER(0x%x)", mask);
- Tcl_Preserve(statePtr);
-
- if (mask & TCL_READABLE) {
- BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ);
- } else {
- BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ);
- }
-
- if (mask & TCL_WRITABLE) {
- BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
- } else {
- BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
- }
-
- mask = 0;
- if (BIO_wpending(statePtr->bio)) {
- mask |= TCL_WRITABLE;
- }
- if (BIO_pending(statePtr->bio)) {
- mask |= TCL_READABLE;
- }
-
- /*
- * The following NotifyChannel calls seems to be important, but
- * we don't know why. It looks like if the mask is ever non-zero
- * that it will enter an infinite loop.
- *
- * Notify the upper channel of the current BIO state so the event
- * continues to propagate up the chain.
- *
- * stanton: It looks like this could result in an infinite loop if
- * the upper channel doesn't cause ChannelHandler to be removed
- * before Tcl_NotifyChannel calls channel handlers on the lower channel.
- */
-
- Tcl_NotifyChannel(statePtr->self, mask);
-
- if (statePtr->timer != (Tcl_TimerToken)NULL) {
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = (Tcl_TimerToken)NULL;
- }
- if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
- /*
- * Data is waiting, flush it out in short time
- */
- statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
- TlsChannelHandlerTimer, statePtr);
- }
- Tcl_Release(statePtr);
-}
-#endif
-
-/*
- *------------------------------------------------------*
- *
- * TlsChannelHandlerTimer --
- *
- * ------------------------------------------------*
- * Called by the notifier (-> timer) to flush out
- * information waiting in channel buffers.
- * ------------------------------------------------*
- *
- * Sideeffects:
- * As of 'TlsChannelHandler'.
- *
- * Result:
- * None.
- *
- *------------------------------------------------------*
- */
-
-static void TlsChannelHandlerTimer(void *clientData) {
- State *statePtr = (State *) clientData;
- int mask = 0;
-
- dprintf("Called");
-
- statePtr->timer = (Tcl_TimerToken) NULL;
-
- if (BIO_wpending(statePtr->bio)) {
- dprintf("[chan=%p] BIO writable", statePtr->self);
-
- mask |= TCL_WRITABLE;
- }
-
- if (BIO_pending(statePtr->bio)) {
- dprintf("[chan=%p] BIO readable", statePtr->self);
-
- mask |= TCL_READABLE;
- }
-
- dprintf("Notifying ourselves");
- Tcl_NotifyChannel(statePtr->self, mask);
-
- dprintf("Returning");
-
- return;
-}
-
-Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) {
- dprintf("Requested to get parent of channel %p", statePtr->self);
-
- if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) {
- dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL");
- return(NULL);
- }
-
- return(Tcl_GetStackedChannel(statePtr->self));
+ * Handler called by Tcl to inform us of activity
+ * on the underlying channel.
+ *
+ * Results:
+ * Type of event or 0 if failed
+ *
+ * Side effects:
+ * May process the incoming event by itself.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsNotifyProc(ClientData instanceData, /* Socket state. */
+ int mask) /* type of event that occurred:
+ * OR-ed combination of TCL_READABLE or TCL_WRITABLE */
+{
+ State *statePtr = (State *) instanceData;
+ int errorCode;
+
+ /*
+ * An event occurred in the underlying channel. This
+ * transformation doesn't process such events thus returns the
+ * incoming mask unchanged.
+ */
+ if (statePtr->timer != (Tcl_TimerToken) NULL) {
+ /*
+ * Delete an existing timer. It was not fired, yet we are
+ * here, so the channel below generated such an event and we
+ * don't have to. The renewal of the interest after the
+ * execution of channel handlers will eventually cause us to
+ * recreate the timer (in WatchProc).
+ */
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ statePtr->timer = (Tcl_TimerToken) NULL;
+ }
+
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ dprintf("Returning 0 due to callback");
+ return 0;
+ }
+
+ dprintf("Calling Tls_WaitForConnect");
+ errorCode = 0;
+ if (Tls_WaitForConnect(statePtr, &errorCode, 1) < 0) {
+ Tls_Error(statePtr, strerror(errorCode));
+ if (errorCode == EAGAIN) {
+ dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0");
+
+ return 0;
+ }
+
+ dprintf("Tls_WaitForConnect returned an error");
+ }
+
+ dprintf("Returning %i", mask);
+
+ return(mask);
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ * TlsChannelHandlerTimer --
+ *
+ * ------------------------------------------------*
+ * Called by the notifier (-> timer) to flush out
+ * information waiting in channel buffers.
+ * ------------------------------------------------*
+ *
+ * Side effects:
+ * As of 'TlsChannelHandler'.
+ *
+ * Result:
+ * None.
+ *
+ *------------------------------------------------------*
+ */
+static void TlsChannelHandlerTimer(ClientData clientData) {
+ State *statePtr = (State *) clientData;
+ int mask = 0;
+
+ dprintf("Called");
+
+ statePtr->timer = (Tcl_TimerToken) NULL;
+
+ if (BIO_wpending(statePtr->bio)) {
+ dprintf("[chan=%p] BIO writable", statePtr->self);
+
+ mask |= TCL_WRITABLE;
+ }
+
+ if (BIO_pending(statePtr->bio)) {
+ dprintf("[chan=%p] BIO readable", statePtr->self);
+
+ mask |= TCL_READABLE;
+ }
+
+ dprintf("Notifying ourselves");
+ Tcl_NotifyChannel(statePtr->self, mask);
+
+ dprintf("Returning");
+
+ return;
+}
+
+Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) {
+ dprintf("Requested to get parent of channel %p", statePtr->self);
+
+ if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) {
+ dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL");
+ return(NULL);
+ }
+ return(Tcl_GetStackedChannel(statePtr->self));
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_ChannelType --
+ *
+ * Return the correct TLS channel driver info
+ *
+ * Results:
+ * The correct channel driver for the current version of Tcl.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static const Tcl_ChannelType tlsChannelType = {
+ "tls", /* Type name */
+ TCL_CHANNEL_VERSION_5, /* v5 channel */
+ TlsCloseProc, /* Close proc */
+ TlsInputProc, /* Input proc */
+ TlsOutputProc, /* Output proc */
+ NULL, /* Seek proc */
+ TlsSetOptionProc, /* Set option proc */
+ TlsGetOptionProc, /* Get option proc */
+ TlsWatchProc, /* Initialize notifier */
+ TlsGetHandleProc, /* Get OS handles out of channel */
+ TlsClose2Proc, /* close2proc */
+ TlsBlockModeProc, /* Set blocking/nonblocking mode*/
+ NULL, /* Flush proc */
+ TlsNotifyProc, /* Handling of events bubbling up */
+ NULL, /* Wide seek proc */
+ NULL, /* Thread action */
+ NULL /* Truncate */
+};
+
+const Tcl_ChannelType *Tls_ChannelType(void) {
+ return &tlsChannelType;
}
Index: generic/tlsInt.h
==================================================================
--- generic/tlsInt.h
+++ generic/tlsInt.h
@@ -21,40 +21,41 @@
#include "tls.h"
#include <errno.h>
#include <string.h>
#include <stdint.h>
-#ifdef __WIN32__
+#ifdef _WIN32
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <wincrypt.h> /* OpenSSL needs this on Windows */
#endif
-#ifdef NO_PATENTS
-# define NO_IDEA
-# define NO_RC2
-# define NO_RC4
-# define NO_RC5
-# define NO_RSA
-# ifndef NO_SSL2
-# define NO_SSL2
-# endif
+/* Handle TCL 8.6 CONST changes */
+#ifndef CONST86
+# if TCL_MAJOR_VERSION > 8
+# define CONST86 const
+# else
+# define CONST86
+# endif
+#endif
+
+/*
+ * Backwards compatibility for size type change
+ */
+#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7
+ #ifndef Tcl_Size
+ typedef int Tcl_Size;
+ #endif
+
+ #define TCL_SIZE_MODIFIER ""
#endif
#include <openssl/ssl.h>
#include <openssl/err.h>
#include <openssl/rand.h>
#include <openssl/opensslv.h>
-/*
- * Determine if we should use the pre-OpenSSL 1.1.0 API
- */
-#undef TCLTLS_OPENSSL_PRE_1_1
-#if (defined(LIBRESSL_VERSION_NUMBER)) || OPENSSL_VERSION_NUMBER < 0x10100000L
-# define TCLTLS_OPENSSL_PRE_1_1_API 1
-#endif
-
#ifndef ECONNABORTED
#define ECONNABORTED 130 /* Software caused connection abort */
#endif
#ifndef ECONNRESET
#define ECONNRESET 131 /* Connection reset by peer */
@@ -61,138 +62,145 @@
#endif
#ifdef TCLEXT_TCLTLS_DEBUG
#include <ctype.h>
#define dprintf(...) { \
- char dprintfBuffer[8192], *dprintfBuffer_p; \
- dprintfBuffer_p = &dprintfBuffer[0]; \
- dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \
- dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \
- fprintf(stderr, "%s\n", dprintfBuffer); \
- }
+ char dprintfBuffer[8192], *dprintfBuffer_p; \
+ dprintfBuffer_p = &dprintfBuffer[0]; \
+ dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \
+ dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \
+ fprintf(stderr, "%s\n", dprintfBuffer); \
+}
#define dprintBuffer(bufferName, bufferLength) { \
- int dprintBufferIdx; \
- unsigned char dprintBufferChar; \
- fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \
- for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \
- dprintBufferChar = bufferName[dprintBufferIdx]; \
- if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \
- fprintf(stderr, "'%c' ", dprintBufferChar); \
- } else { \
- fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \
- }; \
- }; \
- fprintf(stderr, "}\n"); \
- }
+ int dprintBufferIdx; \
+ unsigned char dprintBufferChar; \
+ fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \
+ for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \
+ dprintBufferChar = bufferName[dprintBufferIdx]; \
+ if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \
+ fprintf(stderr, "'%c' ", dprintBufferChar); \
+ } else { \
+ fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \
+ }; \
+ }; \
+ fprintf(stderr, "}\n"); \
+}
#define dprintFlags(statePtr) { \
- char dprintfBuffer[8192], *dprintfBuffer_p; \
- dprintfBuffer_p = &dprintfBuffer[0]; \
- dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \
- if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \
- if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \
- if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \
- if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \
- if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \
- if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \
- if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \
- fprintf(stderr, "%s\n", dprintfBuffer); \
- }
+ char dprintfBuffer[8192], *dprintfBuffer_p; \
+ dprintfBuffer_p = &dprintfBuffer[0]; \
+ dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \
+ if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \
+ if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \
+ if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \
+ if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \
+ if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \
+ if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \
+ if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \
+ fprintf(stderr, "%s\n", dprintfBuffer); \
+}
#else
#define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); }
#define dprintBuffer(bufferName, bufferLength) /**/
#define dprintFlags(statePtr) /**/
#endif
-#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err))))
+#define GET_ERR_REASON() ERR_reason_error_string(ERR_get_error())
+
+/* Common list append macros */
+#define LAPPEND_BARRAY(interp, obj, text, value, size) {\
+ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewByteArrayObj(value, size)); \
+}
+#define LAPPEND_STR(interp, obj, text, value, size) {\
+ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(value, size)); \
+}
+#define LAPPEND_INT(interp, obj, text, value) {\
+ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(value)); \
+}
+#define LAPPEND_LONG(interp, obj, text, value) {\
+ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewLongObj(value)); \
+}
+#define LAPPEND_BOOL(interp, obj, text, value) {\
+ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewBooleanObj(value)); \
+}
+#define LAPPEND_OBJ(interp, obj, text, listObj) {\
+ if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
+ Tcl_ListObjAppendElement(interp, obj, listObj); \
+}
+
/*
* OpenSSL BIO Routines
*/
#define BIO_TYPE_TCL (19|0x0400)
/*
* Defines for State.flags
*/
-#define TLS_TCL_ASYNC (1<<0) /* non-blocking mode */
-#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_ASYNC (1<<0) /* non-blocking mode */
+#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 further I/O will result
- * in ECONNABORTED errors. */
-#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */
+#define TLS_TCL_HANDSHAKE_FAILED (1<<5) /* Set on handshake failures and once set, all
+ * further I/O will result in ECONNABORTED errors. */
+#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */
#define TLS_TCL_DELAY (5)
/*
- * This structure describes the per-instance state
- * of an ssl channel.
+ * This structure describes the per-instance state of an SSL channel.
*
* The SSL processing context is maintained here, in the ClientData
*/
typedef struct State {
- Tcl_Channel self; /* this socket channel */
+ Tcl_Channel self; /* this socket channel */
Tcl_TimerToken timer;
- int flags; /* see State.flags above */
- int watchMask; /* current WatchProc mask */
- int mode; /* current mode of parent channel */
-
- Tcl_Interp *interp; /* interpreter in which this resides */
- Tcl_Obj *callback; /* script called for tracing, verifying and errors */
- Tcl_Obj *password; /* script called for certificate password */
-
- int vflags; /* verify flags */
- SSL *ssl; /* Struct for SSL processing */
- SSL_CTX *ctx; /* SSL Context */
- BIO *bio; /* Struct for SSL processing */
- BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */
-
- const char *err;
+ int flags; /* see State.flags above */
+ int watchMask; /* current WatchProc mask */
+ int mode; /* current mode of parent channel */
+
+ Tcl_Interp *interp; /* interpreter in which this resides */
+ Tcl_Obj *callback; /* script called for tracing, info, and errors */
+ Tcl_Obj *password; /* script called for certificate password */
+ Tcl_Obj *vcmd; /* script called to verify or validate protocol config */
+
+ int vflags; /* verify flags */
+ SSL *ssl; /* Struct for SSL processing */
+ SSL_CTX *ctx; /* SSL Context */
+ BIO *bio; /* Struct for SSL processing */
+ BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */
+
+ unsigned char *protos; /* List of supported protocols in protocol format */
+ unsigned int protos_len; /* Length of protos */
+
+ char *err;
} State;
#ifdef USE_TCL_STUBS
#ifndef Tcl_StackChannel
#error "Unable to compile on this version of Tcl"
#endif /* Tcl_GetStackedChannel */
#endif /* USE_TCL_STUBS */
-#ifndef JOIN
-# define JOIN(a,b) JOIN1(a,b)
-# define JOIN1(a,b) a##b
-#endif
-
-#ifndef TCL_UNUSED
-# if defined(__cplusplus)
-# define TCL_UNUSED(T) T
-# elif defined(__GNUC__) && (__GNUC__ > 2)
-# define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused))
-# else
-# define TCL_UNUSED(T) T JOIN(dummy, __LINE__)
-# endif
-#endif
-
-#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) && !defined(Tcl_Size)
-# define Tcl_Size int
-#endif
-
/*
* Forward declarations
*/
const Tcl_ChannelType *Tls_ChannelType(void);
Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags);
Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert);
+Tcl_Obj *Tls_NewCAObj(Tcl_Interp *interp, const SSL *ssl, int peer);
void Tls_Error(State *statePtr, char *msg);
-#if TCL_MAJOR_VERSION > 8
-void Tls_Free(void *blockPtr);
-#else
void Tls_Free(char *blockPtr);
-#endif
void Tls_Clean(State *statePtr);
int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent);
BIO *BIO_new_tcl(State* statePtr, int flags);
#define PTR2INT(x) ((int) ((intptr_t) (x)))
#endif /* _TLSINT_H */
Index: generic/tlsX509.c
==================================================================
--- generic/tlsX509.c
+++ generic/tlsX509.c
@@ -1,70 +1,356 @@
/*
* Copyright (C) 1997-2000 Sensus Consulting Ltd.
* Matt Newman <matt@sensus.org>
- */
-#include "tlsInt.h"
-
-/*
- * Ensure these are not macros - known to be defined on Win32
- */
-#ifdef min
-#undef min
-#endif
-
-#ifdef max
-#undef max
-#endif
-
-static int min(int a, int b)
-{
- return (a < b) ? a : b;
-}
-
-static int max(int a, int b)
-{
- return (a > b) ? a : b;
-}
-
-/*
- * ASN1_UTCTIME_tostr --
- */
-static char *
-ASN1_UTCTIME_tostr(ASN1_UTCTIME *tm)
-{
- static char bp[128];
- char *v;
- int gmt=0;
- static char *mon[12]={
- "Jan","Feb","Mar","Apr","May","Jun",
- "Jul","Aug","Sep","Oct","Nov","Dec"};
- int i;
- int y=0,M=0,d=0,h=0,m=0,s=0;
-
- i=tm->length;
- v=(char *)tm->data;
-
- if (i < 10) goto err;
- if (v[i-1] == 'Z') gmt=1;
- for (i=0; i<10; i++)
- if ((v[i] > '9') || (v[i] < '0')) goto err;
- y= (v[0]-'0')*10+(v[1]-'0');
- if (y < 70) y+=100;
- M= (v[2]-'0')*10+(v[3]-'0');
- if ((M > 12) || (M < 1)) goto err;
- d= (v[4]-'0')*10+(v[5]-'0');
- h= (v[6]-'0')*10+(v[7]-'0');
- m= (v[8]-'0')*10+(v[9]-'0');
- if ( (v[10] >= '0') && (v[10] <= '9') &&
- (v[11] >= '0') && (v[11] <= '9'))
- s= (v[10]-'0')*10+(v[11]-'0');
-
- sprintf(bp,"%s %2d %02d:%02d:%02d %d%s",
- mon[M-1],d,h,m,s,y+1900,(gmt)?" GMT":"");
- return bp;
- err:
- return "Bad time value";
+ * Copyright (C) 2023 Brian O'Hagan
+ */
+#include <tcl.h>
+#include <stdio.h>
+#include <openssl/bio.h>
+#include <openssl/sha.h>
+#include <openssl/x509.h>
+#include <openssl/x509v3.h>
+#include <openssl/x509_vfy.h>
+#include <openssl/asn1.h>
+#include "tlsInt.h"
+
+/* Define maximum certificate size. Max PEM size 100kB and DER size is 24kB. */
+#define CERT_STR_SIZE 32768
+
+
+/*
+ * Binary string to hex string
+ */
+int String_to_Hex(unsigned char* input, int ilen, unsigned char *output, int olen) {
+ int count = 0;
+ unsigned char *iptr = input;
+ unsigned char *optr = &output[0];
+ const char *hex = "0123456789abcdef";
+
+ for (int i = 0; i < ilen && count < olen - 1; i++, count += 2) {
+ *optr++ = hex[(*iptr>>4)&0xF];
+ *optr++ = hex[(*iptr++)&0xF];
+ }
+ *optr = 0;
+ return count;
+}
+
+/*
+ * BIO to Buffer
+ */
+int BIO_to_Buffer(int result, BIO *bio, void *buffer, int size) {
+ int len = 0;
+ int pending = BIO_pending(bio);
+
+ if (result) {
+ len = BIO_read(bio, buffer, (pending < size) ? pending : size);
+ (void)BIO_flush(bio);
+ if (len < 0) {
+ len = 0;
+ }
+ }
+ return len;
+}
+
+/*
+ * Get X509 Certificate Extensions
+ */
+Tcl_Obj *Tls_x509Extensions(Tcl_Interp *interp, X509 *cert) {
+ const STACK_OF(X509_EXTENSION) *exts;
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ if ((exts = X509_get0_extensions(cert)) != NULL) {
+ for (int i=0; i < X509_get_ext_count(cert); i++) {
+ X509_EXTENSION *ex = sk_X509_EXTENSION_value(exts, i);
+ ASN1_OBJECT *obj = X509_EXTENSION_get_object(ex);
+ /* ASN1_OCTET_STRING *data = X509_EXTENSION_get_data(ex); */
+ int critical = X509_EXTENSION_get_critical(ex);
+ LAPPEND_BOOL(interp, listPtr, OBJ_nid2ln(OBJ_obj2nid(obj)), critical);
+ }
+ }
+ return listPtr;
+}
+
+/*
+ * Get Authority and Subject Key Identifiers
+ */
+Tcl_Obj *Tls_x509Identifier(const ASN1_OCTET_STRING *astring) {
+ Tcl_Obj *resultPtr = NULL;
+ int len = 0;
+ unsigned char buffer[1024];
+
+ if (astring != NULL) {
+ len = String_to_Hex((unsigned char *)ASN1_STRING_get0_data(astring),
+ ASN1_STRING_length(astring), buffer, 1024);
+ }
+ resultPtr = Tcl_NewStringObj((char *) &buffer[0], (Tcl_Size) len);
+ return resultPtr;
+}
+
+/*
+ * Get Key Usage
+ */
+Tcl_Obj *Tls_x509KeyUsage(Tcl_Interp *interp, X509 *cert, uint32_t xflags) {
+ uint32_t usage = X509_get_key_usage(cert);
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ if ((xflags & EXFLAG_KUSAGE) && usage < UINT32_MAX) {
+ if (usage & KU_DIGITAL_SIGNATURE) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Digital Signature", -1));
+ }
+ if (usage & KU_NON_REPUDIATION) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Non-Repudiation", -1));
+ }
+ if (usage & KU_KEY_ENCIPHERMENT) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Key Encipherment", -1));
+ }
+ if (usage & KU_DATA_ENCIPHERMENT) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Data Encipherment", -1));
+ }
+ if (usage & KU_KEY_AGREEMENT) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Key Agreement", -1));
+ }
+ if (usage & KU_KEY_CERT_SIGN) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Certificate Signing", -1));
+ }
+ if (usage & KU_CRL_SIGN) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("CRL Signing", -1));
+ }
+ if (usage & KU_ENCIPHER_ONLY) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Encipher Only", -1));
+ }
+ if (usage & KU_DECIPHER_ONLY) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Decipher Only", -1));
+ }
+ } else {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("unrestricted", -1));
+ }
+ return listPtr;
+}
+
+/*
+ * Get Certificate Purpose
+ */
+char *Tls_x509Purpose(X509 *cert) {
+ 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";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_NS_SSL_SERVER, 0) > 0) {
+ purpose = "MSS SSL Server";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_SMIME_SIGN, 0) > 0) {
+ purpose = "SMIME Signing";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_SMIME_ENCRYPT, 0) > 0) {
+ purpose = "SMIME Encryption";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_CRL_SIGN, 0) > 0) {
+ purpose = "CRL Signing";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_ANY, 0) > 0) {
+ purpose = "Any";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_OCSP_HELPER, 0) > 0) {
+ purpose = "OCSP Helper";
+ } else if (X509_check_purpose(cert, X509_PURPOSE_TIMESTAMP_SIGN, 0) > 0) {
+ purpose = "Timestamp Signing";
+ } else {
+ purpose = "";
+ }
+ return purpose;
+}
+
+/*
+ * For each purpose, get certificate applicability
+ */
+Tcl_Obj *Tls_x509Purposes(Tcl_Interp *interp, X509 *cert) {
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+ X509_PURPOSE *ptmp;
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ for (int i = 0; i < X509_PURPOSE_get_count(); i++) {
+ ptmp = X509_PURPOSE_get0(i);
+ Tcl_Obj *tmpPtr = Tcl_NewListObj(0, NULL);
+
+ for (int j = 0; j < 2; j++) {
+ int idret = X509_check_purpose(cert, X509_PURPOSE_get_id(ptmp), j);
+ Tcl_ListObjAppendElement(interp, tmpPtr, Tcl_NewStringObj(j ? "CA" : "nonCA", -1));
+ Tcl_ListObjAppendElement(interp, tmpPtr, Tcl_NewStringObj(idret == 1 ? "Yes" : "No", -1));
+ }
+ LAPPEND_OBJ(interp, listPtr, X509_PURPOSE_get0_name(ptmp), tmpPtr);
+ }
+ return listPtr;
+}
+
+/*
+ * Get Subject Alternate Names (SAN) and Issuer Alternate Names
+ */
+Tcl_Obj *Tls_x509Names(Tcl_Interp *interp, X509 *cert, int nid, BIO *bio) {
+ STACK_OF(GENERAL_NAME) *names;
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+ int len;
+ char buffer[1024];
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ if ((names = 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, listPtr, NULL, buffer, (Tcl_Size) len);
+ }
+ sk_GENERAL_NAME_pop_free(names, GENERAL_NAME_free);
+ }
+ return listPtr;
+}
+
+/*
+ * Get EXtended Key Usage
+ */
+Tcl_Obj *Tls_x509ExtKeyUsage(Tcl_Interp *interp, X509 *cert, uint32_t xflags) {
+ uint32_t usage = X509_get_key_usage(cert);
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ if ((xflags & EXFLAG_XKUSAGE) && usage < UINT32_MAX) {
+ usage = X509_get_extended_key_usage(cert);
+
+ if (usage & XKU_SSL_SERVER) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("TLS Web Server Authentication", -1));
+ }
+ if (usage & XKU_SSL_CLIENT) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("TLS Web Client Authentication", -1));
+ }
+ if (usage & XKU_SMIME) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("E-mail Protection", -1));
+ }
+ if (usage & XKU_CODE_SIGN) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Code Signing", -1));
+ }
+ if (usage & XKU_SGC) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("SGC", -1));
+ }
+ if (usage & XKU_OCSP_SIGN) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("OCSP Signing", -1));
+ }
+ if (usage & XKU_TIMESTAMP) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Time Stamping", -1));
+ }
+ if (usage & XKU_DVCS ) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("DVCS", -1));
+ }
+ if (usage & XKU_ANYEKU) {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("Any Extended Key Usage", -1));
+ }
+ } else {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("unrestricted", -1));
+ }
+ return listPtr;
+}
+
+/*
+ * Get CRL Distribution Points
+ */
+Tcl_Obj *Tls_x509CrlDp(Tcl_Interp *interp, X509 *cert) {
+ STACK_OF(DIST_POINT) *crl;
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ if ((crl = 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);
+ if (type == GEN_URI) {
+ LAPPEND_STR(interp, listPtr, (char *) NULL, (char *) ASN1_STRING_get0_data(uri), (Tcl_Size) ASN1_STRING_length(uri));
+ }
+ }
+ } else if (distpoint->type == 1) {
+ /* 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, listPtr, (char *) NULL, (char *) ASN1_STRING_data(d), (Tcl_Size) ASN1_STRING_length(d));
+ }
+ }
+ }
+ CRL_DIST_POINTS_free(crl);
+ }
+ return listPtr;
+}
+
+/*
+ * Get On-line Certificate Status Protocol (OSCP) URL
+ */
+Tcl_Obj *Tls_x509Oscp(Tcl_Interp *interp, X509 *cert) {
+ STACK_OF(OPENSSL_STRING) *ocsp;
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
+ if (listPtr == NULL) {
+ return NULL;
+ }
+
+ if ((ocsp = X509_get1_ocsp(cert)) != NULL) {
+ for (int i = 0; i < sk_OPENSSL_STRING_num(ocsp); i++) {
+ LAPPEND_STR(interp, listPtr, NULL, sk_OPENSSL_STRING_value(ocsp, i), -1);
+ }
+ X509_email_free(ocsp);
+ }
+ return listPtr;
+}
+
+/*
+ * Get Certificate Authority (CA) Issuers URL
+ */
+Tcl_Obj *Tls_x509CaIssuers(Tcl_Interp *interp, X509 *cert) {
+ STACK_OF(ACCESS_DESCRIPTION) *ads;
+ ACCESS_DESCRIPTION *ad;
+ Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+ unsigned char *buf;
+ int len;
+
+ if ((ads = 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);
+ if (OBJ_obj2nid(ad->method) == NID_ad_ca_issuers && ad->location) {
+ if (ad->location->type == GEN_URI) {
+ len = ASN1_STRING_to_UTF8(&buf, ad->location->d.uniformResourceIdentifier);
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj((char *) buf, (Tcl_Size) len));
+ OPENSSL_free(buf);
+ break;
+ }
+ }
+ }
+ /* sk_ACCESS_DESCRIPTION_pop_free(ads, ACCESS_DESCRIPTION_free); */
+ AUTHORITY_INFO_ACCESS_free(ads);
+ }
+ return listPtr;
}
/*
*------------------------------------------------------*
*
@@ -72,138 +358,256 @@
*
* ------------------------------------------------*
* Converts a X509 certificate into a Tcl_Obj
* ------------------------------------------------*
*
- * Sideeffects:
+ * Side effects:
* None
*
* Result:
* A Tcl List Object representing the provided
* X509 certificate.
*
*------------------------------------------------------*
*/
-#define CERT_STR_SIZE 16384
-
-Tcl_Obj*
-Tls_NewX509Obj( interp, cert)
- Tcl_Interp *interp;
- X509 *cert;
-{
- Tcl_Obj *certPtr = Tcl_NewListObj( 0, NULL);
- BIO *bio;
- int n;
- unsigned long flags;
- char subject[BUFSIZ];
- char issuer[BUFSIZ];
- char serial[BUFSIZ];
- char notBefore[BUFSIZ];
- char notAfter[BUFSIZ];
- char certStr[CERT_STR_SIZE], *certStr_p;
- int certStr_len, toRead;
-#ifndef NO_SSL_SHA
- int shai;
- char sha_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1];
- unsigned char sha_hash_binary[SHA_DIGEST_LENGTH];
- const char *shachars="0123456789ABCDEF";
-
- sha_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0';
-#endif
-
- certStr[0] = 0;
- if ((bio = BIO_new(BIO_s_mem())) == NULL) {
- subject[0] = 0;
- issuer[0] = 0;
- serial[0] = 0;
- } else {
- flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT;
- flags &= ~ASN1_STRFLGS_ESC_MSB;
-
- X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags);
- n = BIO_read(bio, subject, min(BIO_pending(bio), BUFSIZ - 1));
- n = max(n, 0);
- subject[n] = 0;
- (void)BIO_flush(bio);
-
- X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags);
- n = BIO_read(bio, issuer, min(BIO_pending(bio), BUFSIZ - 1));
- n = max(n, 0);
- issuer[n] = 0;
- (void)BIO_flush(bio);
-
- i2a_ASN1_INTEGER(bio, X509_get_serialNumber(cert));
- n = BIO_read(bio, serial, min(BIO_pending(bio), BUFSIZ - 1));
- n = max(n, 0);
- serial[n] = 0;
- (void)BIO_flush(bio);
-
- if (PEM_write_bio_X509(bio, cert)) {
- certStr_p = certStr;
- certStr_len = 0;
- while (1) {
- toRead = min(BIO_pending(bio), CERT_STR_SIZE - certStr_len - 1);
- toRead = min(toRead, BUFSIZ);
- if (toRead == 0) {
- break;
- }
- dprintf("Reading %i bytes from the certificate...", toRead);
- n = BIO_read(bio, certStr_p, toRead);
- if (n <= 0) {
- break;
- }
- certStr_len += n;
- certStr_p += n;
- }
- *certStr_p = '\0';
- (void)BIO_flush(bio);
- }
-
- BIO_free(bio);
- }
-
- strcpy( notBefore, ASN1_UTCTIME_tostr( X509_get_notBefore(cert) ));
- strcpy( notAfter, ASN1_UTCTIME_tostr( X509_get_notAfter(cert) ));
-
-#ifndef NO_SSL_SHA
- X509_digest(cert, EVP_sha1(), sha_hash_binary, NULL);
- for (shai = 0; shai < SHA_DIGEST_LENGTH; shai++) {
- sha_hash_ascii[shai * 2] = shachars[(sha_hash_binary[shai] & 0xF0) >> 4];
- sha_hash_ascii[shai * 2 + 1] = shachars[(sha_hash_binary[shai] & 0x0F)];
- }
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha_hash_ascii, SHA_DIGEST_LENGTH * 2) );
-
-#endif
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( "subject", -1) );
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( subject, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( "issuer", -1) );
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( issuer, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( "notBefore", -1) );
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( notBefore, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( "notAfter", -1) );
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( notAfter, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( "serial", -1) );
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( serial, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( "certificate", -1) );
- Tcl_ListObjAppendElement( interp, certPtr,
- Tcl_NewStringObj( certStr, -1) );
-
+Tcl_Obj*
+Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert) {
+ Tcl_Obj *certPtr = Tcl_NewListObj(0, NULL);
+ BIO *bio = BIO_new(BIO_s_mem());
+ int mdnid, pknid, bits, len;
+ unsigned int ulen;
+ uint32_t xflags;
+ char buffer[BUFSIZ];
+ unsigned char md[EVP_MAX_MD_SIZE];
+ unsigned long flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT;
+ flags &= ~ASN1_STRFLGS_ESC_MSB;
+
+ if (interp == NULL || cert == NULL || bio == NULL || certPtr == NULL) {
+ return NULL;
+ }
+
+ /* Signature algorithm and value - RFC 5280 section 4.1.1.2 and 4.1.1.3 */
+ /* signatureAlgorithm is the id of the cryptographic algorithm used by the
+ CA to sign this cert. signatureValue is the digital signature computed
+ upon the ASN.1 DER encoded tbsCertificate. */
+ {
+ const X509_ALGOR *sig_alg;
+ const ASN1_BIT_STRING *sig;
+ int sig_nid;
+
+ X509_get0_signature(&sig, &sig_alg, cert);
+ /* sig_nid = X509_get_signature_nid(cert) */
+ sig_nid = OBJ_obj2nid(sig_alg->algorithm);
+ LAPPEND_STR(interp, certPtr, "signatureAlgorithm", OBJ_nid2ln(sig_nid), -1);
+ len = (sig_nid != NID_undef) ? String_to_Hex(sig->data, sig->length, (unsigned char *) buffer, BUFSIZ) : 0;
+ LAPPEND_STR(interp, certPtr, "signatureValue", buffer, (Tcl_Size) len);
+ }
+
+ /* Version of the encoded certificate - RFC 5280 section 4.1.2.1 */
+ LAPPEND_LONG(interp, certPtr, "version", X509_get_version(cert)+1);
+
+ /* Unique number assigned by CA to certificate - RFC 5280 section 4.1.2.2 */
+ len = BIO_to_Buffer(i2a_ASN1_INTEGER(bio, X509_get0_serialNumber(cert)), bio, buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "serialNumber", buffer, (Tcl_Size) len);
+
+ /* Signature algorithm used by the CA to sign the certificate. Must match
+ signatureAlgorithm. RFC 5280 section 4.1.2.3 */
+ LAPPEND_STR(interp, certPtr, "signature", OBJ_nid2ln(X509_get_signature_nid(cert)), -1);
+
+ /* Issuer identifies the entity that signed and issued the cert. RFC 5280 section 4.1.2.4 */
+ len = BIO_to_Buffer(X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags), bio, buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "issuer", buffer, (Tcl_Size) len);
+
+ /* Certificate validity period is the interval the CA warrants that it will
+ maintain info on the status of the certificate. RFC 5280 section 4.1.2.5 */
+ /* Get Validity - Not Before */
+ len = BIO_to_Buffer(ASN1_TIME_print(bio, X509_get0_notBefore(cert)), bio, buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "notBefore", buffer, (Tcl_Size) len);
+
+ /* Get Validity - Not After */
+ len = BIO_to_Buffer(ASN1_TIME_print(bio, X509_get0_notAfter(cert)), bio, buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "notAfter", buffer, (Tcl_Size) len);
+
+ /* Subject identifies the entity associated with the public key stored in
+ the subject public key field. RFC 5280 section 4.1.2.6 */
+ len = BIO_to_Buffer(X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags), bio, buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "subject", buffer, (Tcl_Size) len);
+
+ /* SHA1 Digest (Fingerprint) of cert - DER representation */
+ if (X509_digest(cert, EVP_sha1(), md, &ulen)) {
+ len = String_to_Hex(md, len, (unsigned char *) buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "sha1_hash", buffer, (Tcl_Size) ulen);
+ }
+
+ /* SHA256 Digest (Fingerprint) of cert - DER representation */
+ if (X509_digest(cert, EVP_sha256(), md, &ulen)) {
+ len = String_to_Hex(md, len, (unsigned char *) buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "sha256_hash", buffer, (Tcl_Size) ulen);
+ }
+
+ /* Subject Public Key Info specifies the public key and identifies the
+ algorithm with which the key is used. RFC 5280 section 4.1.2.7 */
+ if (X509_get_signature_info(cert, &mdnid, &pknid, &bits, &xflags)) {
+ ASN1_BIT_STRING *key;
+ unsigned int n;
+
+ LAPPEND_STR(interp, certPtr, "signingDigest", OBJ_nid2ln(mdnid), -1);
+ LAPPEND_STR(interp, certPtr, "publicKeyAlgorithm", OBJ_nid2ln(pknid), -1);
+ LAPPEND_INT(interp, certPtr, "bits", bits); /* Effective security bits */
+
+ key = X509_get0_pubkey_bitstr(cert);
+ len = String_to_Hex(key->data, key->length, (unsigned char *) buffer, BUFSIZ);
+ LAPPEND_STR(interp, certPtr, "publicKey", buffer, (Tcl_Size) len);
+
+ len = 0;
+ if (X509_pubkey_digest(cert, EVP_get_digestbynid(pknid), md, &n)) {
+ len = String_to_Hex(md, (int) n, (unsigned char *) buffer, BUFSIZ);
+ }
+ LAPPEND_STR(interp, certPtr, "publicKeyHash", buffer, (Tcl_Size) len);
+
+ /* digest of the DER representation of the certificate */
+ len = 0;
+ if (X509_digest(cert, EVP_get_digestbynid(mdnid), md, &n)) {
+ len = String_to_Hex(md, (int) n, (unsigned char *) buffer, BUFSIZ);
+ }
+ LAPPEND_STR(interp, certPtr, "signatureHash", buffer, (Tcl_Size) len);
+ }
+
+ /* Certificate Purpose. Call before checking for extensions. */
+ LAPPEND_STR(interp, certPtr, "purpose", Tls_x509Purpose(cert), -1);
+ LAPPEND_OBJ(interp, certPtr, "certificatePurpose", Tls_x509Purposes(interp, cert));
+
+ /* Get extensions flags */
+ xflags = X509_get_extension_flags(cert);
+ LAPPEND_INT(interp, certPtr, "extFlags", xflags);
+
+ /* Check if cert was issued by CA cert issuer or self signed */
+ LAPPEND_BOOL(interp, certPtr, "selfIssued", xflags & EXFLAG_SI);
+ LAPPEND_BOOL(interp, certPtr, "selfSigned", xflags & EXFLAG_SS);
+ LAPPEND_BOOL(interp, certPtr, "isProxyCert", xflags & EXFLAG_PROXY);
+ LAPPEND_BOOL(interp, certPtr, "extInvalid", xflags & EXFLAG_INVALID);
+ LAPPEND_BOOL(interp, certPtr, "isCACert", X509_check_ca(cert));
+
+ /* The Unique Ids are used to handle the possibility of reuse of subject
+ and/or issuer names over time. RFC 5280 section 4.1.2.8 */
+ {
+ const ASN1_BIT_STRING *iuid, *suid;
+ X509_get0_uids(cert, &iuid, &suid);
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("issuerUniqueId", -1));
+ if (iuid != NULL) {
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewByteArrayObj((const unsigned char *)iuid->data, (Tcl_Size) iuid->length));
+ } else {
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("", -1));
+ }
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("subjectUniqueId", -1));
+ if (suid != NULL) {
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewByteArrayObj((const unsigned char *)suid->data, (Tcl_Size) suid->length));
+ } else {
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("", -1));
+ }
+ }
+
+ /* X509 v3 Extensions - RFC 5280 section 4.1.2.9 */
+ LAPPEND_INT(interp, certPtr, "extCount", X509_get_ext_count(cert));
+ LAPPEND_OBJ(interp, certPtr, "extensions", Tls_x509Extensions(interp, cert));
+
+ /* Authority Key Identifier (AKI) is the Subject Key Identifier (SKI) of
+ its signer (the CA). RFC 5280 section 4.2.1.1, NID_authority_key_identifier */
+ LAPPEND_OBJ(interp, certPtr, "authorityKeyIdentifier",
+ Tls_x509Identifier(X509_get0_authority_key_id(cert)));
+
+ /* Subject Key Identifier (SKI) is used to identify certificates that contain
+ a particular public key. RFC 5280 section 4.2.1.2, NID_subject_key_identifier */
+ LAPPEND_OBJ(interp, certPtr, "subjectKeyIdentifier",
+ Tls_x509Identifier(X509_get0_subject_key_id(cert)));
+
+ /* Key usage extension defines the purpose (e.g., encipherment, signature, certificate
+ signing) of the key in the certificate. RFC 5280 section 4.2.1.3, NID_key_usage */
+ LAPPEND_OBJ(interp, certPtr, "keyUsage", Tls_x509KeyUsage(interp, cert, xflags));
+
+ /* Certificate Policies - indicates the issuing CA considers its issuerDomainPolicy
+ equivalent to the subject CA's subjectDomainPolicy. RFC 5280 section 4.2.1.4, NID_certificate_policies */
+ if (xflags & EXFLAG_INVALID_POLICY) {
+ /* Reject cert */
+ }
+
+ /* Policy Mappings - RFC 5280 section 4.2.1.5, NID_policy_mappings */
+
+ /* Subject Alternative Name (SAN) contains additional URLs, DNS names, or IP
+ addresses bound to certificate. RFC 5280 section 4.2.1.6, NID_subject_alt_name */
+ LAPPEND_OBJ(interp, certPtr, "subjectAltName", Tls_x509Names(interp, cert, NID_subject_alt_name, bio));
+
+ /* Issuer Alternative Name is used to associate Internet style identities
+ with the certificate issuer. RFC 5280 section 4.2.1.7, NID_issuer_alt_name */
+ LAPPEND_OBJ(interp, certPtr, "issuerAltName", Tls_x509Names(interp, cert, NID_issuer_alt_name, bio));
+
+ /* Subject Directory Attributes provides identification attributes (e.g., nationality)
+ of the subject. RFC 5280 section 4.2.1.8 (subjectDirectoryAttributes) */
+
+ /* Basic Constraints identifies whether the subject of the cert is a CA and
+ the max depth of valid cert paths for this cert. RFC 5280 section 4.2.1.9, NID_basic_constraints */
+ if (!(xflags & EXFLAG_PROXY)) {
+ LAPPEND_LONG(interp, certPtr, "pathLen", X509_get_pathlen(cert));
+ } else {
+ LAPPEND_LONG(interp, certPtr, "pathLen", X509_get_proxy_pathlen(cert));
+ }
+ LAPPEND_BOOL(interp, certPtr, "basicConstraintsCA", xflags & EXFLAG_CA);
+
+ /* Name Constraints is only used in CA certs to indicate the name space for
+ all subject names in subsequent certificates in a certification path
+ MUST be located. RFC 5280 section 4.2.1.10, NID_name_constraints */
+
+ /* Policy Constraints is only used in CA certs to limit the length of a
+ cert chain for that CA. RFC 5280 section 4.2.1.11, NID_policy_constraints */
+
+ /* Extended Key Usage indicates the purposes the certified public key may be
+ used, beyond the basic purposes. RFC 5280 section 4.2.1.12, NID_ext_key_usage */
+ LAPPEND_OBJ(interp, certPtr, "extendedKeyUsage", Tls_x509ExtKeyUsage(interp, cert, xflags));
+
+ /* CRL Distribution Points identifies where CRL information can be obtained.
+ RFC 5280 section 4.2.1.13*/
+ LAPPEND_OBJ(interp, certPtr, "crlDistributionPoints", Tls_x509CrlDp(interp, cert));
+
+ /* Freshest CRL extension */
+ if (xflags & EXFLAG_FRESHEST) {
+ }
+
+ /* Authority Information Access indicates how to access info and services
+ for the certificate issuer. RFC 5280 section 4.2.2.1, NID_info_access */
+
+ /* Get On-line Certificate Status Protocol (OSCP) Responders URL */
+ LAPPEND_OBJ(interp, certPtr, "ocspResponders", Tls_x509Oscp(interp, cert));
+
+ /* Get Certificate Authority (CA) Issuers URL */
+ LAPPEND_OBJ(interp, certPtr, "caIssuers", Tls_x509CaIssuers(interp, cert));
+
+ /* Subject Information Access - RFC 5280 section 4.2.2.2, NID_sinfo_access */
+
+ /* Certificate Alias. If uses a PKCS#12 structure, alias will reflect the
+ friendlyName attribute (RFC 2985). */
+ {
+ len = 0;
+ unsigned char *string = X509_alias_get0(cert, &len);
+ LAPPEND_STR(interp, certPtr, "alias", (char *) string, (Tcl_Size) len);
+ string = X509_keyid_get0(cert, &len);
+ LAPPEND_STR(interp, certPtr, "keyId", (char *) string, (Tcl_Size) len);
+ }
+
+ /* Certificate and dump all data */
+ {
+ char certStr[CERT_STR_SIZE];
+
+ /* Get certificate */
+ len = BIO_to_Buffer(PEM_write_bio_X509(bio, cert), bio, certStr, CERT_STR_SIZE);
+ LAPPEND_STR(interp, certPtr, "certificate", certStr, (Tcl_Size) len);
+
+ /* Get all cert info */
+ len = BIO_to_Buffer(X509_print_ex(bio, cert, flags, 0), bio, certStr, CERT_STR_SIZE);
+ LAPPEND_STR(interp, certPtr, "all", certStr, (Tcl_Size) len);
+ }
+
+ BIO_free(bio);
return certPtr;
}
Index: library/tls.tcl
==================================================================
--- library/tls.tcl
+++ library/tls.tcl
@@ -30,30 +30,38 @@
variable socketOptionRules {
{0 -async sopts 0}
{* -myaddr sopts 1}
{0 -myport sopts 1}
{* -type sopts 1}
+ {* -alpn iopts 1}
{* -cadir iopts 1}
{* -cafile iopts 1}
{* -cert iopts 1}
{* -certfile iopts 1}
{* -cipher iopts 1}
+ {* -ciphersuites iopts 1}
{* -command iopts 1}
{* -dhparams iopts 1}
{* -key iopts 1}
{* -keyfile iopts 1}
{* -password iopts 1}
+ {* -post_handshake iopts 1}
{* -request iopts 1}
{* -require iopts 1}
+ {* -securitylevel iopts 1}
{* -autoservername discardOpts 1}
+ {* -server iopts 1}
{* -servername iopts 1}
+ {* -session_id iopts 1}
{* -ssl2 iopts 1}
{* -ssl3 iopts 1}
{* -tls1 iopts 1}
{* -tls1.1 iopts 1}
{* -tls1.2 iopts 1}
{* -tls1.3 iopts 1}
+ {* -validatecommand iopts 1}
+ {* -vcmd iopts 1}
}
# tls::socket and tls::init options as a humane readable string
variable socketOptionsNoServer
variable socketOptionsServer
@@ -142,11 +150,11 @@
# dlls must be copied out of the virtual filesystem to the disk
# where Windows will find them when resolving the dependency in
# the tls dll. We choose to make them siblings of the executable.
package require starkit
set dst [file nativename [file dirname $starkit::topdir]]
- foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] {
+ foreach sdll [glob -nocomplain -directory $dir -tails libssl32.dll libcrypto*.dll libssl*.dll libssp*.dll] {
catch {file delete -force $dst/$sdll}
catch {file copy -force $dir/$sdll $dst/$sdll}
}
}
set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
@@ -303,10 +311,11 @@
error $err $::errorInfo $::errorCode
} else {
log 2 "tls::_accept - called \"$callback\" succeeded"
}
}
+
#
# Sample callback for hooking: -
#
# error
# verify
@@ -316,16 +325,71 @@
variable debug
#log 2 [concat $option $args]
switch -- $option {
- "error" {
+ "error" {
foreach {chan msg} $args break
log 0 "TLS/$chan: error: $msg"
}
- "verify" {
+ "info" {
+ # poor man's lassign
+ foreach {chan major minor msg type} $args break
+
+ if {$msg != ""} {
+ append state ": $msg"
+ }
+ # For tracing
+ upvar #0 tls::$chan cb
+ set cb($major) $minor
+
+ log 2 "TLS/$chan: $major/$minor: $state"
+ }
+ "message" {
+ # poor man's lassign
+ foreach {chan direction version content_type msg} $args break
+
+ log 0 "TLS/$chan: info: $direction $msg"
+ }
+ "session" {
+ foreach {chan session_id ticket lifetime} $args break
+
+ log 0 "TLS/$chan: session: lifetime $lifetime"
+ }
+ default {
+ return -code error "bad option \"$option\":\
+ must be one of error, info, or session"
+ }
+ }
+}
+
+#
+# Sample callback when return value is needed
+#
+proc tls::validate_command {option args} {
+ variable debug
+
+ #log 2 [concat $option $args]
+
+ switch -- $option {
+ "alpn" {
+ foreach {chan protocol match} $args break
+
+ log 0 "TLS/$chan: alpn: $protocol $match"
+ }
+ "hello" {
+ foreach {chan servername} $args break
+
+ log 0 "TLS/$chan: hello: $servername"
+ }
+ "sni" {
+ foreach {chan servername} $args break
+
+ log 0 "TLS/$chan: sni: $servername"
+ }
+ "verify" {
# poor man's lassign
foreach {chan depth cert rc err} $args break
array set c $cert
@@ -338,28 +402,16 @@
return 1; # FORCE OK
} else {
return $rc
}
}
- "info" {
- # poor man's lassign
- foreach {chan major minor state msg} $args break
-
- if {$msg != ""} {
- append state ": $msg"
- }
- # For tracing
- upvar #0 tls::$chan cb
- set cb($major) $minor
-
- log 2 "TLS/$chan: $major/$minor: $state"
- }
default {
return -code error "bad option \"$option\":\
- must be one of error, info, or verify"
+ must be one of alpn, info, or verify"
}
}
+ return 1
}
proc tls::xhandshake {chan} {
upvar #0 tls::$chan cb
@@ -376,11 +428,11 @@
return 1
}
}
}
-proc tls::password {} {
+proc tls::password {rwflag size} {
log 0 "TLS/Password: did you forget to set your passwd!"
# Return the worlds best kept secret password.
return "secret"
}
ADDED tests/README.txt
Index: tests/README.txt
==================================================================
--- /dev/null
+++ tests/README.txt
@@ -0,0 +1,23 @@
+Create Test Cases
+
+1. Create the test case *.csv file. You can use multiple files. Generally it's a good idea to group like functions in the same file.
+
+2. Add test cases to *.csv files. Each test case is on a separate line. The column titles correspond to the tcltest tool options. Leave a column blank if not used.
+
+3. Define any common functions in a common.tcl or in *.csv file.
+
+4. To create the test cases script, execute make_test_files.tcl. This will use the *.csv files to create the *.test files.
+
+
+Execute Test Suite
+
+5. To run the test suite, execute the all.tcl file.
+
+
+Special Notes
+
+On systems that don't use a standard OpenSSL installation, the following environment variables can be used to set SSL cert info:
+
+SSL_CERT_FILE = Set to file with SSL CA certificates in OpenSSL compatible format. The usual file name is /path/to/cacert.pem.
+
+SSL_CERT_DIR = Path to directory with CA files.
Index: tests/all.tcl
==================================================================
--- tests/all.tcl
+++ tests/all.tcl
@@ -7,53 +7,47 @@
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: all.tcl,v 1.5 2000/08/15 18:45:01 hobbs Exp $
+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 normalize [pwd]]]
+set auto_path [linsert $auto_path 0 [file dirname $path] [file normalize [pwd]]]
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import ::tcltest::*
}
+
+# Get common functions
+if {[file exists [file join $path common.tcl]]} {
+ source [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}
-puts stdout "Tests running in interp: [info nameofexecutable]"
-puts stdout "Tests running in working dir: $::tcltest::testsDirectory"
-if {[llength $::tcltest::skip] > 0} {
- puts stdout "Skipping tests that match: $::tcltest::skip"
-}
-if {[llength $::tcltest::match] > 0} {
- puts stdout "Only running tests that match: $::tcltest::match"
-}
-
-if {[llength $::tcltest::skipFiles] > 0} {
- puts stdout "Skipping test files that match: $::tcltest::skipFiles"
-}
-if {[llength $::tcltest::matchFiles] > 0} {
- puts stdout "Only sourcing test files that match: $::tcltest::matchFiles"
-}
-
-set timeCmd {clock format [clock seconds]}
-puts stdout "Tests began at [eval $timeCmd]"
-
-# source each of the specified tests
-foreach file [lsort [::tcltest::getMatchingFiles]] {
- set tail [file tail $file]
- puts stdout $tail
- if {[catch {source $file} msg]} {
- puts stdout $msg
- }
-}
-
-# cleanup
-puts stdout "\nTests ended at [eval $timeCmd]"
-::tcltest::cleanupTests 1
-return
-
+#
+# 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-]} {
+ if {[::tcltest::runAllTests] == 1} {
+ set exitCode 1
+ }
+
+} else {
+ # Hook to determine if any of the tests failed. Then we can exit with the
+ # proper exit code: 0=all passed, 1=one or more failed
+ proc tcltest::cleanupTestsHook {} {
+ variable numTests
+ set exitCode [expr {$numTests(Total) == 0 || $numTests(Failed) > 0}]
+ }
+ ::tcltest::runAllTests
+}
+
+# Exit code: 0=all passed, 1=one or more failed
+exit $exitCode
ADDED tests/badssl.csv
Index: tests/badssl.csv
==================================================================
--- /dev/null
+++ tests/badssl.csv
@@ -0,0 +1,78 @@
+# Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes
+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,3des,,,badssl 3des.badssl.com,,,handshake failed: sslv3 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,cbc,,,badssl cbc.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,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,,,badssl dh512.badssl.com,,,handshake failed: dh key too small,,,1
+BadSSL,dh1024,old_api,,badssl dh1024.badssl.com,,,,,,
+BadSSL,dh1024,new_api,,badssl dh1024.badssl.com,,,handshake failed: dh key too small,,,1
+BadSSL,dh2048,,,badssl dh2048.badssl.com,,,,,,
+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,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,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,,,"handshake failed: certificate verify failed due to ""unable to get local issuer certificate""",,,1
+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,,,handshake failed: sslv3 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,,,handshake failed: sslv3 alert handshake failure,,,1
+BadSSL,rc4,,,badssl rc4.badssl.com,,,handshake failed: sslv3 alert handshake failure,,,1
+BadSSL,revoked,,,badssl revoked.badssl.com,,,"handshake failed: certificate verify failed due to ""certificate has expired""",,,1
+BadSSL,rsa2048,,,badssl rsa2048.badssl.com,,,,,,
+BadSSL,rsa4096,,,badssl rsa4096.badssl.com,,,,,,
+BadSSL,rsa8192,,,badssl rsa8192.badssl.com,,,,,,
+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,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,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,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,,,,,,
ADDED tests/badssl.test
Index: tests/badssl.test
==================================================================
--- /dev/null
+++ tests/badssl.test
@@ -0,0 +1,296 @@
+# Auto generated test cases for badssl.csv
+
+# Load Tcl Test package
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]
+
+package require tls
+
+# Constraints
+source [file join [file dirname [info script]] common.tcl]
+
+# Helper functions
+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 {
+ 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 {
+ badssl 10000-sans.badssl.com
+ } -result {handshake failed: excessive message size} -returnCodes {1}
+
+test BadSSL-1.3 {3des} -body {
+ badssl 3des.badssl.com
+ } -result {handshake failed: sslv3 alert handshake failure} -returnCodes {1}
+
+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 {
+ 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 {
+ 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 {
+ badssl dh-composite.badssl.com
+ }
+
+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 {
+ badssl dh-small-subgroup.badssl.com
+ }
+
+test BadSSL-1.12 {dh480} -constraints {old_api} -body {
+ badssl dh480.badssl.com
+ } -result {handshake failed: dh key too small} -returnCodes {1}
+
+test BadSSL-1.13 {dh480} -constraints {new_api} -body {
+ badssl dh480.badssl.com
+ } -result {handshake failed: modulus too small} -returnCodes {1}
+
+test BadSSL-1.14 {dh512} -body {
+ badssl dh512.badssl.com
+ } -result {handshake failed: dh key too small} -returnCodes {1}
+
+test BadSSL-1.15 {dh1024} -constraints {old_api} -body {
+ badssl dh1024.badssl.com
+ }
+
+test BadSSL-1.16 {dh1024} -constraints {new_api} -body {
+ badssl dh1024.badssl.com
+ } -result {handshake failed: dh key too small} -returnCodes {1}
+
+test BadSSL-1.17 {dh2048} -body {
+ badssl dh2048.badssl.com
+ }
+
+test BadSSL-1.18 {dsdtestprovider} -body {
+ badssl dsdtestprovider.badssl.com
+ } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1}
+
+test BadSSL-1.19 {ecc256} -body {
+ badssl ecc256.badssl.com
+ }
+
+test BadSSL-1.20 {ecc384} -body {
+ badssl ecc384.badssl.com
+ }
+
+test BadSSL-1.21 {edellroot} -body {
+ badssl edellroot.badssl.com
+ } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1}
+
+test BadSSL-1.22 {expired} -body {
+ badssl expired.badssl.com
+ } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1}
+
+test BadSSL-1.23 {extended-validation} -body {
+ badssl extended-validation.badssl.com
+ } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1}
+
+test BadSSL-1.24 {hsts} -body {
+ badssl hsts.badssl.com
+ }
+
+test BadSSL-1.25 {https-everywhere} -body {
+ badssl https-everywhere.badssl.com
+ }
+
+test BadSSL-1.26 {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.27 {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.28 {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.29 {longextendedsubdomainnamewithoutdashesinordertotestwordwrapping} -body {
+ badssl longextendedsubdomainnamewithoutdashesinordertotestwordwrapping.badssl.com
+ }
+
+test BadSSL-1.30 {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.31 {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.32 {no-sct} -body {
+ badssl no-sct.badssl.com
+ } -result {handshake failed: certificate verify failed due to "unable to get local issuer certificate"} -returnCodes {1}
+
+test BadSSL-1.33 {no-subject} -body {
+ badssl no-subject.badssl.com
+ } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1}
+
+test BadSSL-1.34 {null} -body {
+ badssl null.badssl.com
+ } -result {handshake failed: sslv3 alert handshake failure} -returnCodes {1}
+
+test BadSSL-1.35 {pinning-test} -body {
+ badssl pinning-test.badssl.com
+ }
+
+test BadSSL-1.36 {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.37 {preloaded-hsts} -body {
+ badssl preloaded-hsts.badssl.com
+ }
+
+test BadSSL-1.38 {rc4-md5} -body {
+ badssl rc4-md5.badssl.com
+ } -result {handshake failed: sslv3 alert handshake failure} -returnCodes {1}
+
+test BadSSL-1.39 {rc4} -body {
+ badssl rc4.badssl.com
+ } -result {handshake failed: sslv3 alert handshake failure} -returnCodes {1}
+
+test BadSSL-1.40 {revoked} -body {
+ badssl revoked.badssl.com
+ } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1}
+
+test BadSSL-1.41 {rsa2048} -body {
+ badssl rsa2048.badssl.com
+ }
+
+test BadSSL-1.42 {rsa4096} -body {
+ badssl rsa4096.badssl.com
+ }
+
+test BadSSL-1.43 {rsa8192} -body {
+ badssl rsa8192.badssl.com
+ }
+
+test BadSSL-1.44 {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.45 {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.46 {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.47 {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.48 {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.49 {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.50 {sha256} -body {
+ badssl sha256.badssl.com
+ }
+
+test BadSSL-1.51 {sha384} -body {
+ badssl sha384.badssl.com
+ } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1}
+
+test BadSSL-1.52 {sha512} -body {
+ badssl sha512.badssl.com
+ } -result {handshake failed: certificate verify failed due to "certificate has expired"} -returnCodes {1}
+
+test BadSSL-1.53 {static-rsa} -body {
+ badssl static-rsa.badssl.com
+ }
+
+test BadSSL-1.54 {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.55 {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.56 {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.57 {tls-v1-0:1010} -constraints {tls1 old_api} -body {
+ badssl tls-v1-0.badssl.com:1010
+ }
+
+test BadSSL-1.58 {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.59 {tls-v1-1:1011} -constraints {tls1.1 old_api} -body {
+ badssl tls-v1-1.badssl.com:1011
+ }
+
+test BadSSL-1.60 {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.61 {tls-v1-2:1012} -constraints {tls1.2} -body {
+ badssl tls-v1-2.badssl.com:1012
+ }
+
+test BadSSL-1.62 {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.63 {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.64 {upgrade} -body {
+ badssl upgrade.badssl.com
+ }
+
+test BadSSL-1.65 {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.66 {wrong.host} -constraints {old_api} -body {
+ badssl wrong.host.badssl.com
+ } -result {handshake failed: certificate verify failed due to "Hostname mismatch"} -returnCodes {1}
+
+test BadSSL-1.67 {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.68 {mozilla-modern} -body {
+ badssl mozilla-modern.badssl.com
+ }
+
+# Cleanup
+::tcltest::cleanupTests
+return
Index: tests/certs/ca.pem
==================================================================
--- tests/certs/ca.pem
+++ tests/certs/ca.pem
@@ -1,18 +1,22 @@
-----BEGIN CERTIFICATE-----
-MIIC2jCCAkOgAwIBAgIBADANBgkqhkiG9w0BAQQFADBYMQswCQYDVQQGEwJDQTEZ
-MBcGA1UECBMQQnJpdGlzaCBDb2x1bWJpYTESMBAGA1UEBxMJVmFuY291dmVyMRow
-GAYDVQQKExFTYW1wbGUgQ2VydHMgSW50bDAeFw0wMTA2MjEyMDI2MDRaFw0wMTA3
-MjEyMDI2MDRaMFgxCzAJBgNVBAYTAkNBMRkwFwYDVQQIExBCcml0aXNoIENvbHVt
-YmlhMRIwEAYDVQQHEwlWYW5jb3V2ZXIxGjAYBgNVBAoTEVNhbXBsZSBDZXJ0cyBJ
-bnRsMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDJeHe1yfuw7YCx6nZ4hcyl
-qe1JgOXSMqAzHwfHf/EdGtQUhsfsmgx9cZCKgtuZaoRKidl60MFeW2zq12ORuPUB
-w90mQh46KDPRNWm1jViI/xmKUY+so6F5P/c6aA0QYqcpDhM7GgMvaAbEuY70gQ0l
-uhxMv75mKMWC4RuzFyVVjwIDAQABo4GzMIGwMB0GA1UdDgQWBBTwwtcIvZ/wpImV
-VC/e3C/I9qXWVTCBgAYDVR0jBHkwd4AU8MLXCL2f8KSJlVQv3twvyPal1lWhXKRa
-MFgxCzAJBgNVBAYTAkNBMRkwFwYDVQQIExBCcml0aXNoIENvbHVtYmlhMRIwEAYD
-VQQHEwlWYW5jb3V2ZXIxGjAYBgNVBAoTEVNhbXBsZSBDZXJ0cyBJbnRsggEAMAwG
-A1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEEBQADgYEANprDWDEI9/UUkIL4kxvK8Woy
-akWYabFR3s2RnxwCMDi0d7eKh+8k+NHLjD1FnWt9VNmub3sd8+PdTMk41PlLfroG
-lCAd31HnYqoi498ivgpczwFj3BQSssmhld+aCFyE83KVIeMuP55fcp44vxQuEmcn
-EWnH66cMUxI1D3jcQWE=
+MIIDkTCCAnmgAwIBAgIUPg6RCIdGBkdlV10XlcfJxHJINeowDQYJKoZIhvcNAQEL
+BQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNVBAgMEEJyaXRpc2ggQ29sdW1iaWExEjAQ
+BgNVBAcMCVZhbmNvdXZlcjEaMBgGA1UECgwRU2FtcGxlIENlcnRzIEludGwwHhcN
+MTkwNzE4MTEyNjM0WhcNMTkwODE3MTEyNjM0WjBYMQswCQYDVQQGEwJDQTEZMBcG
+A1UECAwQQnJpdGlzaCBDb2x1bWJpYTESMBAGA1UEBwwJVmFuY291dmVyMRowGAYD
+VQQKDBFTYW1wbGUgQ2VydHMgSW50bDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC
+AQoCggEBALbsv1fBwo9o/xGkbZgnYTycPMcvttk0w4LPamni++zl6XkV+mGnGUEl
+5Zpn0Ynchsi/dhwhIEY+il9FWeWJ5Dgl4i/fHUTz3L+NZYafGTwCuSFmPCbGd/ho
+54tyZoax5CLQuBAnHGaYlIy9uJRL7eELqZICzxd3mD897DuQMX3fLLOAf0S94VDv
+KytPilY6I9hvwBoy8WH4tQfj3xTIpE/+VB6A6hnG2jTRzwKGlCMpXV8Fj4ZMrGTp
+XTufon4wO/G1YJ8WGDpnJth6y9N0B4yni4xv7MJO+6R69CvpK8udCTfd8exjceAt
+iqjY9bbErVh4FPTUYK2dmMhtuMQFYFECAwEAAaNTMFEwHQYDVR0OBBYEFB88aJVh
+lJEffxFp17pVhAJk/FFRMB8GA1UdIwQYMBaAFB88aJVhlJEffxFp17pVhAJk/FFR
+MA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQELBQADggEBAHbA2u+peV8gYB3c
+IDSN1+p3q1rJuW0sLeo1AEzOuu/HfrEDtIUBYI1OAY0FfJHnfDHPSy/FGWWydDzZ
+POQP8k/0HHT5CvzrDGUWjPQwkFyAvm/7VrJNfUg5RALWUhZIC3b5/gbVUEh/exzY
+eSElOjy3M32t1HQuOrGSHBsoal5D4xyeTdf55hMkxZJZfbhUt3/5ZmcPw1QryX/4
+cqp6QJTDZhVOLHPhVNGIckCy7+DTBo7BDqDt2cEUE7NQ6w2BQTSY5WHCFHcHgJJ6
+5jKQzsrIXe3K0cl23KxW+JC0vYBkckIalhQQ8hQLIQU6gF0wwFjE+H7yNixtH3bt
+BXkdO6c=
-----END CERTIFICATE-----
Index: tests/certs/client.key
==================================================================
--- tests/certs/client.key
+++ tests/certs/client.key
@@ -1,15 +1,27 @@
-----BEGIN RSA PRIVATE KEY-----
-MIICXgIBAAKBgQDByy+QiN7Gde+Pf6Wvjk4OZlXfbV68mzmLh/xrXIdGQL5KqRhi
-ydUZSUU87TZ/poZAFGA8kds0pmD1TWy4lGiJjoU5pxeIvl8d08Sqbh6Srxv1CKJm
-J7RIp4RvEpviOSaDUC0wkLMvAAaAu2ZpNEncsotV4eSaE/WhvCHamBjpSwIDAQAB
-AoGAP0q48h+Bgpep8dfiqP91BsbtbNcvhbG8jZGQIxBJLeyfOYsYZ8s7SdLgRhHD
-JtWgKvV8qMuKKBvetr7erznpGdHcDDw1wutL2PagET756BjAtxcZ0lEx129eXThH
-10+09QEbSlO9XRd1OvAdLCb80H97+jZXMVJ6eb/uMuVzUMECQQDzikOjJLK678fa
-haesVYBqmsFAihGIUK+7Ki1F8wS6/oKLHWKDdFYoI/3Zve0qdFGFdvZicFqLAjKl
-QOXxBGrpAkEAy7Vf1nmp8FAj2p1/0383EuIhjmMjQw2SHYMbTaCwbnYGJrPoeMwE
-dwaaWwfgmXFeoc6lzBRUeDVz2EE6EyzqEwJBAO9XR4eSrlAHDFsWlSVJVg3ujtO1
-nOthmIKRPbML1O9M5tB/DWzxLSb/0B9ohyb8740Bz7wIfQM2Ir3DXPeThtkCQQDH
-zSYrHznnUzNXgZOWxfgmtVVkayhy5CSkfauSAEIMlgaCf4NMuA7JD9jl4FwTJHdF
-DYLhIC+ZmBP/0Do+BJexAkEAjrF928xMKcsrVmr7zlEhl+4B75kDkXm8TDV42PQI
-WzmYuHZHwWZApU42VVlWEToIog2s0RVBOyHdiQsNwrL6Rw==
+MIIEpAIBAAKCAQEAxzY90F1CGLDXKlOiJsvZ9kZks/TBVTx9WDJBrZDG328/V03O
+4R7+kBRwF5rayitOHf0EWB6wMknpWMpz3JStJ9+Dl/K9ix9VUHmySySIh8eVxEO2
+/wjsou2QyBnzgeLFn2Y+m1Sb3NYeEbjayMbqTnZ1ySV6xVLFQLKGTUhH1pE78L8b
+bt0HAQ8ZS3mb9vBQ0seJrx0dOM+SP6DXDtgNolpCLKbnJkk/hknb0+5a2ctTf/JN
+gyl4MyuV7ZHv56ofTwPx6uldQxfSxxyS0SAkC1gKa498b8kbB6fB7SXL9JJ5Jz27
+vWnsROFxaquiVuVb0m014G5rGC23YozY8ELIMwIDAQABAoIBAEQ7WNq4Rn5Me7X8
+pUpiggovPCjDCUEXkdsWg5ZeQy+eW/ScKuLCifBxf58mJBAg2wW8drNz92eSF0GZ
+PivsJI7GqLzvoGo5VjBVLnM8VSMkgjCR/OjHdr2rXu6arOPs90FMdN8hEK2IDQ6G
+4TDpqLEtM9SsaKuTWQp62zM3MZvU0eUFP9oiZ6cp/D7CpSq76cQFpCQekR8a4f9Q
+eGkVzK/cwCauiB055CUB8Jzc5ZmmQal7mjVJ955d6kWWH4J1HP6ktNSiPLxaKA4W
+IvPwtTKOpy0XblZ7hVTTiVhuTZnmF+xqDMj0RsDPO5IAH7/2HZ03ku2yOEIMmg4i
+5eK5yFECgYEA7mbEpQHRJxQiFkx0hQKISMvy0afYN41s7qmtoY4nzFMSOI54YgcU
+w91ZsR+Ac4yLNCCJYxIyuRm4j15YvH3NK4etINJ+9pWPzbTRuKNOHgIySA4QyYhG
+azkO+6pwiy6IOhyPNBek//EaGgnfEFSGcSeEUUcQy/QwXW1QsUB3SnkCgYEA1erh
+yM8IOkcp2c41klZTYhzZQYxdWJBGw9AhlVo082K4qIOLSaZCO5nn5xya2veUl9qz
+0Ee+14wSP/zOX1lXkd9iLoqHmqo2u/nw+MnFdyqwtH0aBnG/bhP+2v6dar2JH/sp
+DDQh9y753vcat8H1eWSWKXrkDHZg3fsnjtiR/QsCgYEA09mjGXa5494yRFqAmMod
+TYNfLgvXSdZ1XMiPsSbgGuQfJv8D3yinvT3wPEPgI85azWG0dMNxK6e9qDmQ5T9t
+mSciJC6qAHn7pjLuwwLroiMVh45oQI7G9PVpaR6WkDgzemByqTnxuDcKmOT4wkw6
+hEc3f/qE5JkEeaFwuXKuDxECgYA9O+c13E22oPhR6L1dDmkABNIL+WofF+2pz8JN
+Rm0x3miNlFoi0vzSotPHTGDnnUdj0K74SBFREj+HIY7RrHlswE0SlYULuP3CAWIB
+VYC5A/dhMw5oGdd6Yy7o8UmObIL8LKErZSDz6PaN5J45S8RA45I4fX0aNCi2YlaI
+hWYE0QKBgQC69xGEbQUXLnR5XQ6i5RVHwIJUts9mk7IJjhEdktm73Ke2aUdovwQ+
+MZqZyJOjiuh+pllgLjitnKYCLaF6cDmlTXBg19rXYA65D7TZVj3+zu3+WaBCc4zq
+J7++4DvtVqyzGRAiCez+lMRm6tB7QvdYHCDAUxVUKdS7EqV1grkjxw==
-----END RSA PRIVATE KEY-----
Index: tests/certs/client.pem
==================================================================
--- tests/certs/client.pem
+++ tests/certs/client.pem
@@ -1,14 +1,19 @@
-----BEGIN CERTIFICATE-----
-MIICHzCCAYgCAQEwDQYJKoZIhvcNAQEEBQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNV
-BAgTEEJyaXRpc2ggQ29sdW1iaWExEjAQBgNVBAcTCVZhbmNvdXZlcjEaMBgGA1UE
-ChMRU2FtcGxlIENlcnRzIEludGwwHhcNMDEwNjIxMjAyOTU4WhcNMDEwNzIxMjAy
-OTU4WjBYMQswCQYDVQQGEwJDQTEZMBcGA1UECBMQQnJpdGlzaCBDb2x1bWJpYTES
-MBAGA1UEBxMJVmFuY291dmVyMRowGAYDVQQKExFTYW1wbGUgQ2VydHMgSW50bDCB
-nzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEAwcsvkIjexnXvj3+lr45ODmZV321e
-vJs5i4f8a1yHRkC+SqkYYsnVGUlFPO02f6aGQBRgPJHbNKZg9U1suJRoiY6FOacX
-iL5fHdPEqm4ekq8b9QiiZie0SKeEbxKb4jkmg1AtMJCzLwAGgLtmaTRJ3LKLVeHk
-mhP1obwh2pgY6UsCAwEAATANBgkqhkiG9w0BAQQFAAOBgQC9llXASadBxwkaEIZ7
-bmCYMWIB6+jjxa0YCY2jYgqCslny/bkLgIuxIcxf83ouFfXU52r/mq04jfuRfyRt
-zCT8C+Z9nhKHdHA0cVYJ+tNuZfssQ+cFHUfjDOsCEFTJ1OoooafnIHpPXub1FcYr
-SCLdcK0BwPbCcJUZrIHwu3Nu7g==
+MIIDJDCCAgwCAQQwDQYJKoZIhvcNAQELBQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNV
+BAgMEEJyaXRpc2ggQ29sdW1iaWExEjAQBgNVBAcMCVZhbmNvdXZlcjEaMBgGA1UE
+CgwRU2FtcGxlIENlcnRzIEludGwwHhcNMTkwNzE4MTEzMzQwWhcNMTkwODE3MTEz
+MzQwWjBYMQswCQYDVQQGEwJDQTEZMBcGA1UECAwQQnJpdGlzaCBDb2x1bWJpYTES
+MBAGA1UEBwwJVmFuY291dmVyMRowGAYDVQQKDBFTYW1wbGUgQ2VydHMgSW50bDCC
+ASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMc2PdBdQhiw1ypToibL2fZG
+ZLP0wVU8fVgyQa2Qxt9vP1dNzuEe/pAUcBea2sorTh39BFgesDJJ6VjKc9yUrSff
+g5fyvYsfVVB5skskiIfHlcRDtv8I7KLtkMgZ84HixZ9mPptUm9zWHhG42sjG6k52
+dcklesVSxUCyhk1IR9aRO/C/G27dBwEPGUt5m/bwUNLHia8dHTjPkj+g1w7YDaJa
+Qiym5yZJP4ZJ29PuWtnLU3/yTYMpeDMrle2R7+eqH08D8erpXUMX0sccktEgJAtY
+CmuPfG/JGwenwe0ly/SSeSc9u71p7EThcWqrolblW9JtNeBuaxgtt2KM2PBCyDMC
+AwEAATANBgkqhkiG9w0BAQsFAAOCAQEAgEps7DSYpNrN7VXdCw+AsOLikSyWZbOg
+kgeiYJWzemghHZJ62dj60aOmlxiYvPHONkds/d39wOuJkURcSBZL56VTqXIOuTXO
+pdBTIxJK9qroZphTt+5up4Z2YaBKb5mBdE/sldwJuxkw5pylLWbBtSaw0i9K40Q7
+7xY/+IDMZB6Duc+lDIWvaVk84U5wHxdzUJcgdBRcUCXlmDP672j3KsILSjx5737g
+yKil2uagRp/QaZgSv3vkwcwX/RiqPHoIBBiLscaSxPIwiOCJJO1CP3rlPfu/1rlH
+765wwtoimMIV503aUe0cMOO7z71zUjsDQkNgjTJtqQFC78ZZsayLFg==
-----END CERTIFICATE-----
Index: tests/certs/client.req
==================================================================
--- tests/certs/client.req
+++ tests/certs/client.req
@@ -1,11 +1,17 @@
-----BEGIN CERTIFICATE REQUEST-----
-MIIBmDCCAQECAQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNVBAgTEEJyaXRpc2ggQ29s
-dW1iaWExEjAQBgNVBAcTCVZhbmNvdXZlcjEaMBgGA1UEChMRU2FtcGxlIENlcnRz
-IEludGwwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAMHLL5CI3sZ1749/pa+O
-Tg5mVd9tXrybOYuH/Gtch0ZAvkqpGGLJ1RlJRTztNn+mhkAUYDyR2zSmYPVNbLiU
-aImOhTmnF4i+Xx3TxKpuHpKvG/UIomYntEinhG8Sm+I5JoNQLTCQsy8ABoC7Zmk0
-Sdyyi1Xh5JoT9aG8IdqYGOlLAgMBAAGgADANBgkqhkiG9w0BAQQFAAOBgQB8xq+d
-On5JqJBZcc9rW70jmSU7AlSZ48UQlmNmlUSj4YznWUCbDawEfHWv0Xpfho+bio+L
-hFuzt0WsotTW1sboFpG3csHyCpGmIxw5Lacv2x5+dDx0jRbyI426+CUn+ZPv5pv8
-iiVrlyiX2P3jifQjhv39Kgbs5cOr/Ic8KKz5rg==
+MIICnTCCAYUCAQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNVBAgMEEJyaXRpc2ggQ29s
+dW1iaWExEjAQBgNVBAcMCVZhbmNvdXZlcjEaMBgGA1UECgwRU2FtcGxlIENlcnRz
+IEludGwwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDHNj3QXUIYsNcq
+U6Imy9n2RmSz9MFVPH1YMkGtkMbfbz9XTc7hHv6QFHAXmtrKK04d/QRYHrAySelY
+ynPclK0n34OX8r2LH1VQebJLJIiHx5XEQ7b/COyi7ZDIGfOB4sWfZj6bVJvc1h4R
+uNrIxupOdnXJJXrFUsVAsoZNSEfWkTvwvxtu3QcBDxlLeZv28FDSx4mvHR04z5I/
+oNcO2A2iWkIspucmST+GSdvT7lrZy1N/8k2DKXgzK5Xtke/nqh9PA/Hq6V1DF9LH
+HJLRICQLWAprj3xvyRsHp8HtJcv0knknPbu9aexE4XFqq6JW5VvSbTXgbmsYLbdi
+jNjwQsgzAgMBAAGgADANBgkqhkiG9w0BAQsFAAOCAQEAXColfK+WzYiOxHzNnObF
+7dQwvSd8d97Q0vZLjV0H5ZTQVSwswb9WKWrXnX2VPTMlcxc3K9UJaHtiJZQX1Xhr
+N13z6D41ZcSGOk16NUkRy/zNtWn4RNiEMyLs1wiQrsPbgAn0KomwE+3FeOMhWKfi
+KFWhV8E8RNIhUM+Wejyrrw2f6Cv13RH6xiQ6ZEvcI8tq3RlM5GfaC0nn3pp/H+Ag
+QmCpmr+OUGpz1XtGBJ0GiEIntl4XnRSkzmB5dwAkUF5XdiRnA285i04WSbxoheQo
+PPav26T16pNlyjlkm+Rub1K79SV5Rk0EJLcopFDc3csjnlQQokpVm+oBw8oCCY4W
+xQ==
-----END CERTIFICATE REQUEST-----
Index: tests/certs/file.srl
==================================================================
--- tests/certs/file.srl
+++ tests/certs/file.srl
@@ -1,1 +1,1 @@
-02
+04
Index: tests/certs/privkey.pem
==================================================================
--- tests/certs/privkey.pem
+++ tests/certs/privkey.pem
@@ -1,18 +1,30 @@
------BEGIN RSA PRIVATE KEY-----
-Proc-Type: 4,ENCRYPTED
-DEK-Info: DES-EDE3-CBC,E5670F088D470CF8
-
-j53yMhP9QC8ZElMlyTENZ9rI6mq9hjQepTGBhku8W0JuGIDSQTbDieGNJ7myTLEo
-AckDGFndIPMJFxz3GU2OYZ40sZE7CL6lkc5JsgSvt2QEp5qK30l9Ij6NnXN/BfpQ
-ETliDPzDNWD0ILM43C2J/sNwgwu2SgAMj7BIn2adNuT5AN1nNXdxUg+tbGrEeH39
-eiHKTBRS+40t6KMxW1ftl85zl6WRSRM+3/URdNKUbVq0DQmpFpXT1XcKGxv4GVao
-X4jyj6pE5L610cIiT3vy0qK3B3UKsQNOE8Z7aTV9eKvGk7F4LVSQpFz+DDgv/nLb
-f2CLIR75MAv7FhcD/Ko+RzxfExPJB0BBsYZGarZcyd1R3rVl/rQAmd+xnZZfM5kV
-iRtl7ux8NldaFkZ7XU71ZkLIiivHPDEY6gKWXe3ANsXzVxSO3Zh9okT1P7jyMaNt
-Ucz7xD0T7+hnmIV4EU10h849o99F37eN3Ygjjy2xZmMsCfs/Qaem1mlJF0d87472
-7pZcOd+PgBpV2W2O9NTerd6+TPhyqGhgtucrQLID7B+eheLXaexAjgBYwHv9LbOo
-uCYPS9s4DBJgvoPhz+IZ/PEZVpY/w5QJ9DsBe0xOv+KWWt9KdcA0SWRYtJUznNSS
-YX3eVKZD0C3d5hgr0vSDUe/p6nsgvubHH/v/9EbruXql6PCVu0akO34n+91374pi
-85G3EWEuzUwxmKDCr228W5NB2bqFet9CgtHycnQ8cjM61AYpLZx4iTCxH8s6m+lY
-WRr1sFm38il8oTODZTQ6o/w91RELhyMd9MTJUZNEqqsgN4y0/r7Dww==
------END RSA PRIVATE KEY-----
+-----BEGIN ENCRYPTED PRIVATE KEY-----
+MIIFHDBOBgkqhkiG9w0BBQ0wQTApBgkqhkiG9w0BBQwwHAQIBWemhNjEyFQCAggA
+MAwGCCqGSIb3DQIJBQAwFAYIKoZIhvcNAwcECPdy2pJ53hrdBIIEyDerixPd/2vy
+eVgr1L6PQSzoyTUx7zrddw7w3Wg8N/TIjFqKGw98edDDPcNlKXbaalpnjL+aMTPa
+fqirXYffJKrMkUhbldKiJca4q25Y+if+K7+TExdltGxEF+OvadcQzjKEFFUZsMkq
+d89EOGecjICvuQblVX7YlSjZbaIHcK/l0lTQ2vWwi8ZQjLQhjoeO5bXl8b1m2s7H
+uWDi+M0jHPf5FN4Exmi0296L5bdUjESyGNIDgJEPDtb+U+k2fbryE0uusGCHXpWZ
+Y9UnKE9zDm0aUbD1L2RiztORW5GCRD+2QGQSNHJnWfIVMvOQLC6xSDFS80UfZ29i
+eoiPwmObliBM6TsG98qBeye4Bn9+vEJeOJwCEJJgRZy57oK3M3NwD681FgRLiIqx
+PDOkwg6yUxKjpn8JfAG3fVkaQ6mt2rAIzR9ClbK3Tk0i6b0B7iWW6VF6ihe5Eqlc
++nX37hXtw6RH6iCqnySoo64PoTtxvG5y9s3bxp1sVmRCJv85bUIp7xLbh/VoyqXf
+aHUYHy48M7lHdarl6tgDAMizJor7m9ZeZqAdOnkUMePehkJ9svIUaudRiO9FzVGP
+3aIGTXw4KfaLwFsT5O0DqsjFnhmrt0c8NOQyCbcEZZS2D7o2g548oEd/k7PH8u2M
+pPnQOI/S2Vb/K4EeUMDHsT6sV/6MFASwKaT4rXBXeyg7ryvqbBTzqAA50kAsUeG7
+/euNHuenZVTIfSYEaZzcBJ9M38ouhbvtdzVIqyJR3DzPXc/olPMudlg2l1ES7CUr
+muGTs1TrFT/Ucu07rPlYYFPUuk6nUC5llhTN3n9GfmHcnkeiE8PPfbX3y3I7z3Xh
+Fj4atR2VB26kxu77oKy8MM4ANd8uKvHAWEornuIZ/H3BbLOZsTnIR0+HhrXq9oT+
+FxxiUFzrKIZKt9dZHfLo27YjvnlP1uQKfaljvTt4OTTbAfV5Q8mWj8OBAyQc0WRv
+EHgHxcItGiwnGhoParqQFO6Cbtw+1G71t1b5Jd5tbEpbHMlugGP5jPWlM/KfJi8e
+mDi+30jTft5+1TEOmQK4hlpINfGOM1h07FPI8bjm3k44FW7FFJPZ8XlCT/JTJ87Y
+Fo92Z7uLW1O6oasj5ooiFYN0F9VyTYRhEcjGzt0aQso/9shNHHFn6T9ECzTsgEJq
+lAYpGESd6nlOkhDAwO2DWbrPYuJTnlj5j2tR6mV1u8mSEbMfB/p3AG4vmdrz0u4c
+hm7+H/pC0bVR+vwZslijZe77jMrWE5VQgDgcdCUS5V8hyRt0nt6AXr48jX4Rnpjh
+90Tb/wJH7AhIzG+Lr7jHoPNe4JWEN8zaBLT5N1l2YDO0+6lSVLMN1lk3q9M3ff4Q
+ExAxsEb7ueox2lPS40XdEBn2Umv4u/66nwiST2oLPp8+esYlu8xOa0ODHeuI+5ya
+E5byUlt+qYTo1iVCtYswGD/AIQCFjaDycBST2RSPfIPpY/cCPlPKniYuX9JokRfS
+3GgEOCJ6lynBSByn7roDDOc/SbE4dUQ6tXvwVx16KwaXOPOXhDJz+LtUTb9X4ShC
+54jI4In+cKe+gBOBXpeGiS6/bPjwCGdNXJ1YN/hyBJy+3L45JKZR5e4nzly7Ebpk
+/3WGW9dRZb210rEH5OllKA==
+-----END ENCRYPTED PRIVATE KEY-----
Index: tests/certs/server.key
==================================================================
--- tests/certs/server.key
+++ tests/certs/server.key
@@ -1,15 +1,27 @@
-----BEGIN RSA PRIVATE KEY-----
-MIICXAIBAAKBgQDCE6cHPOkPnOSpobuRDKTLcvjdmh1vAYmwOvXLcBkpN+PkN443
-2KURytg0rw4w7+HDS+KV13pAF5D5mSl/OOsfwQzi/dQKSVF0zlbz5L7rcBqIt2cG
-Xz7gsX8VRMycXH0XC3QAAZUW32zYeo0G28uCttAh6wt8YCKu99+TNhRIWQIDAQAB
-AoGAaMHQ48BGEO5gIwwwwW+wuDycBom8n4GV/7EjoaclfbE0aqhuNMjU+RCjuXRQ
-Vav2EcOxT65ax6Ow1nmNA6YGi1GUAcktgMmY+Cl72iVyEqz8kUwUS1TBj0EqysCW
-E57CJo6S9Htnhq9/qrJL1LvW2iH9mWobZnMbI6+jN8C/eTECQQDmrnS72ZzNJcLc
-yU9uahH5BaX2vUWpWdurjYend3L9sHII3hZznYTOBn5a4kCfF2CD1FYlL7LMuV4q
-qab8O5QNAkEA12CzTV3lpK8LOFX5CTT4gM5XAZvP0+YiThnRrGh15JRgZoV6Larn
-X+Tvk8qYGRZdjILnNaOCqp9j3z7Mpvt2fQJAR+Z6dg6m4/5wFTcd7fFbtr1+9EAc
-VWOvp3IOpTEDA3WapY7reo/PVBQMEDHTKIM1zwFA9IhAd7UTV8LXTGkZhQJAVUBU
-mLojDRWwdkMpiShreOiz7dIT6Ic+avWzVfAfQjQtGEebPfpZDU8cOb7Gh5+ftd+W
-z1eCgDEJIjPEZBBDLQJBAKnXJh9w47et8NZHsXjdqV/nWiZ2uzxijbEBCQTgLhcT
-e4oSQidcpEPRAB5jsCZAa5czv74kDIRqYCjFL8fAT+4=
+MIIEowIBAAKCAQEArSh1yY1FEue1zn9rlugTp+T1StUiRHWyVs9K5rIQjlBB38zv
+JUfACZcuCNa8yo8ZGVdgDfB/BnCpmRKNle3qDRiNJDMkP0eiZjDp+ZslaWLhDOLv
+97WFI6A9zHPKaz3WvjFTyEfTKGEy+kT6zQqi/AOgA74+7o6NK9ig9me5W/0i1eOW
+5SH0NrV+E3VQlSw1j9UfeqNvsRnwq0TiTWp1FeK/eoaJ07wR/OH9nfaBKinKdH/w
+DG8FOGNKSwYQt+6cjwf3sHg5iDAIe6CRFr75QGfU7XVKQ+vCzhYta5wOwEPBOq8S
+p1Ga9PvPyzrBXxM8vBEldnjk0wuhzIcfq4hgnQIDAQABAoIBAQCSLzZBkiJec3/p
+dWk/XW46r/Dl3EmxwittXlO9r1aKzvbOGhVLQ+e8MQWMML3xxB1MZ5eQLRkQNsz3
+jdI6YUDXDYMarJJNWgygeWsObwyGjBOy7WPpnDVqfj2t/ZNGNk61Aq/YxcperLB8
+2P9jWzd9yxGsF1DJ1U8ZVSmO3MKABTCllTlflFeGWlFo8rPHxh6JbY5IBj6CB0eb
+JKUsabMM3LykEefbzAh37ff647XA7292wfQ/+aZVBQnQ01xMuGnkxrFcyYpE3NJx
+6GBjdwrlEtZPb3TzXWdCoj5U0YT/4L3Up654MZ9Zhyw8ah8AT/m9XbDUdInwXG+/
+vfm5RmuBAoGBAOHMN4YmWWyFw5oFZ3oSmPQmbhONurjInJpga8k/HjGWBctsBKCD
+hXZ3MIaGPDLyNOMrsjBNcKmnY1+Jk8fxVgKnTiut3aSFRIVeHrlmGMj1w55csMBw
+V38i4L1vJUXU7ErOTPGzNXJQMc3KWqBMx3nnz335j4SHhpk5da+I351HAoGBAMRR
+wFrUCnWBCcRauzv1WhL/CahT3ZRfD5QF8TsIAq3aG7AXnrp2UkaEG9k3lMTLjQkp
+e2AWuvXHlQV0K77t4ocdP2UXNUZS10SQk2CX0HfS3pI0pWzLDf8dnfcPfZ/TVDc/
+8Gb82GKh8hsoTgNDPD30kt/2vgBT7gJfoH8hU3T7AoGAJsU+/2zUS/sH5AlrhB1v
+X/S9T+Q1HIdtxGAsAckxsQf2hMBOZxVONFIw5dhku8a06BDXrs2NO8Q/HudrlZhN
+0XTSylM3TImJg3Duy5zJQrBYX3fA7boce/sMJdrQxpXR4OJded7wnWlBs/k76Gxm
+j/sKuLHCP9pZdTPVjkdtRf8CgYA9PO8OphP5IV5FlLPQ+TC2uj1t93Mn5Bs85jmg
+W1hSmLWIUWXe7iet/WmecVsDpCcDU6A7kfuRzUbr45f9v8CouvPaecnRfOfPaHXA
+bLrHlcx9uNRdQl3EVZ2/wmJCZ65eaaB4z6hD5BZcaE8lb2SsQs1J9XLBMW0N6nxr
+C5833wKBgCZNl1qA8avepAOnqm/e2Pl54xsPjhzli2z8Ppe9S6rhe9QvYv2OsJkQ
+8Ja7zGTqRXJU4Rahcs6OYULommkgq5LpVCsszOTZDQH5WgICLvhBsxo2dEGyd3ov
+RTWdXnPYoWlj77ofnSdOsejF4kM4nHRD9Btq+VZ4NEAxe3FiUYbH
-----END RSA PRIVATE KEY-----
Index: tests/certs/server.pem
==================================================================
--- tests/certs/server.pem
+++ tests/certs/server.pem
@@ -1,14 +1,19 @@
-----BEGIN CERTIFICATE-----
-MIICHzCCAYgCAQAwDQYJKoZIhvcNAQEEBQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNV
-BAgTEEJyaXRpc2ggQ29sdW1iaWExEjAQBgNVBAcTCVZhbmNvdXZlcjEaMBgGA1UE
-ChMRU2FtcGxlIENlcnRzIEludGwwHhcNMDEwNjIxMjAyODUyWhcNMDEwNzIxMjAy
-ODUyWjBYMQswCQYDVQQGEwJDQTEZMBcGA1UECBMQQnJpdGlzaCBDb2x1bWJpYTES
-MBAGA1UEBxMJVmFuY291dmVyMRowGAYDVQQKExFTYW1wbGUgQ2VydHMgSW50bDCB
-nzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEAwhOnBzzpD5zkqaG7kQyky3L43Zod
-bwGJsDr1y3AZKTfj5DeON9ilEcrYNK8OMO/hw0vildd6QBeQ+ZkpfzjrH8EM4v3U
-CklRdM5W8+S+63AaiLdnBl8+4LF/FUTMnFx9Fwt0AAGVFt9s2HqNBtvLgrbQIesL
-fGAirvffkzYUSFkCAwEAATANBgkqhkiG9w0BAQQFAAOBgQBXJZfVMqZw9T4EgXQo
-nM0geAByeqyOCoR+4dPv4hipf/c1m8sZgG1SxrXVThey4i4UkZenKz+VlPGDX0++
-sJBKod+aa24wcR5IQBTDuxzwduwuKkbjzGG+zdBXjOgxdcLxw7ozNciSSALYVnez
-0uX7n/lAP92SlcEXhoUroMjeLQ==
+MIIDJDCCAgwCAQMwDQYJKoZIhvcNAQELBQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNV
+BAgMEEJyaXRpc2ggQ29sdW1iaWExEjAQBgNVBAcMCVZhbmNvdXZlcjEaMBgGA1UE
+CgwRU2FtcGxlIENlcnRzIEludGwwHhcNMTkwNzE4MTEzMTUzWhcNMTkwODE3MTEz
+MTUzWjBYMQswCQYDVQQGEwJDQTEZMBcGA1UECAwQQnJpdGlzaCBDb2x1bWJpYTES
+MBAGA1UEBwwJVmFuY291dmVyMRowGAYDVQQKDBFTYW1wbGUgQ2VydHMgSW50bDCC
+ASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAK0odcmNRRLntc5/a5boE6fk
+9UrVIkR1slbPSuayEI5QQd/M7yVHwAmXLgjWvMqPGRlXYA3wfwZwqZkSjZXt6g0Y
+jSQzJD9HomYw6fmbJWli4Qzi7/e1hSOgPcxzyms91r4xU8hH0yhhMvpE+s0KovwD
+oAO+Pu6OjSvYoPZnuVv9ItXjluUh9Da1fhN1UJUsNY/VH3qjb7EZ8KtE4k1qdRXi
+v3qGidO8Efzh/Z32gSopynR/8AxvBThjSksGELfunI8H97B4OYgwCHugkRa++UBn
+1O11SkPrws4WLWucDsBDwTqvEqdRmvT7z8s6wV8TPLwRJXZ45NMLocyHH6uIYJ0C
+AwEAATANBgkqhkiG9w0BAQsFAAOCAQEAj5gWwGYUjNK3v9fvIRu58bvg7r43SK7e
+4w1UEe7x8ZyquG7flomqdBoI5SwQo4C3VMu0Ds9c+psG6GUjnUB5Gki9GE34pkQS
+LOlfOyitvJYO+UaD4C+H0ZWyPAvHPfVwAk4CofKoIBp5eNkTIZASzgYXPbNSuO6K
+59cOM9/hPq4sJ0Pr+XEMYTYYozc5ewvjzRzCvPPkO2DT5kIoyslpRxnidG9+Ugxx
+Bo1WG05QQLN8HYH40fmUNou0omN1T8D7CCcTkWp1EU28vir6omwke0YTaEiFYqMH
+6CFN7/Z5sn0Vj3b3+f7w8Wdqw7DfsyL6DJD7vl8UjuYDHXDLLYVbUw==
-----END CERTIFICATE-----
Index: tests/certs/server.req
==================================================================
--- tests/certs/server.req
+++ tests/certs/server.req
@@ -1,11 +1,17 @@
-----BEGIN CERTIFICATE REQUEST-----
-MIIBmDCCAQECAQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNVBAgTEEJyaXRpc2ggQ29s
-dW1iaWExEjAQBgNVBAcTCVZhbmNvdXZlcjEaMBgGA1UEChMRU2FtcGxlIENlcnRz
-IEludGwwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAMITpwc86Q+c5Kmhu5EM
-pMty+N2aHW8BibA69ctwGSk34+Q3jjfYpRHK2DSvDjDv4cNL4pXXekAXkPmZKX84
-6x/BDOL91ApJUXTOVvPkvutwGoi3ZwZfPuCxfxVEzJxcfRcLdAABlRbfbNh6jQbb
-y4K20CHrC3xgIq7335M2FEhZAgMBAAGgADANBgkqhkiG9w0BAQQFAAOBgQBsiv9V
-OdF/lp3ovGfYj3DF3QyfH6p0fCuUADKgReLKOilMDPR77WE/kExxqRR9dTzlTY4n
-dEmvzfmV3Vbj8KKs3L9NoLo6vF/ZeSt+RyJQlJblzXuFqxMlpZJoYcFSZO1E0Jl8
-iHe6QMOI58MBe/waEPxvIyFo2L30wScEyy/Ynw==
+MIICnTCCAYUCAQAwWDELMAkGA1UEBhMCQ0ExGTAXBgNVBAgMEEJyaXRpc2ggQ29s
+dW1iaWExEjAQBgNVBAcMCVZhbmNvdXZlcjEaMBgGA1UECgwRU2FtcGxlIENlcnRz
+IEludGwwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCtKHXJjUUS57XO
+f2uW6BOn5PVK1SJEdbJWz0rmshCOUEHfzO8lR8AJly4I1rzKjxkZV2AN8H8GcKmZ
+Eo2V7eoNGI0kMyQ/R6JmMOn5myVpYuEM4u/3tYUjoD3Mc8prPda+MVPIR9MoYTL6
+RPrNCqL8A6ADvj7ujo0r2KD2Z7lb/SLV45blIfQ2tX4TdVCVLDWP1R96o2+xGfCr
+ROJNanUV4r96honTvBH84f2d9oEqKcp0f/AMbwU4Y0pLBhC37pyPB/eweDmIMAh7
+oJEWvvlAZ9TtdUpD68LOFi1rnA7AQ8E6rxKnUZr0+8/LOsFfEzy8ESV2eOTTC6HM
+hx+riGCdAgMBAAGgADANBgkqhkiG9w0BAQsFAAOCAQEAhSwccC2Oke5E6j/f7CjT
+SK4ExJfi/1Ze1OBkzaxLny0hSxMbK8iARSciOD7LLcJ1ZAq6aWwnxutHRLpGfO1t
+Nw+OG/AXeoonfLQJzLcU+w/GFOyfSjrSrNo8ePrflOzH6WKMuVH7tNw6PNWDggdG
+khDNq+VklBt6YxZ0X4FbPFuOKjOvjAfKyYY5ZfMSnOYtiZBb7aQEEoeBwcJkiL8D
+QQfwvtlKF8SWdeM61R8fibEw02XelXoIyyQZpL+7BIVPe84AMaJEUI5ijJ/dDOsP
+JFCpozCuNS8P49INvxH+2FdXk05V+/AcMmqJpNEJ916PecwjSTAlcmFmnq43+jM8
+rA==
-----END CERTIFICATE REQUEST-----
ADDED tests/ciphers.csv
Index: tests/ciphers.csv
==================================================================
--- /dev/null
+++ tests/ciphers.csv
@@ -0,0 +1,46 @@
+# Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes
+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,,,,,,,,,,
+command,# Constraints,,,,,,,,,
+command,set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3],,,,,,,,,
+command,foreach protocol $protocols {::tcltest::testConstraint $protocol 0},,,,,,,,,
+command,foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1},,,,,,,,,
+command,"::tcltest::testConstraint OpenSSL [string match ""OpenSSL*"" [::tls::version]]",,,,,,,,,
+,,,,,,,,,,
+command,# Helper functions,,,,,,,,,
+command,"proc lcompare {list1 list2} {set m """";set u """";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list ""missing"" $m ""unexpected"" $u]}",,,,,,,,,
+command,proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]},,,,,,,,,
+,,,,,,,,,,
+command,# Test protocols,,,,,,,,,
+Protocols,All,,,lcompare $protocols [::tls::protocols],,,missing {ssl2 ssl3} unexpected {},,,
+,,,,,,,,,,
+command,# Test ciphers,,,,,,,,,
+CiphersAll,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2] [::tls::ciphers ssl2]",,,missing {} unexpected {},,,
+CiphersAll,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3] [::tls::ciphers ssl3]",,,missing {} unexpected {},,,
+CiphersAll,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1] [::tls::ciphers tls1]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1] [::tls::ciphers tls1.1]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2] [::tls::ciphers tls1.2]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3] [::tls::ciphers tls1.3]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test cipher descriptions,,,,,,,,,
+CiphersDesc,SSL2,ssl2,,"lcompare [exec_get ""\r\n"" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,SSL3,ssl3,,"lcompare [exec_get ""\r\n"" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1,tls1,,"lcompare [exec_get ""\r\n"" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.1,tls1.1,,"lcompare [exec_get ""\r\n"" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.2,tls1.2,,"lcompare [exec_get ""\r\n"" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.3,tls1.3,,"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,,,,,,,,,
+CiphersSpecific,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.3,tls1.3,,"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,157 +1,121 @@
-# Commands covered: tls::ciphers
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-
-# All rights reserved.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import ::tcltest::*
-}
-
-# The build dir is added as the first element of $PATH
+# Auto generated test cases for ciphers_and_protocols.csv
+
+# Load Tcl Test package
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]
+
package require tls
-# One of these should == 1, depending on what type of ssl library
-# tls was compiled against. (RSA BSAFE SSL-C or OpenSSL).
-#
-set ::tcltest::testConstraints(rsabsafe) 0
-set ::tcltest::testConstraints(openssl) [string match "OpenSSL*" [tls::version]]
-
-set ::EXPECTEDCIPHERS(rsabsafe) {
- EDH-DSS-RC4-SHA
- EDH-RSA-DES-CBC3-SHA
- EDH-DSS-DES-CBC3-SHA
- DES-CBC3-SHA
- RC4-SHA
- RC4-MD5
- EDH-RSA-DES-CBC-SHA
- EDH-DSS-DES-CBC-SHA
- DES-CBC-SHA
- EXP-EDH-DSS-DES-56-SHA
- EXP-EDH-DSS-RC4-56-SHA
- EXP-DES-56-SHA
- EXP-RC4-56-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
-}
-
-set ::EXPECTEDCIPHERS(openssl) {
- AES128-SHA
- AES256-SHA
- DES-CBC-SHA
- DES-CBC3-SHA
- DHE-DSS-AES128-SHA
- DHE-DSS-AES256-SHA
- DHE-DSS-RC4-SHA
- DHE-RSA-AES128-SHA
- DHE-RSA-AES256-SHA
- EDH-DSS-DES-CBC-SHA
- EDH-DSS-DES-CBC3-SHA
- EDH-RSA-DES-CBC-SHA
- EDH-RSA-DES-CBC3-SHA
- EXP-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
- EXP1024-DES-CBC-SHA
- EXP1024-DHE-DSS-DES-CBC-SHA
- EXP1024-DHE-DSS-RC4-SHA
- EXP1024-RC2-CBC-MD5
- EXP1024-RC4-MD5
- EXP1024-RC4-SHA
- IDEA-CBC-SHA
- RC4-MD5
- RC4-SHA
-}
-
-set ::EXPECTEDCIPHERS(openssl0.9.8) {
- DHE-RSA-AES256-SHA
- DHE-DSS-AES256-SHA
- AES256-SHA
- EDH-RSA-DES-CBC3-SHA
- EDH-DSS-DES-CBC3-SHA
- DES-CBC3-SHA
- DHE-RSA-AES128-SHA
- DHE-DSS-AES128-SHA
- AES128-SHA
- IDEA-CBC-SHA
- RC4-SHA
- RC4-MD5
- EDH-RSA-DES-CBC-SHA
- EDH-DSS-DES-CBC-SHA
- DES-CBC-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
-}
-
-set version ""
-if {[string match "OpenSSL*" [tls::version]]} {
- regexp {OpenSSL ([\d\.]+)} [tls::version] -> version
-}
-if {![info exists ::EXPECTEDCIPHERS(openssl$version)]} {
- set version ""
-}
-
-proc listcompare {wants haves} {
- array set want {}
- array set have {}
- foreach item $wants { set want($item) 1 }
- foreach item $haves { set have($item) 1 }
- foreach item [lsort -dictionary [array names have]] {
- if {[info exists want($item)]} {
- unset want($item) have($item)
- }
- }
- if {[array size want] || [array size have]} {
- return [list MISSING [array names want] UNEXPECTED [array names have]]
- }
-}
-
-test ciphers-1.1 {Tls::ciphers for ssl3} {rsabsafe} {
- # This will fail if you compiled against OpenSSL.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers ssl3]
-} {}
-
-test ciphers-1.2 {Tls::ciphers for tls1} {rsabsafe} {
- # This will fail if you compiled against OpenSSL.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers tls1]
-} {}
-
-test ciphers-1.3 {Tls::ciphers for ssl3} {openssl} {
- # This will fail if you compiled against RSA bsafe or with a
- # different set of defines than the default.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers ssl3]
-} {}
-
-# This version of the test is correct for OpenSSL only.
-# An equivalent test for the RSA BSAFE SSL-C is earlier in this file.
-
-test ciphers-1.4 {Tls::ciphers for tls1} {openssl} {
- # This will fail if you compiled against RSA bsafe or with a
- # different set of defines than the default.
- # Change the constraint setting in all.tcl
- listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers tls1]
-} {}
-
-
-# cleanup
+# 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)}
+
+# Constraints
+set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3]
+foreach protocol $protocols {::tcltest::testConstraint $protocol 0}
+foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1}
+::tcltest::testConstraint OpenSSL [string match "OpenSSL*" [::tls::version]]
+# Helper functions
+proc lcompare {list1 list2} {set m "";set u "";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list "missing" $m "unexpected" $u]}
+proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]}
+# Test protocols
+
+
+test Protocols-1.1 {All} -body {
+ lcompare $protocols [::tls::protocols]
+ } -result {missing {ssl2 ssl3} unexpected {}}
+# Test ciphers
+
+
+test CiphersAll-2.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get ":" ciphers -ssl2] [::tls::ciphers ssl2]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get ":" ciphers -ssl3] [::tls::ciphers ssl3]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get ":" ciphers -tls1] [::tls::ciphers tls1]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get ":" ciphers -tls1_1] [::tls::ciphers tls1.1]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get ":" ciphers -tls1_2] [::tls::ciphers tls1.2]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get ":" ciphers -tls1_3] [::tls::ciphers tls1.3]
+ } -result {missing {} unexpected {}}
+# Test cipher descriptions
+
+
+test CiphersDesc-3.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get "\r\n" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-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 CiphersDesc-3.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.6 {TLS1.3} -constraints {tls1.3} -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
+
+
+test CiphersSpecific-4.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get ":" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get ":" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get ":" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get ":" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get ":" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get ":" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]
+ } -result {missing {} unexpected {}}
+# Test version
+
+
+test Version-5.1 {All} -body {
+ ::tls::version
+ } -match {glob} -result {*}
+
+test Version-5.2 {OpenSSL} -constraints {OpenSSL} -body {
+ ::tls::version
+ } -match {glob} -result {OpenSSL*}
+
+# Cleanup
::tcltest::cleanupTests
return
ADDED tests/common.tcl
Index: tests/common.tcl
==================================================================
--- /dev/null
+++ tests/common.tcl
@@ -0,0 +1,28 @@
+
+# Common Constraints
+package require tls
+
+# Supported protocols
+set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3]
+foreach protocol $protocols {
+ ::tcltest::testConstraint $protocol 0
+ ::tcltest::testConstraint !$protocol 1
+}
+
+foreach protocol [::tls::protocols] {
+ ::tcltest::testConstraint $protocol 1
+ ::tcltest::testConstraint !$protocol 0
+}
+
+# OpenSSL version
+::tcltest::testConstraint OpenSSL [string match "OpenSSL*" [::tls::version]]
+
+# Legacy OpenSSL v1.1.1 vs new v3.x
+scan [lindex [split [::tls::version]] 1] %f version
+::tcltest::testConstraint new_api [expr {$version >= 3.0}]
+::tcltest::testConstraint old_api [expr {$version < 3.0}]
+
+# Load legacy provider
+if {$version >= 3.0} {
+ tls::provider legacy
+}
Index: tests/keytest1.tcl
==================================================================
--- tests/keytest1.tcl
+++ tests/keytest1.tcl
@@ -1,24 +1,25 @@
-#!/bin/sh
-# The next line is executed by /bin/sh, but not tcl \
-exec tclsh "$0" ${1+"$@"}
+#!/usr/bin/env tclsh
set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]]
package require tls
proc creadable {s} {
puts "LINE=[gets $s]"
after 2000
+ file delete -force $::keyfile
+ file delete -force $::certfile
exit
}
proc myserv {s args} {
fileevent $s readable [list creadable $s]
}
-close [file tempfile keyfile]
-close [file tempfile certfile]
+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
puts "Now run keytest2.tcl"
ADDED tests/make_test_files.tcl
Index: tests/make_test_files.tcl
==================================================================
--- /dev/null
+++ tests/make_test_files.tcl
@@ -0,0 +1,123 @@
+#
+# Name: Make Test Files From CSV Files
+# Version: 0.2
+# Date: August 6, 2022
+# Author: Brian O'Hagan
+# Email: brian199@comcast.net
+# Legal Notice: (c) Copyright 2020 by Brian O'Hagan
+# Released under the Apache v2.0 license. I would appreciate a copy of any modifications
+# made to this package for possible incorporation in a future release.
+#
+
+#
+# Convert test case file into test files
+#
+proc process_config_file {filename} {
+ set prev ""
+ set test 0
+
+ # Open file with test case indo
+ set in [open $filename r]
+ array set cases [list]
+
+ # Open output test file
+ set out [open [format %s.test [file rootname $filename]] w]
+ array set cases [list]
+
+ # Add setup commands to test file
+ 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 ""
+
+ # 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
+
+ # Split comma separated fields with quotes
+ set list [list]
+ while {[string length $data] > 0} {
+ if {[string index $data 0] eq "\""} {
+ # Quoted
+ set end [string first "\"," $data]
+ if {$end == -1} {set end [expr {[string length $data]+1}]}
+ lappend list [string map [list {""} \"] [string range $data 1 [incr end -1]]]
+ set data [string range $data [incr end 3] end]
+
+ } else {
+ # Not quoted, so no embedded NL, quotes, or commas
+ set index [string first "," $data]
+ if {$index == -1} {set index [expr {[string length $data]+1}]}
+ lappend list [string range $data 0 [incr index -1]]
+ set data [string range $data [incr index 2] end]
+ }
+ }
+
+ # Get command or test case
+ foreach {group name constraints setup body cleanup match result output errorOutput returnCodes} $list {
+ if {$group eq "command"} {
+ # Pass-through command
+ puts $out $name
+
+ } elseif {$group ne "" && $body ne ""} {
+ set group [string map [list " " "_"] $group]
+ if {$group ne $prev} {
+ incr test
+ set prev $group
+ puts $out ""
+ }
+
+ # Test case
+ set buffer [format "\ntest %s-%d.%d {%s}" $group $test [incr cases($group)] $name]
+ 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"
+ foreach line [split $cmd ";"] {
+ append buffer \t [string trim $line] \n
+ }
+ append buffer " \}"
+ } elseif {$opt in [list -output -errorOutput]} {
+ append buffer " " $opt " {" $cmd \n "}"
+ } elseif {$opt in [list -result]} {
+ if {[string index $cmd 0] in [list \[ \" \{]} {
+ append buffer " " $opt " " $cmd
+ } elseif {[string match {*[\\$]*} $cmd]} {
+ append buffer " " $opt " \"" [string map [list \\\\\" \\\"] [string map [list \" \\\" ] $cmd]] "\""
+ } else {
+ append buffer " " $opt " {" $cmd "}"
+ }
+ } else {
+ append buffer " " $opt " {" $cmd "}"
+ }
+ }
+ }
+ puts $out $buffer
+
+ } else {
+ # Empty line
+ }
+ break
+ }
+ }
+
+ # Output clean-up commands
+ puts $out "\n# Cleanup\n::tcltest::cleanupTests\nreturn"
+ close $out
+ close $in
+}
+
+#
+# Call script
+#
+foreach file [glob *.csv] {
+ process_config_file $file
+}
+exit
Index: tests/simpleClient.tcl
==================================================================
--- tests/simpleClient.tcl
+++ tests/simpleClient.tcl
@@ -1,8 +1,6 @@
-#!/bin/sh
-# The next line is executed by /bin/sh, but not tcl \
-exec tclsh8.3 "$0" ${1+"$@"}
+#!/usr/bin/env tclsh
package require tls
set dir [file join [file dirname [info script]] ../tests/certs]
set OPTS(-cafile) [file join $dir ca.pem]
Index: tests/simpleServer.tcl
==================================================================
--- tests/simpleServer.tcl
+++ tests/simpleServer.tcl
@@ -1,8 +1,6 @@
-#!/bin/sh
-# The next line is executed by /bin/sh, but not tcl \
-exec tclsh8.3 "$0" ${1+"$@"}
+#!/usr/bin/env tclsh
package require tls
set dir [file join [file dirname [info script]] ../tests/certs]
set OPTS(-cafile) [file join $dir ca.pem]
Index: tests/tlsIO.test
==================================================================
--- tests/tlsIO.test
+++ tests/tlsIO.test
@@ -166,11 +166,11 @@
set remoteServerIP 127.0.0.1
set remoteFile [file join [pwd] remote.tcl]
if {[catch {set remoteProcChan \
[open "|[list $::tcltest::tcltest $remoteFile \
-serverIsSilent -port $remoteServerPort \
- -address $remoteServerIP] 2> /dev/null" w+]} msg] == 0} {
+ -address $remoteServerIP]" w+]} msg] == 0} {
after 1000
if {[catch {set commandSocket [tls::socket -cafile $caCert \
-certfile $clientCert -keyfile $clientKey \
$remoteServerIP $remoteServerPort]} msg] == 0} {
fconfigure $commandSocket -translation crlf -buffering line
@@ -320,11 +320,11 @@
after cancel $timer
close $f
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ 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
} else {
@@ -362,11 +362,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
global port
if {[catch {tls::socket -myport $port \
-certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8829} sock]} {
@@ -402,11 +402,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket -myaddr 127.0.0.1 \
-certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8830} sock]} {
set x $sock
@@ -426,11 +426,11 @@
puts $f [list set auto_path $auto_path]
puts $f {
package require tls
set timer [after 2000 "set x done"]
}
- puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]"
+ puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr localhost 8831 \]"
puts $f {
proc accept {sock addr port} {
global x
puts "[gets $sock]"
close $sock
@@ -440,14 +440,14 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
- -keyfile $clientKey [info hostname] 8831} sock]} {
+ -keyfile $clientKey localhost 8831} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
lappend x [gets $f]
@@ -477,11 +477,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ 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 8832} sock]} {
set x $sock
} else {
@@ -533,11 +533,11 @@
after cancel $timer
close $f
puts done
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8834]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
@@ -580,11 +580,11 @@
after cancel $timer
close $f
puts "done $i"
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8835]
fconfigure $s -buffering line
catch {
@@ -633,11 +633,11 @@
gets $s
close $s
set done 1
}
set cs [tls::socket -certfile $clientCert -cafile $caCert \
- -keyfile $clientKey [info hostname] 8830]
+ -keyfile $clientKey localhost 8830]
close $cs
vwait done
after cancel $timer
set done
@@ -705,11 +705,11 @@
after cancel $timer
close $f
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket 127.0.0.1 8828} msg]} {
set x $msg
} else {
lappend x [gets $f]
@@ -732,11 +732,11 @@
puts ready
gets stdin
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ 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] \
$msg]
@@ -781,11 +781,11 @@
after cancel $t3
close $s
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set f [open "|[list $::tcltest::tcltest script]" r+]
set x [gets $f]
set s1 [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 8828]
fconfigure $s1 -buffering line
@@ -832,15 +832,15 @@
close $s
puts bye
gets stdin
}
close $f
- set p1 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set p1 [open "|[list $::tcltest::tcltest script]" r+]
fconfigure $p1 -buffering line
- set p2 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set p2 [open "|[list $::tcltest::tcltest script]" r+]
fconfigure $p2 -buffering line
- set p3 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set p3 [open "|[list $::tcltest::tcltest script]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
@@ -930,11 +930,11 @@
package require tls
gets stdin
}
puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848]
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set f [open "|[list $::tcltest::tcltest script]" r+]
proc bgerror args {
global x
set x $args
}
proc accept {s a p} {expr 10 / 0}
@@ -968,11 +968,11 @@
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 8820]
set p [fconfigure $s -peername]
@@ -1001,11 +1001,11 @@
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 8821]
set p [fconfigure $s -sockname]
@@ -1040,11 +1040,11 @@
set x [fconfigure $s -sockname]
close $s
}
set s1 [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
- [info hostname] 8823]
+ localhost 8823]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
@@ -1093,20 +1093,21 @@
after 500 close $s
set x done
}
set s1 [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
- -async [info hostname] 8830]
+ -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').
fconfigure $s1 -blocking 0 -buffering line
vwait x
# TLS handshaking needs one byte from the client...
puts $s1 a
# need update to complete TLS handshake in-process
update
+ fconfigure $s1 -blocking 1
set z [gets $s1]
close $s
close $s1
set z
} bye
@@ -1137,11 +1138,11 @@
set s [tls::socket \
-certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 8831]
set c [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
- [info hostname] 8831]
+ 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
close $c
@@ -1184,11 +1185,11 @@
set s [tls::socket \
-certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 8832]
set c [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
- [info hostname] 8832]
+ localhost 8832]
fconfigure $c -blocking 0 -trans lf -buffering line
set count 0
puts $c hello
proc readit {s} {
global count done
@@ -1245,11 +1246,11 @@
set s [tls::socket \
-certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 8833]
set c [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
- [info hostname] 8833]
+ localhost 8833]
fconfigure $c -blocking 0 -buffering line -translation lf
fileevent $c readable "count_to_eof $c"
set timer [after 2000 timerproc]
vwait done
close $s
@@ -2012,16 +2013,14 @@
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 \
+ set s [tls::socket -certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 8831]
- set c [tls::socket \
- -certfile $clientCert -cafile $caCert -keyfile $clientKey \
- [info hostname] 8831]
+ set c [tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey \
+ localhost 8831]
# 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 {}}
@@ -2041,24 +2040,23 @@
# 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.2
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 1 \
- -server Accept 8831]
+ -certfile $serverCert -cafile $caCert -keyfile $serverKey -request 0 \
+ -require 0 -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 \
+ -server Accept 8831]
# Client - Only propose TLS1.0
- set c [tls::socket -async \
- -cafile $caCert \
- -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 0 -tls1.2 0 \
- [info hostname] 8831]
+ set c [tls::socket -async -cafile $caCert -request 0 -require 0 \
+ -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 0 -tls1.2 0 -tls1.3 0 localhost 8831]
fconfigure $c -blocking 0
puts $c a ; flush $c
after 5000 [list set ::done timeout]
vwait ::done
switch -exact -- $::done {
- "handshake failed: wrong ssl version" {
+ "handshake failed: wrong ssl version" -
+ "handshake failed: unsupported protocol" {
set ::done "handshake failed: wrong version number"
}
}
set ::done
} {handshake failed: wrong version number}
Index: win/README.txt
==================================================================
--- win/README.txt
+++ win/README.txt
@@ -1,49 +1,84 @@
Windows DLL Build instructions using nmake build system
2020-10-15 Harald.Oehlmann@elmicron.de
- 2023-08-22 Kevin Walzer (kw@codebykevin.com)
+ 2023-04-23 Brian O'Hagan
Properties:
- 64 bit DLL
-- VisualStudio 2019
-- WSL
-- OpenSSL dynamically linked to TCLTLS DLL. We used a freely redistributable build of OpenSSL from https://www.firedaemon.com/firedaemon-openssl. Unzip and install OpenSSL in an accessible place (we used the lib subdirectory of our Tcl installation).
-
-1. Visual Studio x86 native prompt. Update environmental variables for building Tcltls. Customize the below entries for your setup.
-
-set PATH=%PATH%;C:\tcl-trunk\lib\openssl-3\x64\bin
-set INCLUDE=%INCLUDE%;C:\tcl-trunk\tcl\lib\openssl-3\x64\include\openssl
-set LIB=%LIB%;C:\tcl-trunk\tcl\lib\openssl-3\x64\bin
-
-
-2) Build TCLTLS
-
--> Unzip distribution on your system.
--> Start WSL.
--> cd /mnt/c/path/to/tcltls
-
-./gen_dh_params > dh_params.h
-
-od -A n -v -t xC < 'tls.tcl' > tls.tcl.h.new.1
-sed 's@[^0-9A-Fa-f]@@g;s@..@0x&, @g' < tls.tcl.h.new.1 > tls.tcl.h
+- VisualStudio 2015
+Note: Visual C++ 6 does not build OpenSSL (long long syntax error)
+- Cygwin32 (temporary helper, please help to replace by tclsh)
+- OpenSSL statically linked to TCLTLS DLL.
+Note: Dynamic linking also works but results in a DLL dependency on OPENSSL DLL's
+
+-----------------------------
+
+1) Build OpenSSL static libraries:
+
+set SSLBUILD=\path\to\build\dir
+set SSLINSTALL=\path\to\install\dir
+set SSLCOMMON=\path\to\common\dir
+
+(1a) Get OpenSSL
+
+ https://github.com/openssl/openssl/releases/download/OpenSSL_1_1_1t/openssl-1.1.1t.tar.gz
+
+ Unpack OpenSSL source distribution to %SSLBUILD%
+
+(1b) Install Perl from https://strawberryperl.com/
+
+ https://strawberryperl.com/download/5.32.1.1/strawberry-perl-5.32.1.1-64bit.msi
+ Install to C:\Strawberry\perl
+
+(1c) Install NASM Assembler from https://www.nasm.us/
+
+ https://www.nasm.us/pub/nasm/releasebuilds/2.16.01/win64/nasm-2.16.01-installer-x64.exe
+ Install to: C:\Program Files\NASM
+
+(1d) Configure
+
+ At Visual Studio x86 native prompt:
+
+ set Path=%PATH%;C:\Program Files\NASM;C:\Strawberry\perl\bin
+ perl ..\Configure VC-WIN64A no-shared no-filenames threads no-ssl2 no-ssl3 --api=1.1.0 --prefix="%SSLINSTALL%" --openssldir="%SSLCOMMON%" -DOPENSSL_NO_DEPRECATED
+ # Not used options: no-asm no-zlib no-comp no-ui-console no-autoload-config
+
+(1e) Build OpenSSL
+
+ nmake
+ nmake test
+ nmake install
+
+-----------------------------
+
+2) Build TclTLS
+
+set BUILDDIR=\path\to\build\dir
+set TCLINSTALL=\path\to\tcl\dir
+
+2a) Unzip distribution to %BUILDDIR%
+
+2b) Start BASH shell (MinGW62 Git shell)
+
+cd %BUILDDIR%
+od -A n -v -t xC < 'library/tls.tcl' > tls.tcl.h.new.1
+sed 's@[^0-9A-Fa-f]@@g;s@..@0x&, @g' < tls.tcl.h.new.1 > generic/tls.tcl.h
rm -f tls.tcl.h.new.1
--> Visual Studio x86 native prompt.
-
-cd C:path\to\tcltls\win
-
-Run the following commands (modify the flags to your specific installations).
-
-nmake -f makefile.vc TCLDIR=c:\users\wordt\tcl INSTALLDIR=c:\tcl-trunk\tcl\lib SSL_INSTALL_FOLDER=C:\tcl-trunk\tcl\lib\openssl-3\x64
-
-nmake -f makefile.vc TCLDIR=c:\users\wordt\tcl INSTALLDIR=c:\tcl-trunk\tcl\lib SSL_INSTALL_FOLDER=C:\tcl-trunk\tcl\lib\openssl-3\x64 install
-
-The resulting installation will include both the tcltls package and also have libcrypto.dll and libssl.dll copied into the same directory.
+2c) Start Visual Studio shell
+
+cd %BUILDDIR%\win
+
+nmake -f makefile.vc TCLDIR=%TCLINSTALL% SSL_INSTALL_FOLDER=%SSLINSTALL%
+nmake -f makefile.vc install TCLDIR=c:\test\tcl8610 INSTALLDIR=%TCLINSTALL% SSL_INSTALL_FOLDER=%SSLINSTALL%
+
+-----------------------------
3) Test
-Start tclsh
+Start tclsh or wish
package require tls
package require http
http::register https 443 [list ::tls::socket -autoservername true]
set tok [http::data [http::geturl https://www.tcl-lang.org]]
+::http::cleanup $tok