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 +]) Index: doc/tls.html ================================================================== --- doc/tls.html +++ doc/tls.html @@ -3,33 +3,39 @@ <head> <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> <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 bgcolor="#FFFFFF"> +<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> toolkit.</dd> + <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> <em>?@@VERS@@?</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::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> - <dd><b>tls::ciphers</b> <em>protocol ?verbose?</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> @@ -40,42 +46,40 @@ <hr> <h3><a name="NAME">NAME</a></h3> -<p><strong>tls</strong> - binding to <strong>OpenSSL</strong> -toolkit.</p> +<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 8.5</b><br> -<b>package require tls @@VERS@@</b><br> -<br> -<a href="#tls::init"><b>tls::init</b> <i>?options?</i><br> -</a><a href="#tls::socket"><b>tls::socket</b> <em>?options? host -port</em><br> -<b>tls::socket</b><em> ?-server command? ?options? port</em><br> -</a><a href="#tls::status"><b>tls::status</b> <em>?-local? channel</em><br> -</a><a href="#tls::handshake"><b>tls::handshake</b><em> channel</em></a><br> -<br> +<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> -<a href="#tls::ciphers protocol ?verbose?"><strong>tls::ciphers</strong> -<em>protocol ?verbose?</em></a><br> -<a href="#tls::version"><b>tls::version</b></a> +<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 a generic binding to <a -href="http://www.openssl.org/">OpenSSL</a>, utilizing the -<strong>Tcl_StackChannel</strong> -API for Tcl 8.2 and higher. The sockets behave exactly the same -as channels created using Tcl's built-in <strong>socket</strong> -command with additional options for controlling the SSL session. -To use TLS with an earlier version of Tcl than 8.4, please obtain -TLS 1.3. +<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 @@ -82,143 +86,126 @@ 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>This routine sets the default options used by <strong>tls::socket</strong> - and is <em>optional</em>. If you call <strong>tls::import</strong> + <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? + <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 that the options can include any of the - applicable <a href="#tls::import"><strong>tls:import</strong></a> - options with one additional option: -<blockquote> - <dl> - <dt><strong>-autoservername</strong> <em>bool</em></dt> - <dd>Automatically send the -servername as the <em>host</em> argument - (default is <em>false</em>)</dd> - </dl> -</blockquote> - <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>?-local? channel</em></a></dt> - <dd>Returns the current security status of an SSL channel. The - result is a list of key-value pairs describing the - connected peer. If the result is an empty list then the - SSL handshake has not yet completed. - If <em>-local</em> is given, then the certificate information - is the one used locally.</dd> -</dl> - -<blockquote> - <dl> - <dt><strong>issuer</strong> <em>dn</em></dt> - <dd>The distinguished name (DN) of the certificate - issuer.</dd> - <dt><strong>subject</strong> <em>dn</em></dt> - <dd>The distinguished name (DN) of the certificate - subject.</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 expiry date for the certificate.</dd> - <dt><strong>serial</strong> <em>n</em></dt> - <dd>The serial number of the certificate.</dd> - <dt><strong>cipher</strong> <em>cipher</em></dt> - <dd>The current cipher in use between the client and - server channels.</dd> - <dt><strong>sbits</strong> <em>n</em></dt> - <dd>The number of bits used for the session key.</dd> - <dt><strong>certificate</strong> <em>n</em></dt> - <dd>The PEM encoded certificate.</dd> - <dt><strong>version</strong> <em>value</em></dt> - <dd>The protocol version used for the connection: - SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, unknown</dd> - </dl> -</blockquote> - -<dl> - <dt><a name="tls::import"><b>tls::import</b> <i>channel - ?options?</i></a></dt> - <dd>SSL-enable a regular Tcl channel - it need not be a - socket, but must provide bi-directional flow. Also - setting session parameters for SSL handshake.</dd> -</dl> - -<blockquote> - <dl> - <dt><strong>-cadir</strong> <em>dir</em></dt> - <dd>Provide the directory containing the CA certificates.</dd> - <dt><strong>-cafile </strong><em>filename</em></dt> - <dd>Provide the CA file.</dd> - <dt><strong>-certfile</strong> <em>filename</em></dt> - <dd>Provide the name of a file containing certificate to use.</dd> - <dt><strong>-cert</strong> <em>filename</em></dt> - <dd>Provide 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>Provide the cipher suites to use. Syntax is as per - OpenSSL.</dd> - <dt><strong>-command</strong> <em>callback</em></dt> - <dd>If specified, this callback will be invoked at several points - during the OpenSSL handshake. It can pass errors and tracing - information, and it can allow Tcl scripts to perform - their own validation of the certificate in place of the - default validation provided by OpenSSL. - <br> - See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a> for - further discussion.</dd> - <dt><strong>-dhparams </strong><em>filename</em></dt> - <dd>Provide a Diffie-Hellman parameters file.</dd> - <dt><strong>-keyfile</strong> <em>filename</em></dt> - <dd>Provide the private key file. (default is - value of -certfile)</dd> - <dt><strong>-key</strong> <em>filename</em></dt> - <dd>Provide the private key to use as a DER encoded value (PKCS#1 DER)</dd> - <dt><strong>-model</strong> <em>channel</em></dt> - <dd>This will 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>If supplied, this callback will be invoked when OpenSSL needs - to obtain a password, typically to unlock the private key of - a certificate. - The callback should return a string which represents the - password to be used. - <br> - See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a> for - further discussion.</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. (default is <em>false</em>)</dd> - <dt><strong>-server</strong> <em>bool</em></dt> - <dd>Handshake as server if true, else handshake as - client.(default is <em>false</em>)</dd> - <dt><strong>-servername</strong> <em>host</em></dt> - <dd>Only available if the OpenSSL library the package is linked - against supports the TLS hostname extension for 'Server Name - Indication' (SNI). Use to name the logical host we are talking - to and expecting a certificate for</dd> + 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> @@ -227,224 +214,613 @@ <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> -<dl> - <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 SSL-enabling of a regular Tcl channel. An error - is thrown if TLS is not the top stacked channel type.</dd> -</dl> - -<dl> - <dt><a name="tls::ciphers protocol ?verbose?"><strong>tls::ciphers</strong> - <em>protocol ?verbose?</em></a></dt> - <dd>Returns list of supported ciphers based on the <em>protocol</em> - you supply, which must be one of <em>ssl2, ssl3, or tls1</em>. - If <em>verbose</em> is specified as true then a verbose, - semi-human readable list is returned providing additional - information on the nature of the cipher support. In each - case the result is a Tcl list.</dd> -</dl> - -<dl> + <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 version string defined by OpenSSL.</dd> + <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 -<em>-command</em> and <em>-password</em> options passed to either of +<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. - Except as indicated below, values returned from the + 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. - Arguments appended to the script upon callback take one of the - following forms: <br> <br> <dl> -<!-- This form of callback is disabled. - - <dt> - <strong>error</strong> <em>channel message</em> - </dt> - <dd> - The <em>message</em> argument contains an error message generated - by the OpenSSL function - <code>ERR_reason_error_string()</code>. - </dd> - - <br> ---> - - <dt> - <strong>info</strong> <em>channel major minor message</em> - </dt> - <dd> - This form of callback is invoked by the OpenSSL function - <code>SSL_CTX_set_info_callback()</code>. - <br> - The <em>major</em> and <em>minor</em> arguments are used to - represent the state information bitmask. - <dl> - <dt>Possible values for <em>major</em> are:</dt> - <dd><code>handshake, alert, connect, accept</code>.</dd> - <dt>Possible values for <em>minor</em> are:</dt> - <dd><code>start, done, read, write, loop, exit</code>.</dd> - </dl> - 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 context. - </dd> - - <br> - - <dt> - <strong>verify</strong> <em>channel depth cert status error</em> - </dt> - <dd> - This form of callback is invoked by the OpenSSL function - <code>SSL_set_verify()</code>. - <br> - The <em>depth</em> argument is an integer representing the - current depth on the certificate chain, with - <code>0</code> as the subject certificate and higher values - denoting progressively more indirect issuer certificates. - <br> - 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>. - <br> - The <em>status</em> argument is an integer representing the - current validity of the certificate. - A value of <code>0</code> means the certificate is deemed invalid. - A value of <code>1</code> means the certificate is deemed valid. - <br> - The <em>error</em> argument supplies the message, if any, generated - by - <code>X509_STORE_CTX_get_error()</code>. - <br> - <br> - The callback may override normal validation processing by explicitly - returning one of the above <em>status</em> values. - </dd> - + <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. The callback should return a string which - represents the password to be used. - No arguments are appended to the script upon callback. + 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> and -<strong>tls::password</strong> respectively. Note that these are +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 <em>-command</em> and <em>-password</em> options. +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 <em>-command</em> option is not specified is for -TLS to process the associated library callbacks internally. -The default behavior when the <em>-password</em> option is not specified is for -TLS to process the associated library callbacks by attempting to call -<strong>tls::password</strong>. +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. -</p> - -<p> -<em> -The use of the reference callbacks <strong>tls::callback</strong> and -<strong>tls::password</strong> is not recommended. They may be removed -from future releases. -</em> +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>This example uses a sample server.pem provided with the TLS release, -courtesy of the <strong>OpenSSL</strong> project.</p> +<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] -set tok [http::geturl https://core.tcl-lang.org/] +# 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 your OpenSSL library was configured and built. At the -most macro-level OpenSSL supports a "no patents" build, -which disables RSA, IDEA, RC(2,4,5) and SSL2 - if your OpenSSL is -configured this way then you will need to build TLS with the --DNO_PATENTS option - and the resultant module will function -correctly and also support ADH certificate-less encryption, -however you will be unable to utilize this to speak to normal Web -Servers, which typically require RSA support. Please see <a -href="http://www.openssl.org/">http://www.openssl.org/</a> for -more information on the whole issue of patents and US export -restrictions. </p> +<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>, <a -href="http://www.openssl.org/"><strong>OpenSSL</strong></a></p> +<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 @@ -25,10 +25,12 @@ #include "tlsInt.h" #include "tclOpts.h" #include <stdio.h> #include <stdlib.h> #include "tlsUuid.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 @@ -45,12 +47,12 @@ (((key) == NULL) ? (char *)NULL : \ Tcl_TranslateFileName(interp, (key), (dsp))) 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); + 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 @@ -58,28 +60,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)) -/* - * 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 */ @@ -87,54 +72,78 @@ #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, - TCL_UNUSED(const char *), - TCL_UNUSED(int)) -{ - 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; -} - -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((void *) interp); + Tcl_Preserve((void *) statePtr); + + /* Eval callback with success for ok or return value 1, fail for error or return value 0 */ + Tcl_ResetResult(interp); + code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); + dprintf("EvalCallback: %d", code); + 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((void *) statePtr); + Tcl_Release((void *) interp); + return ok; +} /* *------------------------------------------------------------------- * * InfoCallback -- @@ -160,21 +169,10 @@ 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"; @@ -190,277 +188,736 @@ else if (where & SSL_CB_LOOP) minor = "loop"; else if (where & SSL_CB_EXIT) minor = "exit"; else minor = "unknown"; } - 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_LOOP|SSL_CB_EXIT)) { - Tcl_ListObjAppendElement( 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( 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( interp, cmdPtr, - Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); - } - Tcl_Preserve((void *) interp); - Tcl_Preserve((void *) statePtr); - - Tcl_IncrRefCount( cmdPtr); - (void) Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount( cmdPtr); - - Tcl_Release((void *) statePtr); - Tcl_Release((void *) 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) { + 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 == 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((void *) statePtr->interp); - Tcl_Preserve((void *) 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((void *) statePtr); - Tcl_Release((void *) 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_GetString(Tcl_GetObjResult(interp))) != NULL) { + Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(msg, -1)); - Tcl_Preserve((void *) statePtr->interp); - Tcl_Preserve((void *) 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); - - Tcl_Release((void *) statePtr); - Tcl_Release((void *) statePtr->interp); -} - -/* - *------------------------------------------------------------------- - * - * 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( - TCL_UNUSED(char *) /* buf */, - TCL_UNUSED(int) /* size */, - TCL_UNUSED(int) /* verify */) -{ - return -1; -} -#else -static int -PasswordCallback( - char *buf, - int size, - TCL_UNUSED(int), /* verify */ - void *udata) -{ +} + +/* + *------------------------------------------------------------------- + * + * 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; + + dprintf("Called"); + + if (str) { + fd = fopen(str, "a"); + fprintf(fd, "%s\n",line); + fclose(fd); + } +} + +/* + *------------------------------------------------------------------- + * + * 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) { - const char *ret = Tcl_GetStringResult(interp); + 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((void *) statePtr->interp); + Tcl_Preserve((void *) interp); Tcl_Preserve((void *) 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((void *) statePtr); - Tcl_Release((void *) statePtr->interp); - - if (result == TCL_OK) { - const char *ret = Tcl_GetStringResult(interp); - strncpy(buf, ret, (size_t) size); - return (int)strlen(ret); - } else { - return -1; - } -} -#endif + + /* 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((void *) interp); + return((int) len); + } + Tcl_Release((void *) 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 { + res = SSL_CLIENT_HELLO_ERROR; + *alert = SSL_R_TLSV1_ALERT_INTERNAL_ERROR; + } + Tcl_DecrRefCount(cmdPtr); + return res; +} /* *------------------------------------------------------------------- * * CiphersObjCmd -- list available ciphers @@ -494,24 +951,31 @@ SSL_CTX *ctx = NULL; SSL *ssl = NULL; STACK_OF(SSL_CIPHER) *sk; const char *cp; char buf[BUFSIZ]; - int index, verbose = 0; + int index, verbose = 0, use_supported = 0; + const SSL_METHOD *method; 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 ((objc > 3) && Tcl_GetBooleanFromObj(interp, objv[3], &use_supported) != TCL_OK) { + return TCL_ERROR; + } + + ERR_clear_error(); + switch ((enum protocol)index) { case TLS_SSL2: Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); return TCL_ERROR; case TLS_SSL3: @@ -520,39 +984,41 @@ case TLS_TLS1: #if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1) || defined(OPENSSL_NO_TLS1_METHOD) Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); return TCL_ERROR; #else - ctx = SSL_CTX_new(TLSv1_method()); break; + method = TLSv1_method(); break; #endif case TLS_TLS1_1: #if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1_METHOD) Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); return TCL_ERROR; #else - ctx = SSL_CTX_new(TLSv1_1_method()); break; + method = TLSv1_1_method(); break; #endif case TLS_TLS1_2: #if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2_METHOD) Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); return TCL_ERROR; #else - ctx = SSL_CTX_new(TLSv1_2_method()); break; + method = TLSv1_2_method(); break; #endif case TLS_TLS1_3: #if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3_METHOD) Tcl_AppendResult(interp, protocols[index], ": protocol not supported", (char *)NULL); return TCL_ERROR; #else - ctx = SSL_CTX_new(TLS_method()); + method = TLS_method(); SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION); SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION); break; #endif default: + method = TLS_method(); break; } + ctx = SSL_CTX_new(method); if (ctx == NULL) { Tcl_AppendResult(interp, GET_ERR_REASON(), (char *)NULL); return TCL_ERROR; } ssl = SSL_new(ctx); @@ -559,40 +1025,104 @@ if (ssl == NULL) { Tcl_AppendResult(interp, GET_ERR_REASON(), (char *)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'; + } + + 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 { - break; + Tcl_AppendToObj(objPtr, "UNKNOWN\n", 8); } } - Tcl_ListObjAppendElement( interp, objPtr, - Tcl_NewStringObj( buf, -1) ); + } + if (use_supported) { + sk_SSL_CIPHER_free(sk); } } SSL_free(ssl); SSL_CTX_free(ctx); + + 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( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { + Tcl_Obj *objPtr; + + dprintf("Called"); + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + ERR_clear_error(); + + objPtr = Tcl_NewListObj(0, NULL); + +#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; } @@ -629,10 +1159,12 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return(TCL_ERROR); } + + ERR_clear_error(); chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return(TCL_ERROR); } @@ -711,10 +1243,11 @@ 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; + 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? */ @@ -723,41 +1256,44 @@ 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 *CAdir = NULL; + char *CApath = NULL; char *DHparams = NULL; char *model = NULL; -#ifndef OPENSSL_NO_TLSEXT char *servername = NULL; /* hostname for Server Name Indication */ -#endif + 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; dprintf("Called"); -#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; } + + ERR_clear_error(); chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } @@ -771,41 +1307,47 @@ char *opt = Tcl_GetString(objv[idx]); if (opt[0] != '-') break; - OPTSTR("-cadir", CAdir); + 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("-require", require); + OPTBOOL("-post_handshake", post_handshake); OPTBOOL("-request", request); + OPTBOOL("-require", require); + OPTINT("-security_level", level); OPTBOOL("-server", server); -#ifndef OPENSSL_NO_TLSEXT - OPTSTR( "-servername", servername); -#endif - + 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) - OPTBYTE("-cert", cert, cert_len); - OPTBYTE("-key", key, key_len); + 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 (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); @@ -817,12 +1359,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)); @@ -847,10 +1390,19 @@ 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); @@ -870,13 +1422,12 @@ Tls_Free((void *)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)) == NULL) { + 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((void *)statePtr); return TCL_ERROR; } } @@ -911,10 +1462,14 @@ 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 */ @@ -925,46 +1480,171 @@ Tcl_SetErrorCode(interp, "TLS", "IMPORT", "INIT", "FAILED", (char *)NULL); Tls_Free((void *)statePtr); return TCL_ERROR; } -#ifndef OPENSSL_NO_TLSEXT + /* Set host server name */ if (servername) { + /* 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, "setting TLS host name extension failed", (char *)NULL); + Tcl_AppendResult(interp, "Set SNI extension failed: ", GET_ERR_REASON(), (char *)NULL); + Tcl_SetErrorCode(interp, "TLS", "IMPORT", "SNI", "FAILED", (char *)NULL); + Tls_Free((void *)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((void *)statePtr); return TCL_ERROR; } } -#endif + + /* 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((void *)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((void *)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((void *)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((void *)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_CTX_set_info_callback(statePtr->ctx, InfoCallback); + SSL_set_info_callback(statePtr->ssl, 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; } /* *------------------------------------------------------------------- @@ -1009,11 +1689,11 @@ chan = Tcl_GetTopChannel(chan); if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", (char *)NULL); - Tcl_SetErrorCode(interp, "TLS", "UNIMPORT", "CHANNEL", "INVALID", (char *)NULL); + Tcl_SetErrorCode(interp, "TLS", "UNIMPORT", "CHANNEL", "INVALID", (char *)NULL); return TCL_ERROR; } if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) { return TCL_ERROR; @@ -1037,28 +1717,29 @@ */ static SSL_CTX * CTX_Init( State *statePtr, - TCL_UNUSED(int) /* isServer */, + int isServer, int proto, char *keyfile, char *certfile, unsigned char *key, unsigned char *cert, int key_len, int cert_len, - char *CAdir, + 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"); @@ -1098,35 +1779,41 @@ if (ENABLED(proto, TLS_PROTO_TLS1_3)) { Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", (char *)NULL); return NULL; } #endif + if (proto == 0) { + /* Use full range */ + SSL_CTX_set_min_proto_version(ctx, 0); + SSL_CTX_set_max_proto_version(ctx, 0); + } switch (proto) { #if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) && !defined(OPENSSL_NO_TLS1_METHOD) case TLS_PROTO_TLS1: - method = TLSv1_method(); + 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 = TLSv1_1_method(); + 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 = TLSv1_2_method(); + method = isServer ? TLSv1_2_server_method() : TLSv1_2_client_method(); break; #endif #if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3_METHOD) case TLS_PROTO_TLS1_3: /* Use the generic method and constraint range after context is created */ - method = TLS_method(); + method = isServer ? TLS_server_method() : TLS_client_method(); break; #endif default: - method = TLS_method(); + /* Negotiate highest available SSL/TLS version */ + method = isServer ? TLS_server_method() : TLS_client_method(); #if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) && !defined(OPENSSL_NO_TLS1_METHOD) off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1); #endif #if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1_METHOD) off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1); @@ -1137,37 +1824,61 @@ #if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3_METHOD) off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3); #endif break; } + + ERR_clear_error(); ctx = SSL_CTX_new(method); if (!ctx) { return(NULL); } + + if (getenv(SSLKEYLOGFILE)) { + SSL_CTX_set_keylog_callback(ctx, KeyLogCallback); + } #if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) if (proto == TLS_PROTO_TLS1_3) { SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION); SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION); } #endif - SSL_CTX_set_app_data(ctx, interp); /* remember the interpreter */ + /* Force cipher selection order by server */ + if (!isServer) { + SSL_CTX_set_options(ctx, SSL_OP_CIPHER_SERVER_PREFERENCE); + } + + 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 */ SSL_CTX_sess_set_cache_size(ctx, 128); - if (ciphers != NULL) - SSL_CTX_set_cipher_list(ctx, ciphers); + /* 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); @@ -1177,11 +1888,10 @@ #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); SSL_CTX_free(ctx); @@ -1212,23 +1922,22 @@ /* 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) { Tcl_DStringFree(&ds); Tcl_AppendResult(interp, "unable to set certificate file ", certfile, ": ", GET_ERR_REASON(), (char *)NULL); SSL_CTX_free(ctx); 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: ", GET_ERR_REASON(), (char *)NULL); SSL_CTX_free(ctx); return NULL; } @@ -1235,11 +1944,10 @@ } else { certfile = (char*)X509_get_default_cert_file(); 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, ": ", GET_ERR_REASON(), (char *)NULL); SSL_CTX_free(ctx); return NULL; #endif @@ -1268,11 +1976,10 @@ return NULL; } 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: ", GET_ERR_REASON(), (char *)NULL); SSL_CTX_free(ctx); return NULL; @@ -1287,37 +1994,61 @@ SSL_CTX_free(ctx); return NULL; } } - /* 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: ", - GET_ERR_REASON(), (char *)NULL); - SSL_CTX_free(ctx); - return NULL; -#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); + /* 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 + } + return ctx; } /* *------------------------------------------------------------------- @@ -1343,29 +2074,22 @@ X509 *peer; Tcl_Obj *objPtr; Tcl_Channel chan; char *channelName, *ciphers; int mode; + const unsigned char *proto; + unsigned int len; + int nid, res; 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; + } + + channelName = Tcl_GetString(objv[(objc == 2 ? 1 : 2)]); chan = Tcl_GetChannel(interp, channelName, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } /* @@ -1395,18 +2119,305 @@ } } else { objPtr = Tcl_NewListObj(0, 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) { - LAPPEND_STR(interp, objPtr, "cipher", ciphers, -1); + 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( + 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 */ + Tcl_Obj *objPtr, *listPtr; + const SSL *ssl; + const SSL_CIPHER *cipher; + const SSL_SESSION *session; + const EVP_MD *md; + + 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", 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_INT(interp, objPtr, "start_time", SSL_SESSION_get_time(session)); + + /* Timeout value - SSL_CTX_get_timeout (in seconds) */ + LAPPEND_INT(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_INT(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_STR(interp, objPtr, "version", SSL_get_version(statePtr->ssl), -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; } @@ -1458,29 +2469,33 @@ 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; + static const char *commands [] = { "req", "strreq", NULL }; + enum command { C_REQ, C_STRREQ, C_DUMMY }; + Tcl_Size cmd; + int isStr; + char buffer[16384]; 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) { + "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; @@ -1506,10 +2521,14 @@ 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) { return TCL_ERROR; } @@ -1544,10 +2563,11 @@ Tcl_SetResult(interp,"Unknown parameter",NULL); return TCL_ERROR; } } } + #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) || @@ -1554,24 +2574,36 @@ !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); + 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 { - 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 (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 @@ -1606,14 +2638,25 @@ #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); #if OPENSSL_VERSION_NUMBER < 0x30000000L BN_free(bne); @@ -1685,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; @@ -1707,10 +2754,14 @@ statePtr->callback = NULL; } if (statePtr->password) { Tcl_DecrRefCount(statePtr->password); statePtr->password = NULL; + } + if (statePtr->vcmd) { + Tcl_DecrRefCount(statePtr->vcmd); + statePtr->vcmd = NULL; } dprintf("Returning"); } @@ -1758,16 +2809,18 @@ Tcl_AppendResult(interp, "could not initialize SSL library", (char *)NULL); return TCL_ERROR; } Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, NULL, 0); + Tcl_CreateObjCommand(interp, "tls::connection", ConnectionInfoObjCmd, NULL, 0); Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, NULL, 0); Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, NULL, 0); Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, NULL, 0); Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, NULL, 0); Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, NULL, 0); Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, NULL, 0); + Tcl_CreateObjCommand(interp, "tls::protocols", ProtocolsObjCmd, NULL, 0); if (interp) { if (Tcl_Eval(interp, tlsTclInitScript) != TCL_OK) { return TCL_ERROR; } @@ -1775,10 +2828,11 @@ if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { Tcl_CreateObjCommand(interp, "::tls::build-info", info.objProc, (void *)( PACKAGE_VERSION "+" STRINGIFY(TLS_VERSION_UUID) + ".bohagan" #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) #if __clang_minor__ < 10 "0" #endif @@ -1919,31 +2973,23 @@ Tcl_MutexLock(&init_mx); #endif initialized = 1; #if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - num_locks = CRYPTO_num_locks(); - locksCount = num_locks; + num_locks = 1; + locksCount = (int) 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(); + /* 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); -done: #if defined(OPENSSL_THREADS) && defined(TCL_THREADS) Tcl_MutexUnlock(&init_mx); #endif return(status); } Index: generic/tlsIO.c ================================================================== --- generic/tlsIO.c +++ generic/tlsIO.c @@ -119,17 +119,17 @@ */ int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) { unsigned long backingError; int err, rc; int bioShouldRetry; + *errorCodePtr = 0; 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) { /* @@ -141,35 +141,43 @@ *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 (;;) { - /* Not initialized yet! */ + 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("That seems to have gone okay"); + 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); - - dprintf("Got error: %i (rc = %i)", err, rc); + 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; @@ -188,10 +196,11 @@ 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; } @@ -199,71 +208,71 @@ 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"); + /* The TLS/SSL I/O operation completed */ + dprintf("The connection is good"); + *errorCodePtr = 0; break; case SSL_ERROR_ZERO_RETURN: - dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...") + /* 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: - backingError = ERR_get_error(); + /* 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 = 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; + 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())); + /* 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); default: - dprintf("We got a confusing reply: %i", rc); - *errorCodePtr = Tcl_GetErrno(); + /* 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); - 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 + 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"); @@ -313,10 +322,11 @@ 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 */ @@ -340,10 +350,11 @@ 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"); @@ -355,50 +366,77 @@ 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)); + /* 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; - 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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno()); - *errorCodePtr = Tcl_GetErrno(); - bytesRead = -1; - } else { - dprintf("I/O error occurred (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; +#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; } @@ -446,10 +484,11 @@ 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 */ @@ -463,10 +502,11 @@ 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); } @@ -490,10 +530,11 @@ 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; } @@ -500,46 +541,64 @@ 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: - backingError = ERR_get_error(); + /* 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 = backingError; + *errorCodePtr = Tcl_GetErrno(); written = -1; + Tls_Error(statePtr, (char *) ERR_reason_error_string(backingError)); } break; case SSL_ERROR_SSL: - Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written)); + /* 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); @@ -657,10 +716,11 @@ 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. */ @@ -675,11 +735,12 @@ 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); + watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(downChan)); + watchProc(Tcl_GetChannelInstanceData(downChan), 0); statePtr->watchMask = 0; return; } statePtr->watchMask = mask; @@ -690,11 +751,12 @@ * 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); + watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(downChan)); + watchProc(Tcl_GetChannelInstanceData(downChan), mask); /* * Management of the internal timer. */ if (statePtr->timer != (Tcl_TimerToken) NULL) { @@ -788,10 +850,11 @@ } 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; } Index: generic/tlsInt.h ================================================================== --- generic/tlsInt.h +++ generic/tlsInt.h @@ -97,11 +97,10 @@ #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)); \ @@ -157,16 +156,20 @@ 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 */ const char *err; } State; #ifdef USE_TCL_STUBS @@ -199,10 +202,11 @@ */ 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); Index: generic/tlsX509.c ================================================================== --- generic/tlsX509.c +++ generic/tlsX509.c @@ -1,74 +1,356 @@ /* * Copyright (C) 1997-2000 Sensus Consulting Ltd. * Matt Newman <matt@sensus.org> * 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 -/* - * 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"; + +/* + * 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; } /* *------------------------------------------------------* * @@ -92,101 +374,243 @@ Tls_NewX509Obj( 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)]; - } - LAPPEND_STR(interp, certPtr, "sha1_hash", sha_hash_ascii, SHA_DIGEST_LENGTH * 2); - -#endif - LAPPEND_STR(interp, certPtr, "subject", subject, -1); - - LAPPEND_STR(interp, certPtr, "issuer", issuer, -1); - - LAPPEND_STR(interp, certPtr, "notBefore", notBefore, -1); - - LAPPEND_STR(interp, certPtr, "notAfter", notAfter, -1); - - LAPPEND_STR(interp, certPtr, "serial", serial, -1); - - LAPPEND_STR(interp, certPtr, "certificate", certStr, -1); - + 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_INT(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_INT(interp, certPtr, "pathLen", X509_get_pathlen(cert)); + } else { + LAPPEND_INT(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 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,181 +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) { - ECDHE-RSA-AES256-SHA - DHE-PSK-AES256-CCM - DHE-PSK-AES128-GCM-SHA256 - ECDHE-RSA-AES128-SHA256 - DHE-PSK-AES256-GCM-SHA384 - AES256-SHA256 - ECDHE-PSK-CHACHA20-POLY1305 - ECDHE-ECDSA-AES128-SHA256 - AES256-CCM - ECDHE-RSA-AES128-GCM-SHA256 - DHE-RSA-AES256-SHA - ECDHE-ECDSA-AES128-GCM-SHA256 - PSK-AES128-GCM-SHA256 - ECDHE-ECDSA-AES256-SHA - ECDHE-RSA-AES256-GCM-SHA384 - ECDHE-PSK-AES256-CBC-SHA - ECDHE-ECDSA-AES256-GCM-SHA384 - AES128-SHA - PSK-AES256-GCM-SHA384 - PSK-AES128-CBC-SHA - ECDHE-RSA-AES128-SHA - AES128-GCM-SHA256 - ECDHE-PSK-AES128-CBC-SHA256 - AES256-GCM-SHA384 - TLS_AES_128_GCM_SHA256 - DHE-RSA-AES128-SHA256 - DHE-PSK-CHACHA20-POLY1305 - DHE-PSK-AES128-CCM - TLS_AES_256_GCM_SHA384 - DHE-RSA-AES256-CCM - DHE-RSA-AES128-GCM-SHA256 - ECDHE-ECDSA-AES256-CCM - PSK-AES256-CCM - DHE-RSA-AES256-GCM-SHA384 - AES128-CCM - ECDHE-RSA-CHACHA20-POLY1305 - DHE-PSK-AES256-CBC-SHA - DHE-RSA-AES128-SHA - ECDHE-ECDSA-CHACHA20-POLY1305 - PSK-CHACHA20-POLY1305 - DHE-PSK-AES128-CBC-SHA256 - ECDHE-ECDSA-AES128-SHA - ECDHE-PSK-AES128-CBC-SHA - AES128-SHA256 - PSK-AES128-CBC-SHA256 - DHE-RSA-CHACHA20-POLY1305 - DHE-RSA-AES128-CCM - DHE-RSA-AES256-SHA256 - ECDHE-ECDSA-AES128-CCM - PSK-AES128-CCM - TLS_CHACHA20_POLY1305_SHA256 - DHE-PSK-AES128-CBC-SHA - AES256-SHA - PSK-AES256-CBC-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} -constraints openssl -body { - tls::ciphers ssl3 -} -returnCodes 1 -result {ssl3: protocol not supported} - -# 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 @@ -6,19 +6,22 @@ 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" Index: tests/keytest2.tcl ================================================================== --- tests/keytest2.tcl +++ tests/keytest2.tcl @@ -1,6 +1,8 @@ -#! /usr/bin/env tclsh +#!/bin/sh +# The next line is executed by /bin/sh, but not tcl \ +exec tclsh "$0" ${1+"$@"} set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]] package require tls set s [tls::socket 127.0.0.1 12300] 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/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 @@ -440,11 +440,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 localhost 8831} sock]} { set x $sock } else { @@ -477,11 +477,11 @@ vwait x after cancel $timer close $f } close $f - set f [open "|[list $::tcltest::tcltest script] 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 { @@ -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] @@ -2040,16 +2040,16 @@ # 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 localhost 8831] + -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 { Index: win/README.txt ================================================================== --- win/README.txt +++ win/README.txt @@ -1,47 +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 x64 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 - -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 x64 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