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,125 @@ 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>-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>-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 @@ -154,123 +251,68 @@ <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>server</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>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>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>session_reused</strong> <em>boolean</em></dt> + <dd>Whether the session has been reused or not.</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> 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 @@ -41,11 +42,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, char *DHparams); static int TlsLibInit(int uninitialize); #define TLS_PROTO_SSL2 0x01 #define TLS_PROTO_SSL3 0x02 @@ -488,40 +489,45 @@ * 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 @@ -568,42 +574,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, 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; } @@ -718,10 +793,11 @@ 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 @@ -777,10 +853,11 @@ OPTSTR("-cadir", CAdir); OPTSTR("-cafile", CAfile); OPTSTR("-certfile", certfile); OPTSTR("-cipher", ciphers); + OPTSTR("-ciphersuites", ciphersuites); OPTOBJ("-command", script); OPTSTR("-dhparams", DHparams); OPTSTR("-keyfile", keyfile); OPTSTR("-model", model); OPTOBJ("-password", password); @@ -799,11 +876,11 @@ 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, -server, -servername, -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 +897,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 +951,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, DHparams)) == (SSL_CTX*)0) { Tls_Free((char *) statePtr); return TCL_ERROR; } } @@ -935,11 +1013,11 @@ } } 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; @@ -950,23 +1028,23 @@ 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; } /* 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; } @@ -1069,11 +1147,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, char *DHparams) { Tcl_Interp *interp = statePtr->interp; SSL_CTX *ctx = NULL; Tcl_DString ds; Tcl_DString ds1; int off = 0; @@ -1086,11 +1164,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,11 +1202,11 @@ 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) @@ -1216,12 +1294,17 @@ #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 and cipher suites */ + 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 some callbacks */ SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback); #ifndef BSAFE @@ -1462,10 +1545,136 @@ 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; + +#if !defined(OPENSSL_NO_TLSEXT) && OPENSSL_VERSION_NUMBER >= 0x10002000L + const unsigned char *proto; + unsigned int len; +#endif +#if defined(HAVE_SSL_COMPRESSION) && OPENSSL_VERSION_NUMBER >= 0x10002000L + const COMP_METHOD *comp; +#endif + + 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); + + /* Get connection state */ + statePtr = (State *)Tcl_GetChannelInstanceData(chan); + ssl = statePtr->ssl; + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("state", -1)); + if (SSL_is_init_finished(ssl)) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("established", -1)); + } else if (SSL_in_init(ssl)) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("handshake", -1)); + } else { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("initializing", -1)); + } + + /* Get server name */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("server", -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)); + + /* Get cipher */ + 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)); + } + } + + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("renegotiation", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + SSL_get_secure_renegotiation_support(ssl) ? "allowed" : "disallowed", -1)); + +#if !defined(OPENSSL_NO_TLSEXT) && OPENSSL_VERSION_NUMBER >= 0x10002000L + /* Report the selected protocol as a result of the 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)); +#endif + + /* Session info */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_reused", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_session_reused(ssl))); + +#if defined(HAVE_SSL_COMPRESSION) && OPENSSL_VERSION_NUMBER >= 0x10002000L + /* Compression info */ + comp = SSL_get_current_compression(ssl); + if (comp != NULL) { + expansion = SSL_get_current_expansion(ssl); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("compression", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_COMP_get_name(comp), -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("expansion", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_COMP_get_name(expansion), -1)); + } +#endif Tcl_SetObjResult(interp, objPtr); return TCL_OK; clientData = clientData; } @@ -1845,16 +2054,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); } Index: library/tls.tcl ================================================================== --- library/tls.tcl +++ library/tls.tcl @@ -35,10 +35,11 @@ {* -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} 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 {