Index: doc/tls.html ================================================================== --- doc/tls.html +++ doc/tls.html @@ -11,28 +11,29 @@
NAME
-
tls - binding to OpenSSL - toolkit.
-
+
tls - binding to OpenSSL toolkit.
+
SYNOPSIS
-
package require Tcl ?8.4?
-
package require tls ?@@VERS@@?
+
package require Tcl ?8.4?
+
package require tls
+
 
+
tls::init ?options?
+
tls::socket ?options? host port
+
tls::socket ?-server command? ?options? port
+
tls::handshake channel
+
tls::status ?-local? channel
+
tls::connection channel
+
tls::import channel ?options?
+
tls::unimport channel
 
-
tls::init ?options?
-
tls::socket ?options? host port
-
tls::socket ?-server command? - ?options? port
-
tls::handshake channel
-
tls::status ?-local? channel
-
tls::import channel ?options?
-
tls::unimport channel
-
tls::ciphers protocol ?verbose?
+
tls::ciphers protocol ?verbose? ?supported?
+
tls::protocols
tls::version
COMMANDS
CALLBACK OPTIONS
@@ -49,23 +50,23 @@ toolkit.

SYNOPSIS

package require Tcl 8.4
-package require tls @@VERS@@
-
-tls::init ?options?
-tls::socket ?options? host -port
-tls::socket ?-server command? ?options? port
-tls::status ?-local? channel
-tls::handshake channel
-
-tls::import channel ?options?
-tls::unimport channel
-tls::ciphers -protocol ?verbose?
+package require tls
+
+tls::init ?options?
+tls::socket ?options? host port
+tls::socket ?-server command? ?options? port
+tls::status ?-local? channel
+tls::connection channel
+tls::handshake channel
+tls::import channel ?options?
+tls::unimport channel
+
+tls::ciphers protocol ?verbose? ?supported?
+tls::protocols tls::version

DESCRIPTION

@@ -84,12 +85,12 @@ command. In such cases tls::import should not be used directly.

tls::init ?options?
-
This routine sets the default options used by tls::socket - and is optional. If you call tls::import +
Optional function to set the default options used by + tls::socket. If you call tls::import directly this routine has no effect. Any of the options that tls::socket accepts can be set using this command, though you should limit your options to only TLS related ones.
 
@@ -104,29 +105,134 @@ options with one additional option:
-autoservername bool
Automatically send the -servername as the host argument - (default: false)
+ (default is false) +
+
+ +
tls::import channel + ?options?
+
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.
+ +
+
+
-alpn list
+
List of protocols to offer during Application-Layer + Protocol Negotiation (ALPN). For example: h2, http/1.1, etc.
+
-cadir dir
+
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 SSL_CERT_DIR + environment variable.
+
-cafile filename
+
Specify the certificate authority (CA) file to use.
+
-certfile filename
+
Specify the filename containing the certificate to use. The + default name is cert.pem. This can be overridden via + the SSL_CERT_FILE environment variable.
+
-cert filename
+
Specify the contents of a certificate to use, as a DER + encoded binary value (X.509 DER).
+
-cipher string
+
List of ciphers to use. String is a colon (":") separated list + of ciphers or cipher suites. Cipher suites can be combined + using the + character. Prefixes can be used to permanently + remove ("!"), delete ("-"), or move a cypher to the end of + the list ("+"). Keywords @STRENGTH (sort by algorithm + key length), @SECLEVEL=n (set security level to + n), and DEFAULT (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)
+
-ciphersuites string
+
List of cipher suites to use. String is a colon (":") + separated list of cipher suite names. (TLS 1.3 only)
+
-command callback
+
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 CALLBACK OPTIONS + for further discussion.
+
-dhparams filename
+
Specify the Diffie-Hellman parameters file.
+
-keyfile filename
+
Specify the private key file. (default is + value of -certfile)
+
-key filename
+
Specify the private key to use as a DER encoded value (PKCS#1 DER)
+
-model channel
+
Force this channel to share the same SSL_CTX + structure as the specified channel, and + therefore share callbacks etc.
+
-password callback
+
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 CALLBACK OPTIONS + for further discussion.
+
-request bool
+
Request a certificate from peer during SSL handshake. + (default is true)
+
-require bool
+
Require a valid certificate from peer during SSL handshake. + If this is set to true, then -request must + also be set to true. (default is false)
+
-securitylevel integer
+
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.
+
-server bool
+
Handshake as server if true, else handshake as + client. (default is false)
+
-servername host
+
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.
+
-session_id string
+
Session id to resume session.
+
-ssl2 bool
+
Enable use of SSL v2. (default is false)
+
-ssl3 bool
+
Enable use of SSL v3. (default is false)
+
-tls1 bool
+
Enable use of TLS v1. (default is true)
+
-tls1.1 bool
+
Enable use of TLS v1.1 (default is true)
+
-tls1.2 bool
+
Enable use of TLS v1.2 (default is true)
+
-tls1.3 bool
+
Enable use of TLS v1.3 (default is true)
+ +
tls::unimport channel
+
Provided for symmetry to tls::import, this + unstacks the SSL-enabling of a regular Tcl channel. An error + is thrown if TLS is not the top stacked channel type.
 
tls::handshake channel
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.
 
tls::status ?-local? channel
-
Returns the current security status of an SSL channel. The +
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 -local is given, then the certificate information is the one used locally.
-
issuer dn
The distinguished name (DN) of the certificate @@ -149,128 +255,93 @@
The PEM encoded certificate.
sha1_hash hash
The SHA1 hash of the certificate.
sha256_hash hash
The SHA256 hash of the certificate.
+
validation result
+
Certificate validation result.
alpn protocol
The protocol selected after Application-Layer Protocol Negotiation (ALPN).
version value
The protocol version used for the connection: - SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, unknown
+ SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, or unknown
-
-
tls::import channel - ?options?
-
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.
-
+
tls::connection + channel
+
Returns the current connection status of an SSL channel. The + result is a list of key-value pairs describing the + connected peer.
-
-alpn list
-
List of protocols to offer during Application-Layer - Protocol Negotiation (ALPN). For example: h2, http/1.1, etc.
-
-cadir dir
-
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 SSL_CERT_DIR - environment variable.
-
-cafile filename
-
Provide the CA file.
-
-certfile filename
-
Provide the name of a file containing certificate to use. - The default name is cert.pem. This can be overridden via the - SSL_CERT_FILE environment variable.
-
-cert filename
-
Provide the contents of a certificate to use, as a DER encoded binary value (X.509 DER).
-
-cipher string
-
Provide the cipher suites to use. Syntax is as per - OpenSSL.
-
-command callback
-
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. -
- See CALLBACK OPTIONS for - further discussion.
-
-dhparams filename
-
Provide a Diffie-Hellman parameters file.
-
-keyfile filename
-
Provide the private key file. (default: - value of -certfile)
-
-key filename
-
Provide the private key to use as a DER encoded value (PKCS#1 DER)
-
-model channel
-
This will force this channel to share the same SSL_CTX - structure as the specified channel, and - therefore share callbacks etc.
-
-password callback
-
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. -
- See CALLBACK OPTIONS for - further discussion.
-
-request bool
-
Request a certificate from peer during SSL handshake. - (default: true)
-
-require bool
-
Require a valid certificate from peer during SSL - handshake. If this is set to true then -request - must also be set to true. (default: false)
-
-server bool
-
Handshake as server if true, else handshake as - client.(default: false)
-
-servername host
-
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
-
-ssl2 bool
-
Enable use of SSL v2. (default: false)
-
-ssl3 bool
-
Enable use of SSL v3. (default: false)
-
-tls1 bool
-
Enable use of TLS v1. (default: true)
-
-tls1.1 bool
-
Enable use of TLS v1.1 (default: true)
-
-tls1.2 bool
-
Enable use of TLS v1.2 (default: true)
-
-tls1.3 bool
-
Enable use of TLS v1.3 (default: true)
+
state state
+
State of the connection: initializing, handshake, established
+
servername name
+
The name of the connected to server.
+
protocol version
+
The protocol version used for the connection: + SSL2, SSL3, TLS1, TLS1.1, TLS1.2, TLS1.3, or unknown.
+
renegotiation state
+
Whether protocol renegotiation is allowed or disallowed.
+
alpn protocol
+
The protocol selected after Application-Layer Protocol + Negotiation (ALPN).
+
securitylevel level
+
The security level used for selection of ciphers, key size, etc.
+
cipher cipher
+
The current cipher in use for the connection.
+
standard_name name
+
The standard RFC name of cipher.
+
bits n
+
The number of processed bits used for cipher.
+
secret_bits n
+
The number of secret bits used for cipher.
+
min_version version
+
The minimum protocol version for cipher.
+
description string
+
A text description of the cipher.
+
session_reused boolean
+
Whether the session has been reused or not.
+
session_id string
+
Unique session id for use in resuming the session.
+
session_ticket string
+
Unique session ticket for use in resuming the session.
+
resumable boolean
+
Can the session be resumed or not.
+
start_time seconds
+
Time since session started in seconds since epoch.
+
timeout seconds
+
Max duration of session in seconds before time-out.
+
compression mode
+
Compression method.
+
expansion mode
+
Expansion method.
+
session_cache_mode mode
+
Server cache mode (client, server, or both).
-
-
tls::unimport channel
-
Provided for symmetry to tls::import, this - unstacks the SSL-enabling of a regular Tcl channel. An error - is thrown if TLS is not the top stacked channel type.
-
- -
-
tls::ciphers - protocol ?verbose?
-
Returns list of supported ciphers based on the protocol - you supply, which must be one of ssl2, ssl3, or tls1. - If verbose 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.
-
- -
+
tls::ciphers + protocol ?verbose? ?supported?
+
Returns a list of supported ciphers available for protocol, + where protocol must be one of ssl2, ssl3, tls1, tls1.1, + tls1.2, or tls1.3. If verbose is specified as + true then a verbose, human readable list is returned with + additional information on the cipher. If supported + is specified as true, then only the ciphers supported for protocol + will be listed.
+ +
tls::protocols
+
Returns a list of supported protocols. Valid values are: + ssl2, ssl3, tls1, tls1.1, tls1.2, + and tls1.3.
+
tls::version
-
Returns the version string defined by OpenSSL.
+
Returns the OpenSSL version string.

CALLBACK OPTIONS

@@ -294,10 +365,21 @@

+ +
+ alpn protocol +
+
+ 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. +
+ +
+ +
+ hello servername +
+
+ This form of callback is invoked during client hello message processing. +
+ +
info channel major minor message
@@ -331,10 +422,35 @@ SSL_state_string_long() or by SSL_alert_desc_string_long(), depending on context.
+
+ +
+ session session_id ticket lifetime +
+
+ This form of callback is invoked by the OpenSSL function + SSL_CTX_sess_set_new_cb(). + Where session_id is the current session identifier, + ticket is the session ticket info, and lifetime + is the the ticket lifetime in seconds. +
+ +
+ +
+ sni servername +
+
+ This form of callback is invoked when the server receives the SNI + header from the client where servername is the client + specified servername. Used to allow multiple names for + same server so the right certificate can be used. +
+
verify channel depth cert status error
Index: generic/tls.c ================================================================== --- generic/tls.c +++ generic/tls.c @@ -2,10 +2,11 @@ * Copyright (C) 1997-1999 Matt Newman * some modifications: * Copyright (C) 2000 Ajuba Solutions * Copyright (C) 2002 ActiveState Corporation * Copyright (C) 2004 Starfish Systems + * Copyright (C) 2023 Brian O'Hagan * * 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 #include #include +#include + +/* 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 #ifdef OPENSSL_THREADS #include -/* Added */ #include /* * 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,326 @@ } Tcl_Release((ClientData) interp); return -1; verify = verify; } + +/* + *------------------------------------------------------------------- + * + * Session Callback for Clients -- + * + * Called when a new session is added to the cache. In TLS 1.3 + * this may be received multiple times after the handshake. For + * earlier versions, this will be received during the handshake. + * This is the preferred way to obtain a resumable session. + * + * Results: + * None + * + * Side effects: + * Calls callback (if defined) + * + * Return codes: + * 0 = error where session will be immediately removed from the internal cache. + * 1 = success where app retains session in session cache, and must call SSL_SESSION_free() when done. + * + *------------------------------------------------------------------- + */ +static int +SessionCallback(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 code; + size_t len2; + unsigned int ulen; + + dprintf("Called"); + + if (statePtr->callback == (Tcl_Obj*)NULL) { + return SSL_TLSEXT_ERR_OK; + } else if (ssl == NULL) { + return SSL_TLSEXT_ERR_NOACK; + } + + cmdPtr = Tcl_DuplicateObj(statePtr->callback); + Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("session", -1)); + + /* Session id */ + session_id = SSL_SESSION_get_id(session, &ulen); + Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(session_id, (int) ulen)); + + /* 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 0; +} + +/* + *------------------------------------------------------------------- + * + * ALPN Callback for Servers -- + * + * Perform server-side protocol (http/1.1, h2, h3, etc.) selection for the + * incoming connection. Called after Hello and server callbacks + * + * 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, res; + + dprintf("Called"); + + if (statePtr->callback == (Tcl_Obj*)NULL) { + return SSL_TLSEXT_ERR_OK; + } else if (ssl == NULL) { + return SSL_TLSEXT_ERR_NOACK; + } + + /* Select protocol */ + if (SSL_select_next_proto(out, outlen, statePtr->protos, statePtr->protos_len, + in, inlen) == OPENSSL_NPN_NEGOTIATED) { + res = SSL_TLSEXT_ERR_OK; + } else { + /* No overlap, so first client protocol used */ + res = SSL_TLSEXT_ERR_NOACK; + } + + 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 res; +} + +/* + *------------------------------------------------------------------- + * + * SNI Callback for Servers -- + * + * Perform server-side SNI hostname selection after receiving SNI header. + * Called after hello callback but before ALPN callback. + * + * Results: + * None + * + * Side effects: + * Calls callback (if defined) + * + * Return codes: + * SSL_TLSEXT_ERR_OK: SNI hostname is accepted. The connection continues. + * SSL_TLSEXT_ERR_ALERT_FATAL: SNI hostname is not accepted. The connection + * is aborted. Default for alert is SSL_AD_UNRECOGNIZED_NAME. + * SSL_TLSEXT_ERR_ALERT_WARNING: SNI hostname is not accepted, warning alert + * sent (not 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 Handshake Callback for Servers -- + * + * Used by server to examine the server name indication (SNI) extension + * provided by the client in order to select an appropriate certificate to + * present, and make other configuration adjustments relevant to that server + * name and its configuration. This includes swapping out the associated + * SSL_CTX pointer, modifying the server's list of permitted TLS versions, + * changing the server's cipher list in response to the client's cipher list, etc. + * + * 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_TLSEXT_ERR_OK; + } else if (ssl == NULL) { + return SSL_TLSEXT_ERR_NOACK; + } + + /* 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 +756,75 @@ * 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; + } + + ERR_clear_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 +843,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 +985,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 +1060,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 +1104,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 +1117,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 +1161,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 +1215,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,58 +1266,87 @@ 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); + 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)) { - Tcl_AppendResult(interp, "failed to set alpn protocols", (char *) NULL); + 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 */ @@ -985,13 +1356,23 @@ /* 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 { + /* Session caching */ + SSL_CTX_set_session_cache_mode(statePtr->ctx, SSL_SESS_CACHE_CLIENT | SSL_SESS_CACHE_NO_INTERNAL_STORE); + SSL_CTX_sess_set_new_cb(statePtr->ctx, SessionCallback); + SSL_set_connect_state(statePtr->ssl); } SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio); BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE); @@ -1034,13 +1415,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 +1448,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 +1465,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 +1503,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) @@ -1156,20 +1535,16 @@ /* * The version range is constrained below, * after the context is created. Use the * generic method here. */ - method = TLS_method(); + method = isServer ? TLS_server_method() : TLS_client_method(); break; #endif default: -#if OPENSSL_VERSION_NUMBER >= 0x10100000L /* Negotiate highest available SSL/TLS version */ - method = TLS_method(); -#else - method = SSLv23_method(); -#endif + method = isServer ? TLS_server_method() : TLS_client_method(); #if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2) off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2); #endif #if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3); @@ -1187,10 +1562,11 @@ off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3); #endif break; } + ERR_clear_error(); ctx = SSL_CTX_new(method); if (!ctx) { return(NULL); } @@ -1201,34 +1577,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 +1778,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 +1807,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 +1827,222 @@ 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) { + /* connection state */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("state", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_state_string_long(ssl), -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 +2118,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 +2179,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 +2219,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 +2246,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 +2271,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 +2284,14 @@ } return TCL_OK; clientData = clientData; } +/********************/ +/* Init */ +/********************/ + /* *------------------------------------------------------------------- * * Tls_Free -- * @@ -1776,10 +2343,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 +2416,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 +2491,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 +2519,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 +2556,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 #include #include #include -/* - * 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 + * Copyright (C) 2023 Brian O'Hagan */ #include #include #include #include @@ -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 {