Index: doc/tls.html
==================================================================
--- doc/tls.html
+++ doc/tls.html
@@ -11,28 +11,29 @@
<body bgcolor="#FFFFFF">
<dl>
<dd><a href="#NAME">NAME</a> <dl>
- <dd><strong>tls</strong> - binding to <strong>OpenSSL</strong>
- toolkit.</dd>
- </dl>
+ <dd><b>tls</b> - binding to <b>OpenSSL</b> toolkit.</dd>
+ </dl>
</dd>
<dd><a href="#SYNOPSIS">SYNOPSIS</a> </dd>
<dd><dl>
- <dd><b>package require Tcl </b><em>?8.4?</em></dd>
- <dd><b>package require tls </b><em>?@@VERS@@?</em></dd>
+ <dd><b>package require Tcl</b> <em>?8.4?</em></dd>
+ <dd><b>package require tls</b></dd>
+ <dt> </dt>
+ <dd><b>tls::init</b> <em>?options?</em> </dd>
+ <dd><b>tls::socket</b> <em>?options? host port</em></dd>
+ <dd><b>tls::socket</b> <em> ?-server command? ?options? port</em></dd>
+ <dd><b>tls::handshake</b> <em> channel</em></dd>
+ <dd><b>tls::status </b> <em>?-local? channel</em></dd>
+ <dd><b>tls::connection </b> <em>channel</em></dd>
+ <dd><b>tls::import</b> <em>channel ?options?</em></dd>
+ <dd><b>tls::unimport</b> <em>channel</em></dd>
<dt> </dt>
- <dd><b>tls::init </b><i>?options?</i> </dd>
- <dd><b>tls::socket </b><em>?options? host port</em></dd>
- <dd><b>tls::socket</b><em> ?-server command?
- ?options? port</em></dd>
- <dd><b>tls::handshake</b><em> channel</em></dd>
- <dd><b>tls::status </b><em>?-local? channel</em></dd>
- <dd><b>tls::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>
+ <dd><b>tls::ciphers </b> <em>protocol ?verbose? ?supported?</em></dd>
+ <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>
@@ -49,23 +50,23 @@
toolkit.</p>
<h3><a name="SYNOPSIS">SYNOPSIS</a></h3>
<p><b>package require Tcl 8.4</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>
-<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>
+<b>package require tls</b><br>
+<br>
+<a href="#tls::init"><b>tls::init</b> <i>?options?</i></a><br>
+<a href="#tls::socket"><b>tls::socket</b> <i>?options? host port</i><br>
+<a href="#tls::socket"><b>tls::socket</b> <i>?-server command? ?options? port</i></a><br>
+<a href="#tls::status"><b>tls::status</b> <i>?-local? channel</i></a><br>
+<a href="#tls::connection"><b>tls::connection</b> <i>channel</i></a><br>
+<a href="#tls::handshake"><b>tls::handshake</b> <i>channel</i></a><br>
+<a href="#tls::import"><b>tls::import</b> <i>channel ?options?</i></a><br>
+<a href="#tls::unimport"><b>tls::unimport</b> <i>channel</i></a><br>
+<br>
+<a href="#tls::ciphers"><b>tls::ciphers</b> <i>protocol ?verbose? ?supported?</i></a><br>
+<a href="#tls::protocols"><b>tls::protocols</b></a>
<a href="#tls::version"><b>tls::version</b></a>
</p>
<h3><a name="DESCRIPTION">DESCRIPTION</a></h3>
@@ -84,12 +85,12 @@
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>
+ <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>
@@ -104,29 +105,134 @@
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
- (<strong>default</strong>: <em>false</em>)</dd>
+ (default is <em>false</em>)</dd>
+ </dl>
+</blockquote>
+
+ <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>
+
+<blockquote>
+ <dl>
+ <dt><strong>-alpn</strong> <em>list</em></dt>
+ <dd>List of protocols to offer during Application-Layer
+ Protocol Negotiation (ALPN). For example: h2, http/1.1, etc.</dd>
+ <dt><strong>-cadir</strong> <em>dir</em></dt>
+ <dd>Specify the directory containing the CA certificates. 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>Specify the certificate authority (CA) file to use.</dd>
+ <dt><strong>-certfile</strong> <em>filename</em></dt>
+ <dd>Specify the filename containing the certificate to use. The
+ default name is <b>cert.pem</b>. This can be overridden via
+ the <b>SSL_CERT_FILE</b> environment variable.</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 or cipher suites. Cipher suites 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 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 to invoke 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. 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>-securitylevel</strong> <em>integer</em></dt>
+ <dd>Set security level. Must be 0 to 5. The security level affects
+ 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>Handshake as server if true, else handshake as
+ client. (default is <em>false</em>)</dd>
+ <dt><strong>-servername</strong> <em>host</em></dt>
+ <dd>Specify server hostname. 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>
+ <dt><strong>-session_id</strong> <em>string</em></dt>
+ <dd>Session id to resume session.</dd>
+ <dt><strong>-ssl2</strong> <em>bool</em></dt>
+ <dd>Enable use of SSL v2. (default is <em>false</em>)</dd>
+ <dt><strong>-ssl3 </strong><em>bool</em></dt>
+ <dd>Enable use of SSL v3. (default is <em>false</em>)</dd>
+ <dt>-<strong>tls1</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1. (default is <em>true</em>)</dd>
+ <dt>-<strong>tls1.1</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1.1 (default is <em>true</em>)</dd>
+ <dt>-<strong>tls1.2</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1.2 (default is <em>true</em>)</dd>
+ <dt>-<strong>tls1.3</strong> <em>bool</em></dt>
+ <dd>Enable use of TLS v1.3 (default is <em>true</em>)</dd>
</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 SSL-enabling 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>?-local? channel</em></a></dt>
- <dd>Returns the current security status of an SSL channel. The
+ <dd>Returns the current certificate 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
@@ -149,128 +255,93 @@
<dd>The PEM encoded certificate.</dd>
<dt><strong>sha1_hash</strong> <em>hash</em></dt>
<dd>The SHA1 hash of the certificate.</dd>
<dt><strong>sha256_hash</strong> <em>hash</em></dt>
<dd>The SHA256 hash of the certificate.</dd>
+ <dt><strong>validation</strong> <em>result</em></dt>
+ <dd>Certificate validation result.</dd>
<dt><strong>alpn</strong> <em>protocol</em></dt>
<dd>The protocol selected after Application-Layer Protocol
Negotiation (ALPN).</dd>
<dt><strong>version</strong> <em>value</em></dt>
<dd>The protocol version used for the connection:
- SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, unknown</dd>
+ SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, or 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>
+ <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
+ connected peer.</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: h2, http/1.1, etc.</dd>
- <dt><strong>-cadir</strong> <em>dir</em></dt>
- <dd>Provide the directory containing the CA certificates. 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>Provide the CA file.</dd>
- <dt><strong>-certfile</strong> <em>filename</em></dt>
- <dd>Provide the name of a file containing certificate to use.
- The default name is cert.pem. This can be overridden via the
- <b>SSL_CERT_FILE</b> environment variable.</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. (<strong>default</strong>:
- 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.
- (<strong>default</strong>: <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. (<strong>default</strong>: <em>false</em>)</dd>
- <dt><strong>-server</strong> <em>bool</em></dt>
- <dd>Handshake as server if true, else handshake as
- client.(<strong>default</strong>: <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>
- <dt><strong>-ssl2</strong> <em>bool</em></dt>
- <dd>Enable use of SSL v2. (<strong>default</strong>: <em>false</em>)</dd>
- <dt><strong>-ssl3 </strong><em>bool</em></dt>
- <dd>Enable use of SSL v3. (<strong>default</strong>: <em>false</em>)</dd>
- <dt>-<strong>tls1</strong> <em>bool</em></dt>
- <dd>Enable use of TLS v1. (<strong>default</strong>: <em>true</em>)</dd>
- <dt>-<strong>tls1.1</strong> <em>bool</em></dt>
- <dd>Enable use of TLS v1.1 (<strong>default</strong>: <em>true</em>)</dd>
- <dt>-<strong>tls1.2</strong> <em>bool</em></dt>
- <dd>Enable use of TLS v1.2 (<strong>default</strong>: <em>true</em>)</dd>
- <dt>-<strong>tls1.3</strong> <em>bool</em></dt>
- <dd>Enable use of TLS v1.3 (<strong>default</strong>: <em>true</em>)</dd>
+ <dt><strong>state</strong> <em>state</em></dt>
+ <dd>State of the connection: initializing, handshake, established</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</strong> <em>state</em></dt>
+ <dd>Whether protocol renegotiation is allowed or disallowed.</dd>
+ <dt><strong>alpn</strong> <em>protocol</em></dt>
+ <dd>The protocol selected after Application-Layer Protocol
+ Negotiation (ALPN).</dd>
+ <dt><strong>securitylevel</strong> <em>level</em></dt>
+ <dd>The security level used for selection of ciphers, key size, etc.</dd>
+ <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>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>description</strong> <em>string</em></dt>
+ <dd>A text description of the cipher.</dd>
+ <dt><strong>session_reused</strong> <em>boolean</em></dt>
+ <dd>Whether the session has been reused or not.</dd>
+ <dt><strong>session_id</strong> <em>string</em></dt>
+ <dd>Unique session id for use in resuming the session.</dd>
+ <dt><strong>session_ticket</strong> <em>string</em></dt>
+ <dd>Unique session ticket for use in resuming the session.</dd>
+ <dt><strong>resumable</strong> <em>boolean</em></dt>
+ <dd>Can the session 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>compression</strong> <em>mode</em></dt>
+ <dd>Compression method.</dd>
+ <dt><strong>expansion</strong> <em>mode</em></dt>
+ <dd>Expansion method.</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::ciphers"><strong>tls::ciphers</strong>
+ <em>protocol ?verbose? ?supported?</em></a></dt>
+ <dd>Returns a list of supported ciphers available for <em>protocol</em>,
+ where protocol must be one of <b>ssl2, ssl3, tls1, tls1.1,
+ tls1.2,</b> or <b>tls1.3</b>. If <em>verbose</em> is specified as
+ true then a verbose, human readable list is returned with
+ additional information on the cipher. If <em>supported</em>
+ is specified as true, then only the ciphers supported for protocol
+ will be listed.</dd>
+
+ <dt><a name="tls::protocols"><strong>tls::protocols</strong></a></dt>
+ <dd>Returns a list of 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>.</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>
@@ -294,10 +365,21 @@
<br>
<br>
<dl>
+
+ <dt>
+ <strong>alpn</strong> <em>protocol</em>
+ </dt>
+ <dd>
+ This form of callback is invoked when server selects the first
+ -alpn specified protocol common to the client and server. If none,
+ first client one is used.
+ </dd>
+
+ <br>
<!-- This form of callback is disabled.
<dt>
<strong>error</strong> <em>channel message</em>
@@ -308,10 +390,19 @@
<code>ERR_reason_error_string()</code>.
</dd>
<br>
-->
+
+ <dt>
+ <strong>hello</strong> <em>servername</em>
+ </dt>
+ <dd>
+ This form of callback is invoked during client hello message processing.
+ </dd>
+
+ <br>
<dt>
<strong>info</strong> <em>channel major minor message</em>
</dt>
<dd>
@@ -331,10 +422,35 @@
<code>SSL_state_string_long()</code> or by
<code>SSL_alert_desc_string_long()</code>,
depending on context.
</dd>
+ <br>
+
+ <dt>
+ <strong>session</strong> <em>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>.
+ Where <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.
+ </dd>
+
+ <br>
+
+ <dt>
+ <strong>sni</strong> <em>servername</em>
+ </dt>
+ <dd>
+ This form of callback is invoked when the server receives the SNI
+ header from the client where <i>servername</i> is the client
+ specified servername. Used to allow multiple names for
+ same server so the right certificate can be used.
+ </dd>
+
<br>
<dt>
<strong>verify</strong> <em>channel depth cert status error</em>
</dt>
Index: generic/tls.c
==================================================================
--- generic/tls.c
+++ generic/tls.c
@@ -2,10 +2,11 @@
* Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com>
* some modifications:
* Copyright (C) 2000 Ajuba Solutions
* Copyright (C) 2002 ActiveState Corporation
* Copyright (C) 2004 Starfish Systems
+ * Copyright (C) 2023 Brian O'Hagan
*
* TLS (aka SSL) Channel - can be layered on any bi-directional
* Tcl_Channel (Note: Requires Trf Core Patch)
*
* This was built (almost) from scratch based upon observation of
@@ -24,10 +25,16 @@
#include "tlsInt.h"
#include "tclOpts.h"
#include <stdio.h>
#include <stdlib.h>
#include <openssl/rsa.h>
+#include <openssl/safestack.h>
+
+/* Min OpenSSL version */
+#if OPENSSL_VERSION_NUMBER < 0x10101000L
+#error "Only OpenSSL v1.1.1 or later is supported"
+#endif
/*
* External functions
*/
@@ -41,11 +48,11 @@
#define REASON() ERR_reason_error_string(ERR_get_error())
static SSL_CTX *CTX_Init(State *statePtr, int isServer, int proto, char *key,
char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1,
int key_asn1_len, int cert_asn1_len, char *CAdir, char *CAfile,
- char *ciphers, char *DHparams);
+ char *ciphers, char *ciphersuites, int level, char *DHparams);
static int TlsLibInit(int uninitialize);
#define TLS_PROTO_SSL2 0x01
#define TLS_PROTO_SSL3 0x02
@@ -63,29 +70,10 @@
#ifndef OPENSSL_NO_DH
#include "dh_params.h"
#endif
-/*
- * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2
- * libraries instead of the current OpenSSL libraries.
- */
-
-#ifdef BSAFE
-#define PRE_OPENSSL_0_9_4 1
-#endif
-
-/*
- * Pre OpenSSL 0.9.4 Compat
- */
-
-#ifndef STACK_OF
-#define STACK_OF(x) STACK
-#define sk_SSL_CIPHER_num(sk) sk_num((sk))
-#define sk_SSL_CIPHER_value(sk, index) (SSL_CIPHER*)sk_value((sk), (index))
-#endif
-
/*
* Thread-Safe TLS Code
*/
#ifdef TCL_THREADS
@@ -92,11 +80,10 @@
#define OPENSSL_THREAD_DEFINES
#include <openssl/opensslconf.h>
#ifdef OPENSSL_THREADS
#include <openssl/crypto.h>
-/* Added */
#include <openssl/ssl.h>
/*
* Threaded operation requires locking callbacks
* Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL.
@@ -103,46 +90,16 @@
*/
static Tcl_Mutex *locks = NULL;
static int locksCount = 0;
static Tcl_Mutex init_mx;
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
-
-void CryptoThreadLockCallback(int mode, int n, const char *file, int line) {
-
- if (mode & CRYPTO_LOCK) {
- /* This debugging is turned off by default -- it's too noisy. */
- /* dprintf("Called to lock (n=%i of %i)", n, locksCount); */
- Tcl_MutexLock(&locks[n]);
- } else {
- /* dprintf("Called to unlock (n=%i of %i)", n, locksCount); */
- Tcl_MutexUnlock(&locks[n]);
- }
-
- /* dprintf("Returning"); */
-
- return;
- file = file;
- line = line;
-}
-
-unsigned long CryptoThreadIdCallback(void) {
- unsigned long ret;
-
- dprintf("Called");
-
- ret = (unsigned long) Tcl_GetCurrentThread();
-
- dprintf("Returning %lu", ret);
-
- return(ret);
-}
-
-#endif
#endif /* OPENSSL_THREADS */
#endif /* TCL_THREADS */
+
+/********************/
+/* Callbacks */
+/********************/
/*
*-------------------------------------------------------------------
*
@@ -158,10 +115,11 @@
*-------------------------------------------------------------------
*/
static void
InfoCallback(const SSL *ssl, int where, int ret) {
State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
+ Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr;
char *major; char *minor;
dprintf("Called");
@@ -196,36 +154,36 @@
else if (where & SSL_CB_LOOP) minor = "loop";
else if (where & SSL_CB_EXIT) minor = "exit";
else minor = "unknown";
}
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj("info", -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("info", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(major, -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(minor, -1));
+ 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(statePtr->interp, cmdPtr,
+ 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(statePtr->interp, cmdPtr, Tcl_NewStringObj(cp, -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(cp, -1));
} else {
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
+ Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewStringObj(SSL_state_string_long(ssl), -1));
}
- Tcl_Preserve((ClientData) statePtr->interp);
+ Tcl_Preserve((ClientData) interp);
Tcl_Preserve((ClientData) statePtr);
Tcl_IncrRefCount(cmdPtr);
- (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ (void) Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdPtr);
Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
+ Tcl_Release((ClientData) interp);
}
/*
*-------------------------------------------------------------------
*
@@ -252,10 +210,11 @@
char *errStr, *string;
int length;
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);
int code;
dprintf("Verify: %d", ok);
@@ -273,44 +232,44 @@
return 1;
}
}
cmdPtr = Tcl_DuplicateObj(statePtr->callback);
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj("verify", -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
- Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewIntObj(depth));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tls_NewX509Obj(statePtr->interp, cert));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewIntObj(ok));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(errStr ? errStr : "", -1));
-
- Tcl_Preserve((ClientData) statePtr->interp);
+ Tcl_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(errStr ? errStr : "", -1));
+
+ Tcl_Preserve((ClientData) interp);
Tcl_Preserve((ClientData) statePtr);
statePtr->flags |= TLS_TCL_CALLBACK;
Tcl_IncrRefCount(cmdPtr);
- code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
/* It got an error - reject the certificate. */
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
+ Tcl_BackgroundError(interp);
#else
- Tcl_BackgroundException(statePtr->interp, code);
+ Tcl_BackgroundException(interp, code);
#endif
ok = 0;
} else {
- result = Tcl_GetObjResult(statePtr->interp);
+ result = Tcl_GetObjResult(interp);
string = Tcl_GetStringFromObj(result, &length);
/* An empty result leaves verification unchanged. */
if (string != NULL && length > 0) {
- code = Tcl_GetIntFromObj(statePtr->interp, result, &ok);
+ code = Tcl_GetIntFromObj(interp, result, &ok);
if (code != TCL_OK) {
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
+ Tcl_BackgroundError(interp);
#else
- Tcl_BackgroundException(statePtr->interp, code);
+ Tcl_BackgroundException(interp, code);
#endif
ok = 0;
}
}
}
@@ -317,11 +276,11 @@
Tcl_DecrRefCount(cmdPtr);
statePtr->flags &= ~(TLS_TCL_CALLBACK);
Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
+ Tcl_Release((ClientData) interp);
return(ok); /* By default, leave verification unchanged. */
}
/*
*-------------------------------------------------------------------
@@ -336,62 +295,70 @@
* to a string describing the SSL negotiation failure reason
*-------------------------------------------------------------------
*/
void
Tls_Error(State *statePtr, char *msg) {
+ Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr;
int code;
dprintf("Called");
if (msg && *msg) {
- Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL);
+ Tcl_SetErrorCode(interp, "SSL", msg, (char *)NULL);
} else {
- msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL);
+ msg = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL);
}
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_SetResult(interp, buf, TCL_VOLATILE);
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
+ Tcl_BackgroundError(interp);
#else
- Tcl_BackgroundException(statePtr->interp, TCL_ERROR);
+ Tcl_BackgroundException(interp, TCL_ERROR);
#endif
return;
}
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));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(msg, -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
- Tcl_NewStringObj(msg, -1));
-
- Tcl_Preserve((ClientData) statePtr->interp);
+ Tcl_Preserve((ClientData) interp);
Tcl_Preserve((ClientData) statePtr);
Tcl_IncrRefCount(cmdPtr);
- code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
+ Tcl_BackgroundError(interp);
#else
- Tcl_BackgroundException(statePtr->interp, code);
+ Tcl_BackgroundException(interp, code);
#endif
}
Tcl_DecrRefCount(cmdPtr);
Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
+ Tcl_Release((ClientData) interp);
}
+/*
+ *-------------------------------------------------------------------
+ *
+ * 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;
if (str) {
fd = fopen(str, "a");
@@ -401,30 +368,17 @@
}
/*
*-------------------------------------------------------------------
*
- * PasswordCallback --
+ * Password Callback --
*
* Called when a password is needed to unpack RSA and PEM keys.
* Evals any bound password script and returns the result as
* the password string.
*-------------------------------------------------------------------
*/
-#ifdef PRE_OPENSSL_0_9_4
-/*
- * No way to handle user-data therefore no way without a global
- * variable to access the Tcl interpreter.
-*/
-static int
-PasswordCallback(char *buf, int size, int verify) {
- return -1;
- buf = buf;
- size = size;
- verify = verify;
-}
-#else
static int
PasswordCallback(char *buf, int size, int verify, void *udata) {
State *statePtr = (State *) udata;
Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr;
@@ -470,12 +424,305 @@
}
Tcl_Release((ClientData) interp);
return -1;
verify = verify;
}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Session Callback for Clients --
+ *
+ * Called when a new session ticket has been received. In TLS 1.3
+ * this may be received multiple times after the handshake. For
+ * earlier versions, this will be received during the handshake.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *-------------------------------------------------------------------
+ */
+static int
+SessionCallback(const 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;
+ int len;
+ int code;
+ size_t len2;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL)
+ return 0;
+
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("session", -1));
+
+ /* Session id */
+ session_id = SSL_SESSION_get0_id_context(session, &len);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(session_id, len));
+
+ /* Session ticket */
+ SSL_SESSION_get0_ticket(session, &ticket, &len2);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(ticket, (int)len2));
+
+ /* Lifetime - number of seconds */
+ Tcl_ListObjAppendElement(interp, cmdPtr,
+ Tcl_NewLongObj((long) SSL_SESSION_get_ticket_lifetime_hint(session)));
+
+ Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
+#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) interp);
+ return 1;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ALPN Callback for Servers --
+ *
+ * Select which protocol (http/1.1, h2, h3, etc.) to use for the
+ * incoming connection.
+ *
+ * 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(const 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;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL)
+ return SSL_TLSEXT_ERR_OK;
+
+ /* Select protocol */
+ SSL_select_next_proto(out, outlen, statePtr->protos, statePtr->protos_len, in, inlen);
+
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("alpn", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(*out, -1));
+
+ Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
+#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) interp);
+ return SSL_TLSEXT_ERR_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * SNI Callback for Servers --
+ *
+ * Perform server name selection
+ *
+ * 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 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;
+ char *servername = NULL;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL) {
+ return SSL_TLSEXT_ERR_OK;
+ } else if (ssl == NULL) {
+ return SSL_TLSEXT_ERR_NOACK;
+ }
+
+ servername = SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name);
+ if (!servername || servername[0] == '\0') {
+ return SSL_TLSEXT_ERR_NOACK;
+ }
+
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("sni", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(servername , -1));
+
+ Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
+#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) interp);
+ return SSL_TLSEXT_ERR_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Hello 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.
+ *
+ * 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(const SSL *ssl, int *alert, void *arg) {
+ State *statePtr = (State*)arg;
+ Tcl_Interp *interp = statePtr->interp;
+ Tcl_Obj *cmdPtr;
+ int code;
+ const char *servername;
+ const unsigned char *p;
+ size_t len, remaining;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL)
+ return SSL_CLIENT_HELLO_SUCCESS;
+
+ /* Get names */
+ if (!SSL_client_hello_get0_ext(ssl, TLSEXT_TYPE_server_name, &p, &remaining) || remaining <= 2) {
+ return SSL_CLIENT_HELLO_ERROR;
+ }
+
+ /* Extract the length of the supplied list of names. */
+ len = (*(p++) << 8);
+ len += *(p++);
+ if (len + 2 != remaining) {
+ 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) {
+ return SSL_CLIENT_HELLO_ERROR;
+ }
+ remaining--;
+
+ /* Now we can finally pull out the byte array with the actual hostname. */
+ if (remaining <= 2) {
+ return SSL_CLIENT_HELLO_ERROR;
+ }
+ len = (*(p++) << 8);
+ len += *(p++);
+ if (len + 2 > remaining) {
+ return SSL_CLIENT_HELLO_ERROR;
+ }
+ remaining = len;
+ servername = (const char *)p;
+
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("hello", -1));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(servername, (int)len));
+
+ Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) interp);
+ return SSL_CLIENT_HELLO_SUCCESS;
+}
+/********************/
+/* Commands */
+/********************/
+
/*
*-------------------------------------------------------------------
*
* CiphersObjCmd -- list available ciphers
*
@@ -488,68 +735,73 @@
* Side effects:
* constructs and destroys SSL context (CTX)
*
*-------------------------------------------------------------------
*/
+static const char *protocols[] = {
+ "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL
+};
+enum protocol {
+ TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE
+};
+
static int
CiphersObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- static const char *protocols[] = {
- "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL
- };
- enum protocol {
- TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE
- };
- Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr = NULL;
SSL_CTX *ctx = NULL;
SSL *ssl = NULL;
STACK_OF(SSL_CIPHER) *sk;
char *cp, buf[BUFSIZ];
- int index, verbose = 0;
+ int index, verbose = 0, use_supported = 0;
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;
+ }
+
switch ((enum protocol)index) {
case TLS_SSL2:
-#if OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
return TCL_ERROR;
#else
ctx = SSL_CTX_new(SSLv2_method()); break;
#endif
case TLS_SSL3:
-#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
+#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3) || defined(OPENSSL_NO_SSL3_METHOD)
Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
return TCL_ERROR;
#else
ctx = SSL_CTX_new(SSLv3_method()); break;
#endif
case TLS_TLS1:
-#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1) || defined(OPENSSL_NO_TLS1_METHOD)
Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
return TCL_ERROR;
#else
ctx = SSL_CTX_new(TLSv1_method()); break;
#endif
case TLS_TLS1_1:
-#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1_METHOD)
Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
return TCL_ERROR;
#else
ctx = SSL_CTX_new(TLSv1_1_method()); break;
#endif
case TLS_TLS1_2:
-#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2_METHOD)
Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
return TCL_ERROR;
#else
ctx = SSL_CTX_new(TLSv1_2_method()); break;
#endif
@@ -568,42 +820,111 @@
}
if (ctx == NULL) {
Tcl_AppendResult(interp, REASON(), NULL);
return TCL_ERROR;
}
+
ssl = SSL_new(ctx);
if (ssl == NULL) {
Tcl_AppendResult(interp, REASON(), NULL);
SSL_CTX_free(ctx);
return TCL_ERROR;
}
- objPtr = Tcl_NewListObj(0, NULL);
-
- if (!verbose) {
- for (index = 0; ; index++) {
- cp = (char*)SSL_get_cipher_list(ssl, index);
- if (cp == NULL) break;
- Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(cp, -1));
- }
+
+ /* Use list and order as would be sent in a ClientHello or all available ciphers */
+ if (use_supported) {
+ sk = SSL_get1_supported_ciphers(ssl);
} else {
sk = SSL_get_ciphers(ssl);
+ }
- for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) {
- register 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, (int) 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;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ProtocolsObjCmd -- list available protocols
+ *
+ * This procedure is invoked to process the "tls::protocols" command
+ * to list available protocols.
+ *
+ * Results:
+ * A standard Tcl result list.
+ *
+ * Side effects:
+ * none
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+ProtocolsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Obj *objPtr;
+
+ dprintf("Called");
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ objPtr = Tcl_NewListObj(0, NULL);
+
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL2], -1));
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL3], -1));
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1], -1));
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_1], -1));
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+ 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;
clientData = clientData;
}
@@ -641,13 +962,11 @@
chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
if (chan == (Tcl_Channel) NULL) {
return(TCL_ERROR);
}
- /*
- * Make sure to operate on the topmost channel
- */
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL);
return(TCL_ERROR);
}
@@ -718,29 +1037,29 @@
unsigned char *key = NULL;
int key_len = 0;
unsigned char *cert = NULL;
int cert_len = 0;
char *ciphers = NULL;
+ char *ciphersuites = NULL;
char *CAfile = NULL;
char *CAdir = NULL;
char *DHparams = NULL;
char *model = NULL;
-#ifndef OPENSSL_NO_TLSEXT
char *servername = NULL; /* hostname for Server Name Indication */
+ const unsigned char *session_id = NULL;
Tcl_Obj *alpn = NULL;
-#endif
int ssl2 = 0, ssl3 = 0;
int tls1 = 1, tls1_1 = 1, tls1_2 = 1, tls1_3 = 1;
- int proto = 0;
+ int proto = 0, level = -1;
int verify = 0, require = 0, request = 1;
dprintf("Called");
-#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(OPENSSL_NO_SSL2) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3) && defined(NO_SSL3) && !defined(NO_SSL2)
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(OPENSSL_NO_SSL2) && !defined(NO_SSL2) && defined(NO_SSL3) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3)
ssl2 = 1;
#endif
-#if !defined(OPENSSL_NO_SSL3) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3) && defined(NO_SSL2) && !defined(NO_SSL3)
+#if !defined(OPENSSL_NO_SSL3) && !defined(NO_SSL3) && defined(NO_SSL2) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3)
ssl3 = 1;
#endif
#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
tls1 = 0;
#endif
@@ -762,13 +1081,11 @@
chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
for (idx = 2; idx < objc; idx++) {
char *opt = Tcl_GetStringFromObj(objv[idx], NULL);
@@ -777,33 +1094,34 @@
OPTSTR("-cadir", CAdir);
OPTSTR("-cafile", CAfile);
OPTSTR("-certfile", certfile);
OPTSTR("-cipher", ciphers);
+ OPTSTR("-ciphers", ciphers);
+ OPTSTR("-ciphersuites", ciphersuites);
OPTOBJ("-command", script);
OPTSTR("-dhparams", DHparams);
OPTSTR("-keyfile", keyfile);
OPTSTR("-model", model);
OPTOBJ("-password", password);
OPTBOOL("-require", require);
OPTBOOL("-request", request);
+ OPTINT("-securitylevel", level);
OPTBOOL("-server", server);
-#ifndef OPENSSL_NO_TLSEXT
OPTSTR("-servername", servername);
+ OPTSTR("-session_id", session_id);
OPTOBJ("-alpn", alpn);
-#endif
-
OPTBOOL("-ssl2", ssl2);
OPTBOOL("-ssl3", ssl3);
OPTBOOL("-tls1", tls1);
OPTBOOL("-tls1.1", tls1_1);
OPTBOOL("-tls1.2", tls1_2);
OPTBOOL("-tls1.3", tls1_3);
OPTBYTE("-cert", cert, cert_len);
OPTBYTE("-key", key, key_len);
- OPTBAD("option", "-alpn, -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, -require, -request, -securitylevel, -server, -servername, -session_id, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, or -tls1.3");
return TCL_ERROR;
}
if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
@@ -820,10 +1138,11 @@
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 (DHparams && !*DHparams) DHparams = NULL;
/* new SSL state */
@@ -873,11 +1192,11 @@
return TCL_ERROR;
}
ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx;
} else {
if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, cert,
- key_len, cert_len, CAdir, CAfile, ciphers, DHparams)) == (SSL_CTX*)0) {
+ key_len, cert_len, CAdir, CAfile, ciphers, ciphersuites, level, DHparams)) == (SSL_CTX*)0) {
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
}
@@ -924,71 +1243,107 @@
Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), (char *) NULL);
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
-#ifndef OPENSSL_NO_TLSEXT
+ /* Set host server name */
if (servername) {
+ /* Sets the server name indication (SNI) ClientHello extension */
if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) {
Tcl_AppendResult(interp, "setting TLS host name extension failed", (char *) NULL);
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
+
+ /* Configure server host name checks in the SSL client. Set DNS hostname to
+ name for peer certificate checks. SSL_set1_host has limitations. */
+ if (!SSL_add1_host(statePtr->ssl, servername)) {
+ Tcl_AppendResult(interp, "setting DNS host name failed", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ }
+
+ /* Resume session id */
+ if (session_id && strlen(session_id) <= SSL_MAX_SID_CTX_LENGTH) {
+ /* SSL_set_session() */
+ if (!SSL_SESSION_set1_id_context(SSL_get_session(statePtr->ssl), session_id, (unsigned int) strlen(session_id))) {
+ Tcl_AppendResult(interp, "Resume session id ", session_id, " failed", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
}
+
if (alpn) {
/* Convert a Tcl list into a protocol-list in wire-format */
unsigned char *protos, *p;
- unsigned int protoslen = 0;
+ unsigned int protos_len = 0;
int i, len, cnt;
Tcl_Obj **list;
+
if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
+
/* Determine the memory required for the protocol-list */
for (i = 0; i < cnt; i++) {
Tcl_GetStringFromObj(list[i], &len);
if (len > 255) {
Tcl_AppendResult(interp, "alpn protocol name too long", (char *) NULL);
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
- protoslen += 1 + len;
+ protos_len += 1 + len;
}
+
/* Build the complete protocol-list */
- protos = ckalloc(protoslen);
+ protos = ckalloc(protos_len);
/* protocol-lists consist of 8-bit length-prefixed, byte strings */
for (i = 0, p = protos; i < cnt; i++) {
char *str = Tcl_GetStringFromObj(list[i], &len);
*p++ = len;
memcpy(p, str, 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, protoslen)) {
+ if (SSL_set_alpn_protos(statePtr->ssl, protos, protos_len)) {
Tcl_AppendResult(interp, "failed to set alpn protocols", (char *) NULL);
Tls_Free((char *) statePtr);
ckfree(protos);
return TCL_ERROR;
}
- /* SSL_set_alpn_protos makes a copy of the protocol-list */
- ckfree(protos);
+
+ /* Store protocols list */
+ statePtr->protos = protos;
+ statePtr->protos_len = protos_len;
+ } else {
+ statePtr->protos = NULL;
+ statePtr->protos_len = 0;
}
-#endif
/*
* 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_CTX_sess_set_new_cb(statePtr->ctx, SessionCallback);
/* 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_alpn_select_cb(statePtr->ctx, ALPNCallback, (void *)statePtr);
+ 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);
+
statePtr->flags |= TLS_TCL_SERVER;
SSL_set_accept_state(statePtr->ssl);
} else {
SSL_set_connect_state(statePtr->ssl);
}
@@ -1034,13 +1389,11 @@
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
"\": not a TLS channel", NULL);
@@ -1069,11 +1422,11 @@
*-------------------------------------------------------------------
*/
static SSL_CTX *
CTX_Init(State *statePtr, int isServer, int proto, char *keyfile, char *certfile,
unsigned char *key, unsigned char *cert, int key_len, int cert_len, char *CAdir,
- char *CAfile, char *ciphers, char *DHparams) {
+ 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;
@@ -1086,11 +1439,11 @@
Tcl_AppendResult(interp, "no valid protocol selected", NULL);
return (SSL_CTX *)0;
}
/* create SSL context */
-#if OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
if (ENABLED(proto, TLS_PROTO_SSL2)) {
Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
return (SSL_CTX *)0;
}
#endif
@@ -1124,31 +1477,31 @@
return (SSL_CTX *)0;
}
#endif
switch (proto) {
-#if OPENSSL_VERSION_NUMBER < 0x10101000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
case TLS_PROTO_SSL2:
method = SSLv2_method();
break;
#endif
-#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) && !defined(OPENSSL_NO_SSL3_METHOD)
case TLS_PROTO_SSL3:
method = SSLv3_method();
break;
#endif
-#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) && !defined(OPENSSL_NO_TLS1_METHOD)
case TLS_PROTO_TLS1:
method = TLSv1_method();
break;
#endif
-#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+#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();
break;
#endif
-#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+#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();
break;
#endif
#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
@@ -1160,16 +1513,12 @@
*/
method = TLS_method();
break;
#endif
default:
-#if OPENSSL_VERSION_NUMBER >= 0x10100000L
/* Negotiate highest available SSL/TLS version */
method = TLS_method();
-#else
- method = SSLv23_method();
-#endif
#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2);
#endif
#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3);
@@ -1201,34 +1550,43 @@
#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);
-
- if (!isServer) {
- SSL_CTX_set_options(ctx, SSL_OP_CIPHER_SERVER_PREFERENCE);
- }
}
#endif
+
+ /* 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, off); /* disable protocol versions */
#if OPENSSL_VERSION_NUMBER < 0x10101000L
SSL_CTX_set_mode(ctx, SSL_MODE_AUTO_RETRY); /* handle new handshakes in background */
#endif
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)) || \
+ ((ciphersuites != NULL) && !SSL_CTX_set_ciphersuites(ctx, ciphersuites))) {
+ Tcl_AppendResult(interp, "Set ciphers failed", (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+
+ /* 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);
@@ -1393,14 +1751,13 @@
X509 *peer;
Tcl_Obj *objPtr;
Tcl_Channel chan;
char *channelName, *ciphers;
int mode;
-#ifndef OPENSSL_NO_TLSEXT
const unsigned char *proto;
unsigned int len;
-#endif
+ char *peername = NULL;
dprintf("Called");
switch (objc) {
case 2:
@@ -1423,13 +1780,11 @@
chan = Tcl_GetChannel(interp, channelName, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- /*
- * Make sure to operate on the topmost channel
- */
+ /* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
"\": not a TLS channel", NULL);
return TCL_ERROR;
@@ -1445,28 +1800,231 @@
if (objc == 2) { X509_free(peer); }
} else {
objPtr = Tcl_NewListObj(0, NULL);
}
+ /* Peer cert chain (client only) */
+ STACK_OF(X509)* ssl_certs = SSL_get_peer_cert_chain(statePtr->ssl);
+ if (!peer && (ssl_certs == NULL || sk_X509_num(ssl_certs) == 0)) {
+ return TCL_ERROR;
+ }
+
+ /* Peer name from cert */
+ if (SSL_get_verify_result(statePtr->ssl) == X509_V_OK) {
+ peername = SSL_get0_peername(statePtr->ssl);
+ }
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("peername", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(peername, -1));
+
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("sbits", -1));
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_get_cipher_bits(statePtr->ssl, NULL)));
ciphers = (char*)SSL_get_cipher(statePtr->ssl);
if ((ciphers != NULL) && (strcmp(ciphers, "(NONE)") != 0)) {
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("cipher", -1));
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1));
}
-#ifndef OPENSSL_NO_TLSEXT
+ /* Verify the X509 certificate presented by the peer */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("validation", -1));
+ if (SSL_get_verify_result(statePtr->ssl) != X509_V_OK) {
+ /* proto = "failed"; */
+ proto = REASON();
+ } else {
+ proto = "ok";
+ }
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(proto, -1));
+
/* Report the selected protocol as a result of the negotiation */
SSL_get0_alpn_selected(statePtr->ssl, &proto, &len);
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1));
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj((char *)proto, (int)len));
-#endif
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("version", -1));
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_version(statePtr->ssl), -1));
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ConnectionInfoObjCmd -- return connection info from OpenSSL.
+ *
+ * Results:
+ * A list of connection info
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int ConnectionInfoObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Channel chan; /* The channel to set a mode on. */
+ State *statePtr; /* client state for ssl socket */
+ Tcl_Obj *objPtr;
+ const SSL *ssl;
+ const SSL_CIPHER *cipher;
+ const SSL_SESSION *session;
+ const unsigned char *proto;
+ unsigned int len;
+ long mode;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel");
+ return(TCL_ERROR);
+ }
+
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return(TCL_ERROR);
+ }
+
+ /* Make sure to operate on the topmost channel */
+ chan = Tcl_GetTopChannel(chan);
+ if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
+ Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL);
+ return(TCL_ERROR);
+ }
+
+ objPtr = Tcl_NewListObj(0, NULL);
+
+ /* Connection info */
+ statePtr = (State *)Tcl_GetChannelInstanceData(chan);
+ ssl = statePtr->ssl;
+ if (ssl != NULL) {
+ const char *state;
+
+ /* connection state */
+ if (SSL_is_init_finished(ssl)) {
+ state = "established";
+ } else if (SSL_in_init(ssl)) {
+ state = "handshake";
+ } else {
+ state = "initializing";
+ }
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("state", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(state, -1));
+
+ /* Get server name */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("servername", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name), -1));
+
+ /* Get protocol */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("protocol", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_version(ssl), -1));
+
+ /* Renegotiation allowed */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("renegotiation", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
+ SSL_get_secure_renegotiation_support(ssl) ? "supported" : "not supported", -1));
+
+ /* Report the selected protocol as a result of the ALPN negotiation */
+ SSL_get0_alpn_selected(ssl, &proto, &len);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj((char *)proto, (int)len));
+
+ /* Get security level */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("securitylevel", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_get_security_level(ssl)));
+ }
+
+ /* Cipher info */
+ cipher = SSL_get_current_cipher(ssl);
+ if (cipher != NULL) {
+ char buf[BUFSIZ] = {0};
+ int bits, alg_bits;
+
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("cipher", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_get_name(cipher), -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("standard_name", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_standard_name(cipher), -1));
+
+ bits = SSL_CIPHER_get_bits(cipher, &alg_bits);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("bits", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(bits));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("secret_bits", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(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) */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("min_version", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_get_version(cipher), -1));
+
+ if (SSL_CIPHER_description(cipher, buf, sizeof(buf)) != NULL) {
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("description", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1));
+ }
+ }
+
+ /* Session info */
+ session = SSL_get_session(ssl);
+ if (session != NULL) {
+ const unsigned char *ticket;
+ size_t len2;
+ const unsigned char *session_id;
+
+ /* Session info */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_reused", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_session_reused(ssl)));
+
+ /* Session id */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_id", -1));
+ session_id = SSL_SESSION_get_id(session, &len);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(session_id, (int)len));
+
+ /* Session ticket - client only */
+ SSL_SESSION_get0_ticket(session, &ticket, &len2);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_ticket", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(ticket, (int) len2));
+
+ /* Resumable session */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("resumable", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_SESSION_is_resumable(session)));
+
+ /* Start time */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("start_time", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewLongObj(SSL_SESSION_get_time(session)));
+
+ /* Timeout value */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("timeout", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewLongObj(SSL_SESSION_get_timeout(session)));
+ }
+
+ /* 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);
+
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("compression", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(comp ? SSL_COMP_get_name(comp) : "NONE", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("expansion", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(expn ? SSL_COMP_get_name(expn) : "NONE", -1));
+#else
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("compression", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("NONE", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("expansion", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("NONE", -1));
+#endif
+ }
+
+ /* Server info */
+ mode = SSL_CTX_get_session_cache_mode(statePtr->ctx);
+ if (mode & SSL_SESS_CACHE_OFF) {
+ proto = "off";
+ } else if (mode & SSL_SESS_CACHE_CLIENT) {
+ proto = "client";
+ } else if (mode & SSL_SESS_CACHE_SERVER) {
+ proto = "server";
+ } else if (mode & SSL_SESS_CACHE_BOTH) {
+ proto = "both";
+ } else {
+ proto = "unknown";
+ }
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_cache_mode", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(proto, -1));
+
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
clientData = clientData;
}
@@ -1542,13 +2100,11 @@
char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email="";
char *keyout,*pemout,*str;
int keysize,serial=0,days=365;
-#if OPENSSL_VERSION_NUMBER <= 0x10100000L
- RSA *rsa = NULL;
-#elif OPENSSL_VERSION_NUMBER < 0x30000000L
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
BIGNUM *bne = NULL;
RSA *rsa = NULL;
#else
EVP_PKEY_CTX *ctx = NULL;
#endif
@@ -1605,17 +2161,11 @@
return TCL_ERROR;
}
}
}
-#if OPENSSL_VERSION_NUMBER <= 0x10100000L
- pkey = EVP_PKEY_new();
- rsa = RSA_generate_key(keysize, 0x10001, NULL, NULL);
- if (pkey == NULL || rsa == NULL || !EVP_PKEY_assign_RSA(pkey, rsa)) {
- EVP_PKEY_free(pkey);
- /* RSA_free(rsa); freed by EVP_PKEY_free */
-#elif OPENSSL_VERSION_NUMBER < 0x30000000L
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
bne = BN_new();
rsa = RSA_new();
pkey = EVP_PKEY_new();
if (bne == NULL || rsa == NULL || pkey == NULL || !BN_set_word(bne,RSA_F4) ||
!RSA_generate_key_ex(rsa, keysize, bne, NULL) || !EVP_PKEY_assign_RSA(pkey, rsa)) {
@@ -1651,25 +2201,20 @@
}
if ((cert=X509_new())==NULL) {
Tcl_SetResult(interp,"Error generating certificate request",NULL);
EVP_PKEY_free(pkey);
-#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
BN_free(bne);
#endif
return(TCL_ERROR);
}
X509_set_version(cert,2);
ASN1_INTEGER_set(X509_get_serialNumber(cert),serial);
-#if OPENSSL_VERSION_NUMBER < 0x10100000L
- X509_gmtime_adj(X509_get_notBefore(cert),0);
- X509_gmtime_adj(X509_get_notAfter(cert),(long)60*60*24*days);
-#else
X509_gmtime_adj(X509_getm_notBefore(cert),0);
X509_gmtime_adj(X509_getm_notAfter(cert),(long)60*60*24*days);
-#endif
X509_set_pubkey(cert,pkey);
name=X509_get_subject_name(cert);
X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, (const unsigned char *) k_C, -1, -1, 0);
@@ -1683,11 +2228,11 @@
X509_set_subject_name(cert,name);
if (!X509_sign(cert,pkey,EVP_sha256())) {
X509_free(cert);
EVP_PKEY_free(pkey);
-#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
BN_free(bne);
#endif
Tcl_SetResult(interp,"Error signing certificate",NULL);
return TCL_ERROR;
}
@@ -1708,11 +2253,11 @@
BIO_free_all(out);
}
X509_free(cert);
EVP_PKEY_free(pkey);
-#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+#if OPENSSL_VERSION_NUMBER < 0x30000000L
BN_free(bne);
#endif
}
}
break;
@@ -1721,10 +2266,14 @@
}
return TCL_OK;
clientData = clientData;
}
+/********************/
+/* Init */
+/********************/
+
/*
*-------------------------------------------------------------------
*
* Tls_Free --
*
@@ -1776,10 +2325,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;
@@ -1845,16 +2398,18 @@
Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::connection", ConnectionInfoObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::protocols", ProtocolsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
if (interp) {
Tcl_Eval(interp, tlsTclInitScript);
}
@@ -1918,18 +2473,10 @@
dprintf("Asked to uninitialize");
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
Tcl_MutexLock(&init_mx);
-#if OPENSSL_VERSION_NUMBER < 0x10000000L
- CRYPTO_set_locking_callback(NULL);
- CRYPTO_set_id_callback(NULL);
-#elif OPENSSL_VERSION_NUMBER < 0x10100000L
- CRYPTO_set_locking_callback(NULL);
- CRYPTO_THREADID_set_callback(NULL)
-#endif
-
if (locks) {
free(locks);
locks = NULL;
locksCount = 0;
}
@@ -1954,46 +2501,19 @@
Tcl_MutexLock(&init_mx);
#endif
initialized = 1;
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
-#if OPENSSL_VERSION_NUMBER < 0x10100000L
- num_locks = CRYPTO_num_locks();
-#else
num_locks = 1;
-#endif
locksCount = (int) num_locks;
locks = malloc(sizeof(*locks) * num_locks);
memset(locks, 0, sizeof(*locks) * num_locks);
-
-#if OPENSSL_VERSION_NUMBER < 0x10000000L
- CRYPTO_set_locking_callback(CryptoThreadLockCallback);
- CRYPTO_set_id_callback(CryptoThreadIdCallback);
-#elif OPENSSL_VERSION_NUMBER < 0x10100000L
- CRYPTO_set_locking_callback(CryptoThreadLockCallback);
- CRYPTO_THREADID_set_callback(CryptoThreadIdCallback)
-#endif
-#endif
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
- if (SSL_library_init() != 1) {
- status = TCL_ERROR;
- goto done;
- }
-#else
+#endif
+
/* Initialize BOTH libcrypto and libssl. */
OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS | OPENSSL_INIT_LOAD_CRYPTO_STRINGS
| OPENSSL_INIT_ADD_ALL_CIPHERS | OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);
-#endif
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
- SSL_load_error_strings();
- ERR_load_crypto_strings();
-#else
- /* Only initialize libcrypto */
- OPENSSL_init_crypto(OPENSSL_INIT_LOAD_CRYPTO_STRINGS, NULL);
-#endif
BIO_new_tcl(NULL, 0);
#if 0
/*
@@ -2018,14 +2538,11 @@
}
RAND_seed(rnd_seed, sizeof(rnd_seed));
} while (RAND_status() != 1);
#endif
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
-done:
-#endif
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
Tcl_MutexUnlock(&init_mx);
#endif
return(status);
}
Index: generic/tlsBIO.c
==================================================================
--- generic/tlsBIO.c
+++ generic/tlsBIO.c
@@ -4,31 +4,10 @@
* Provides BIO layer to interface openssl to Tcl.
*/
#include "tlsInt.h"
-#ifdef TCLTLS_OPENSSL_PRE_1_1_API
-#define BIO_get_data(bio) ((bio)->ptr)
-#define BIO_get_init(bio) ((bio)->init)
-#define BIO_get_shutdown(bio) ((bio)->shutdown)
-#define BIO_set_data(bio, val) (bio)->ptr = (val)
-#define BIO_set_init(bio, val) (bio)->init = (val)
-#define BIO_set_shutdown(bio, val) (bio)->shutdown = (val)
-
-/* XXX: This assumes the variable being assigned to is BioMethods */
-#define BIO_meth_new(type_, name_) (BIO_METHOD *)Tcl_Alloc(sizeof(BIO_METHOD)); \
- memset(BioMethods, 0, sizeof(BIO_METHOD)); \
- BioMethods->type = type_; \
- BioMethods->name = name_;
-#define BIO_meth_set_write(bio, val) (bio)->bwrite = val;
-#define BIO_meth_set_read(bio, val) (bio)->bread = val;
-#define BIO_meth_set_puts(bio, val) (bio)->bputs = val;
-#define BIO_meth_set_ctrl(bio, val) (bio)->ctrl = val;
-#define BIO_meth_set_create(bio, val) (bio)->create = val;
-#define BIO_meth_set_destroy(bio, val) (bio)->destroy = val;
-#endif
-
static int BioWrite(BIO *bio, const char *buf, int bufLen) {
Tcl_Channel chan;
int ret;
int tclEofChan, tclErrno;
@@ -59,11 +38,11 @@
dprintf("We got some kind of I/O error");
if (tclErrno == EAGAIN) {
dprintf("It's EAGAIN");
} else {
- dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
+ dprintf("It's an unexpected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
}
} else {
dprintf("Successfully wrote some data");
}
@@ -114,11 +93,11 @@
dprintf("We got some kind of I/O error");
if (tclErrno == EAGAIN) {
dprintf("It's EAGAIN");
} else {
- dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
+ dprintf("It's an unexpected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno);
}
} else {
dprintf("Successfully read some data");
}
Index: generic/tlsIO.c
==================================================================
--- generic/tlsIO.c
+++ generic/tlsIO.c
@@ -97,11 +97,11 @@
/*
*------------------------------------------------------*
*
* Tls_WaitForConnect --
*
- * Sideeffects:
+ * Side effects:
* Issues SSL_accept or SSL_connect
*
* Result:
* None.
*
@@ -157,10 +157,11 @@
}
rc = SSL_get_error(statePtr->ssl, err);
dprintf("Got error: %i (rc = %i)", err, rc);
+ dprintf("Got error: %s", ERR_reason_error_string(ERR_get_error()));
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;
@@ -800,11 +801,11 @@
* Handler called by Tcl as a result of
* Tcl_CreateChannelHandler - to inform us of activity
* on the underlying channel.
* ------------------------------------------------*
*
- * Sideeffects:
+ * Side effects:
* May generate subsequent calls to
* Tcl_NotifyChannel.
*
* Result:
* None.
@@ -874,11 +875,11 @@
* ------------------------------------------------*
* Called by the notifier (-> timer) to flush out
* information waiting in channel buffers.
* ------------------------------------------------*
*
- * Sideeffects:
+ * Side effects:
* As of 'TlsChannelHandler'.
*
* Result:
* None.
*
Index: generic/tlsInt.h
==================================================================
--- generic/tlsInt.h
+++ generic/tlsInt.h
@@ -32,34 +32,15 @@
/* Handle TCL 8.6 CONST changes */
#ifndef CONST86
#define CONST86
#endif
-#ifdef NO_PATENTS
-# define NO_IDEA
-# define NO_RC2
-# define NO_RC4
-# define NO_RC5
-# define NO_RSA
-# ifndef NO_SSL2
-# define NO_SSL2
-# endif
-#endif
-
#include <openssl/ssl.h>
#include <openssl/err.h>
#include <openssl/rand.h>
#include <openssl/opensslv.h>
-/*
- * Determine if we should use the pre-OpenSSL 1.1.0 API
- */
-#undef TCLTLS_OPENSSL_PRE_1_1
-#if (defined(LIBRESSL_VERSION_NUMBER)) || OPENSSL_VERSION_NUMBER < 0x10100000L
-# define TCLTLS_OPENSSL_PRE_1_1_API 1
-#endif
-
#ifndef ECONNABORTED
#define ECONNABORTED 130 /* Software caused connection abort */
#endif
#ifndef ECONNRESET
#define ECONNRESET 131 /* Connection reset by peer */
@@ -147,10 +128,13 @@
int vflags; /* verify flags */
SSL *ssl; /* Struct for SSL processing */
SSL_CTX *ctx; /* SSL Context */
BIO *bio; /* Struct for SSL processing */
BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */
+
+ char *protos; /* List of supported protocols in protocol format */
+ unsigned int protos_len; /* Length of protos */
char *err;
} State;
#ifdef USE_TCL_STUBS
Index: generic/tlsX509.c
==================================================================
--- generic/tlsX509.c
+++ generic/tlsX509.c
@@ -1,8 +1,9 @@
/*
* 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>
@@ -100,20 +101,21 @@
char serial[BUFSIZ];
char notBefore[BUFSIZ];
char notAfter[BUFSIZ];
char certStr[CERT_STR_SIZE], *certStr_p;
int certStr_len, toRead;
-#ifndef NO_SSL_SHA
char sha1_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1];
unsigned char sha1_hash_binary[SHA_DIGEST_LENGTH];
char sha256_hash_ascii[SHA256_DIGEST_LENGTH * 2 + 1];
unsigned char sha256_hash_binary[SHA256_DIGEST_LENGTH];
const char *shachars="0123456789ABCDEF";
+ int nid, pknid, bits;
+ long version;
+ uint32_t xflags;
sha1_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0';
sha256_hash_ascii[SHA256_DIGEST_LENGTH * 2] = '\0';
-#endif
certStr[0] = 0;
if ((bio = BIO_new(BIO_s_mem())) == NULL) {
subject[0] = 0;
issuer[0] = 0;
@@ -162,52 +164,66 @@
}
BIO_free(bio);
}
-#if OPENSSL_VERSION_NUMBER < 0x10100000L
- strcpy(notBefore, ASN1_UTCTIME_tostr(X509_get_notBefore(cert)));
- strcpy(notAfter, ASN1_UTCTIME_tostr(X509_get_notAfter(cert)));
-#else
strcpy(notBefore, ASN1_UTCTIME_tostr(X509_getm_notBefore(cert)));
strcpy(notAfter, ASN1_UTCTIME_tostr(X509_getm_notAfter(cert)));
-#endif
+
+ /* Version */
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("version", -1));
+ version = X509_get_version(cert)+1;
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewLongObj(version));
-#ifndef NO_SSL_SHA
- /* SHA1 */
+ /* Signature NID */
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("signature_nid", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewIntObj(X509_get_signature_nid(cert)));
+
+ if (X509_get_signature_info(cert, &nid, &pknid, &bits, &xflags) == 1) {
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("digest_nid", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewIntObj(nid));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("public_key_nid", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewIntObj(pknid));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("bits", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewIntObj(bits));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("extension_flags", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewIntObj(xflags));
+ }
+
+ /* SHA1 - DER representation*/
X509_digest(cert, EVP_sha1(), sha1_hash_binary, NULL);
for (int n = 0; n < SHA_DIGEST_LENGTH; n++) {
sha1_hash_ascii[n*2] = shachars[(sha1_hash_binary[n] & 0xF0) >> 4];
sha1_hash_ascii[n*2+1] = shachars[(sha1_hash_binary[n] & 0x0F)];
}
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha1_hash_ascii, SHA_DIGEST_LENGTH * 2) );
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("sha1_hash", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj(sha1_hash_ascii, SHA_DIGEST_LENGTH * 2));
- /* SHA256 */
+ /* SHA256 - DER representation */
X509_digest(cert, EVP_sha256(), sha256_hash_binary, NULL);
for (int n = 0; n < SHA256_DIGEST_LENGTH; n++) {
sha256_hash_ascii[n*2] = shachars[(sha256_hash_binary[n] & 0xF0) >> 4];
sha256_hash_ascii[n*2+1] = shachars[(sha256_hash_binary[n] & 0x0F)];
}
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "sha256_hash", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( sha256_hash_ascii, SHA256_DIGEST_LENGTH * 2) );
-#endif
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "subject", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( subject, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "issuer", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( issuer, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "notBefore", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( notBefore, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "notAfter", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( notAfter, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "serial", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( serial, -1) );
-
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "certificate", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( certStr, -1) );
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("sha256_hash", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( sha256_hash_ascii, SHA256_DIGEST_LENGTH * 2));
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("subject", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( subject, -1));
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("issuer", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( issuer, -1));
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("notBefore", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( notBefore, -1));
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("notAfter", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( notAfter, -1));
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("serial", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( serial, -1));
+
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj("certificate", -1));
+ Tcl_ListObjAppendElement(interp, certPtr, Tcl_NewStringObj( certStr, -1));
return certPtr;
}
Index: library/tls.tcl
==================================================================
--- library/tls.tcl
+++ library/tls.tcl
@@ -35,19 +35,22 @@
{* -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}
{* -request iopts 1}
{* -require iopts 1}
+ {* -securitylevel iopts 1}
{* -autoservername discardOpts 1}
{* -servername iopts 1}
+ {* -session_id iopts 1}
{* -alpn iopts 1}
{* -ssl2 iopts 1}
{* -ssl3 iopts 1}
{* -tls1 iopts 1}
{* -tls1.1 iopts 1}
ADDED tests/README.txt
Index: tests/README.txt
==================================================================
--- /dev/null
+++ tests/README.txt
@@ -0,0 +1,17 @@
+Create Test Cases
+
+1. Create 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. Each column defines the equivalent input the tcltest tool expects.
+
+3. Define any common functions in 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. The results will be output to the stdoutlog.txt file.
+ On Windows you can also use the run_all_tests.bat file.
+
+6. Review stdoutlog.txt for the count of test cases executed successfully and view details of those that failed.
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/ciphers.csv
Index: tests/ciphers.csv
==================================================================
--- /dev/null
+++ tests/ciphers.csv
@@ -0,0 +1,46 @@
+# Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes
+command,package require tls,,,,,,,,,
+command,,,,,,,,,,
+command,# Make sure path includes location of OpenSSL executable,,,,,,,,,
+command,"if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin] "";"" $::env(path)}",,,,,,,,,
+command,,,,,,,,,,
+command,# Constraints,,,,,,,,,
+command,set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3],,,,,,,,,
+command,foreach protocol $protocols {::tcltest::testConstraint $protocol 0},,,,,,,,,
+command,foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1},,,,,,,,,
+command,"::tcltest::testConstraint OpenSSL [string match ""OpenSSL*"" [::tls::version]]",,,,,,,,,
+,,,,,,,,,,
+command,# Helper functions,,,,,,,,,
+command,"proc lcompare {list1 list2} {set m """";set u """";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list ""missing"" $m ""unexpected"" $u]}",,,,,,,,,
+command,proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]},,,,,,,,,
+,,,,,,,,,,
+command,# Test protocols,,,,,,,,,
+Protocols,All,,,lcompare $protocols [::tls::protocols],,,missing {ssl2 ssl3} unexpected {},,,
+,,,,,,,,,,
+command,# Test ciphers,,,,,,,,,
+CiphersAll,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2] [::tls::ciphers ssl2]",,,missing {} unexpected {},,,
+CiphersAll,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3] [::tls::ciphers ssl3]",,,missing {} unexpected {},,,
+CiphersAll,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1] [::tls::ciphers tls1]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1] [::tls::ciphers tls1.1]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2] [::tls::ciphers tls1.2]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3] [::tls::ciphers tls1.3]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test cipher descriptions,,,,,,,,,
+CiphersDesc,SSL2,ssl2,,"lcompare [exec_get ""\r\n"" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,SSL3,ssl3,,"lcompare [exec_get ""\r\n"" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1,tls1,,"lcompare [exec_get ""\r\n"" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.1,tls1.1,,"lcompare [exec_get ""\r\n"" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.2,tls1.2,,"lcompare [exec_get ""\r\n"" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.3,tls1.3,,"lcompare [exec_get ""\r\n"" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test protocol specific ciphers,,,,,,,,,
+CiphersSpecific,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test version,,,,,,,,,
+Version,All,,,::tls::version,,glob,*,,,
+Version,OpenSSL,OpenSSL,,::tls::version,,glob,OpenSSL*,,,
Index: tests/ciphers.test
==================================================================
--- tests/ciphers.test
+++ tests/ciphers.test
@@ -1,157 +1,121 @@
-# Commands covered: tls::ciphers
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-
-# All rights reserved.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import ::tcltest::*
-}
-
-# The build dir is added as the first element of $PATH
+# Auto generated test cases for ciphers_and_protocols.csv
+
+# Load Tcl Test package
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]
+
package require tls
-# One of these should == 1, depending on what type of ssl library
-# tls was compiled against. (RSA BSAFE SSL-C or OpenSSL).
-#
-set ::tcltest::testConstraints(rsabsafe) 0
-set ::tcltest::testConstraints(openssl) [string match "OpenSSL*" [tls::version]]
-
-set ::EXPECTEDCIPHERS(rsabsafe) {
- EDH-DSS-RC4-SHA
- EDH-RSA-DES-CBC3-SHA
- EDH-DSS-DES-CBC3-SHA
- DES-CBC3-SHA
- RC4-SHA
- RC4-MD5
- EDH-RSA-DES-CBC-SHA
- EDH-DSS-DES-CBC-SHA
- DES-CBC-SHA
- EXP-EDH-DSS-DES-56-SHA
- EXP-EDH-DSS-RC4-56-SHA
- EXP-DES-56-SHA
- EXP-RC4-56-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
-}
-
-set ::EXPECTEDCIPHERS(openssl) {
- AES128-SHA
- AES256-SHA
- DES-CBC-SHA
- DES-CBC3-SHA
- DHE-DSS-AES128-SHA
- DHE-DSS-AES256-SHA
- DHE-DSS-RC4-SHA
- DHE-RSA-AES128-SHA
- DHE-RSA-AES256-SHA
- EDH-DSS-DES-CBC-SHA
- EDH-DSS-DES-CBC3-SHA
- EDH-RSA-DES-CBC-SHA
- EDH-RSA-DES-CBC3-SHA
- EXP-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
- EXP1024-DES-CBC-SHA
- EXP1024-DHE-DSS-DES-CBC-SHA
- EXP1024-DHE-DSS-RC4-SHA
- EXP1024-RC2-CBC-MD5
- EXP1024-RC4-MD5
- EXP1024-RC4-SHA
- IDEA-CBC-SHA
- RC4-MD5
- RC4-SHA
-}
-
-set ::EXPECTEDCIPHERS(openssl0.9.8) {
- DHE-RSA-AES256-SHA
- DHE-DSS-AES256-SHA
- AES256-SHA
- EDH-RSA-DES-CBC3-SHA
- EDH-DSS-DES-CBC3-SHA
- DES-CBC3-SHA
- DHE-RSA-AES128-SHA
- DHE-DSS-AES128-SHA
- AES128-SHA
- IDEA-CBC-SHA
- RC4-SHA
- RC4-MD5
- EDH-RSA-DES-CBC-SHA
- EDH-DSS-DES-CBC-SHA
- DES-CBC-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
-}
-
-set version ""
-if {[string match "OpenSSL*" [tls::version]]} {
- regexp {OpenSSL ([\d\.]+)} [tls::version] -> version
-}
-if {![info exists ::EXPECTEDCIPHERS(openssl$version)]} {
- set version ""
-}
-
-proc listcompare {wants haves} {
- array set want {}
- array set have {}
- foreach item $wants { set want($item) 1 }
- foreach item $haves { set have($item) 1 }
- foreach item [lsort -dictionary [array names have]] {
- if {[info exists want($item)]} {
- unset want($item) have($item)
- }
- }
- if {[array size want] || [array size have]} {
- return [list MISSING [array names want] UNEXPECTED [array names have]]
- }
-}
-
-test ciphers-1.1 {Tls::ciphers for ssl3} {rsabsafe} {
- # This will fail if you compiled against OpenSSL.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers ssl3]
-} {}
-
-test ciphers-1.2 {Tls::ciphers for tls1} {rsabsafe} {
- # This will fail if you compiled against OpenSSL.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers tls1]
-} {}
-
-test ciphers-1.3 {Tls::ciphers for ssl3} {openssl} {
- # This will fail if you compiled against RSA bsafe or with a
- # different set of defines than the default.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers ssl3]
-} {}
-
-# This version of the test is correct for OpenSSL only.
-# An equivalent test for the RSA BSAFE SSL-C is earlier in this file.
-
-test ciphers-1.4 {Tls::ciphers for tls1} {openssl} {
- # This will fail if you compiled against RSA bsafe or with a
- # different set of defines than the default.
- # Change the constraint setting in all.tcl
- listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers tls1]
-} {}
-
-
-# cleanup
+# Make sure path includes location of OpenSSL executable
+if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin] ";" $::env(path)}
+
+# Constraints
+set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3]
+foreach protocol $protocols {::tcltest::testConstraint $protocol 0}
+foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1}
+::tcltest::testConstraint OpenSSL [string match "OpenSSL*" [::tls::version]]
+# Helper functions
+proc lcompare {list1 list2} {set m "";set u "";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list "missing" $m "unexpected" $u]}
+proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]}
+# Test protocols
+
+
+test Protocols-1.1 {All} -body {
+ lcompare $protocols [::tls::protocols]
+ } -result {missing {ssl2 ssl3} unexpected {}}
+# Test ciphers
+
+
+test CiphersAll-2.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get ":" ciphers -ssl2] [::tls::ciphers ssl2]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get ":" ciphers -ssl3] [::tls::ciphers ssl3]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get ":" ciphers -tls1] [::tls::ciphers tls1]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get ":" ciphers -tls1_1] [::tls::ciphers tls1.1]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get ":" ciphers -tls1_2] [::tls::ciphers tls1.2]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get ":" ciphers -tls1_3] [::tls::ciphers tls1.3]
+ } -result {missing {} unexpected {}}
+# Test cipher descriptions
+
+
+test CiphersDesc-3.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get "\r\n" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get "\r\n" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]
+ } -result {missing {} unexpected {}}
+# Test protocol specific ciphers
+
+
+test CiphersSpecific-4.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get ":" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get ":" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get ":" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get ":" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get ":" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get ":" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]
+ } -result {missing {} unexpected {}}
+# Test version
+
+
+test Version-5.1 {All} -body {
+ ::tls::version
+ } -match {glob} -result {*}
+
+test Version-5.2 {OpenSSL} -constraints {OpenSSL} -body {
+ ::tls::version
+ } -match {glob} -result {OpenSSL*}
+
+# Cleanup
::tcltest::cleanupTests
return
ADDED tests/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]
@@ -2012,15 +2012,13 @@
proc accept {s a p} {
fconfigure $s -blocking 0
fileevent $s readable [list do_handshake $s readable readlittle \
-buffering none]
}
- set s [tls::socket \
- -certfile $serverCert -cafile $caCert -keyfile $serverKey \
+ set s [tls::socket -certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 8831]
- set c [tls::socket \
- -certfile $clientCert -cafile $caCert -keyfile $clientKey \
+ set c [tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey \
localhost 8831]
# only the client gets tls::import
set res [tls::unimport $c]
list $res [catch {close $c} err] $err \
[catch {close $s} err] $err
@@ -2041,18 +2039,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]
+ set c [tls::socket -async -cafile $caCert -request 0 -require 0 \
+ -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 0 -tls1.2 0 -tls1.3 0 localhost 8831]
fconfigure $c -blocking 0
puts $c a ; flush $c
after 5000 [list set ::done timeout]
vwait ::done
switch -exact -- $::done {