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.
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
@@ -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,125 @@
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)
+ - -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.
+ - -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
@@ -154,123 +251,68 @@
- 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
+ - server 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
+ - 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.
+ - renegotiation state
+ - Whether protocol renegotiation is allowed or disallowed.
+ - alpn protocol
+ - The protocol selected after Application-Layer Protocol
+ Negotiation (ALPN).
+ - session_reused boolean
+ - Whether the session has been reused or not.
-
- - 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.
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
@@ -41,11 +42,11 @@
#define REASON() ERR_reason_error_string(ERR_get_error())
static SSL_CTX *CTX_Init(State *statePtr, int isServer, int proto, char *key,
char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1,
int key_asn1_len, int cert_asn1_len, char *CAdir, char *CAfile,
- char *ciphers, char *DHparams);
+ char *ciphers, char *ciphersuites, char *DHparams);
static int TlsLibInit(int uninitialize);
#define TLS_PROTO_SSL2 0x01
#define TLS_PROTO_SSL3 0x02
@@ -488,40 +489,45 @@
* Side effects:
* constructs and destroys SSL context (CTX)
*
*-------------------------------------------------------------------
*/
+static const char *protocols[] = {
+ "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL
+};
+enum protocol {
+ TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE
+};
+
static int
CiphersObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- static const char *protocols[] = {
- "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL
- };
- enum protocol {
- TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE
- };
- Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr = NULL;
SSL_CTX *ctx = NULL;
SSL *ssl = NULL;
STACK_OF(SSL_CIPHER) *sk;
char *cp, buf[BUFSIZ];
- int index, verbose = 0;
+ int index, verbose = 0, use_supported = 0;
dprintf("Called");
- if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?");
+ if ((objc < 2) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose? ?supported?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], protocols, "protocol", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if ((objc > 2) && Tcl_GetBooleanFromObj(interp, objv[2], &verbose) != TCL_OK) {
return TCL_ERROR;
}
+ if ((objc > 3) && Tcl_GetBooleanFromObj(interp, objv[3], &use_supported) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
switch ((enum protocol)index) {
case TLS_SSL2:
-#if OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
return TCL_ERROR;
#else
ctx = SSL_CTX_new(SSLv2_method()); break;
#endif
@@ -568,42 +574,111 @@
}
if (ctx == NULL) {
Tcl_AppendResult(interp, REASON(), NULL);
return TCL_ERROR;
}
+
ssl = SSL_new(ctx);
if (ssl == NULL) {
Tcl_AppendResult(interp, REASON(), NULL);
SSL_CTX_free(ctx);
return TCL_ERROR;
}
- objPtr = Tcl_NewListObj(0, NULL);
-
- if (!verbose) {
- for (index = 0; ; index++) {
- cp = (char*)SSL_get_cipher_list(ssl, index);
- if (cp == NULL) break;
- Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(cp, -1));
- }
+
+ /* Use list and order as would be sent in a ClientHello or all available ciphers */
+ if (use_supported) {
+ sk = SSL_get1_supported_ciphers(ssl);
} else {
sk = SSL_get_ciphers(ssl);
+ }
- for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) {
- register size_t i;
- SSL_CIPHER_description(sk_SSL_CIPHER_value(sk, index), buf, sizeof(buf));
- for (i = strlen(buf) - 1; i ; i--) {
- if ((buf[i] == ' ') || (buf[i] == '\n') || (buf[i] == '\r') || (buf[i] == '\t')) {
- buf[i] = '\0';
+ if (sk != NULL) {
+ if (!verbose) {
+ objPtr = Tcl_NewListObj(0, NULL);
+ for (int i = 0; i < sk_SSL_CIPHER_num(sk); i++) {
+ const SSL_CIPHER *c = sk_SSL_CIPHER_value(sk, i);
+ if (c == NULL) continue;
+
+ /* cipher name or (NONE) */
+ cp = SSL_CIPHER_get_name(c);
+ if (cp == NULL) break;
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(cp, -1));
+ }
+
+ } else {
+ objPtr = Tcl_NewStringObj("",0);
+ for (int i = 0; i < sk_SSL_CIPHER_num(sk); i++) {
+ const SSL_CIPHER *c = sk_SSL_CIPHER_value(sk, i);
+ if (c == NULL) continue;
+
+ /* textual description of the cipher */
+ if (SSL_CIPHER_description(c, buf, sizeof(buf)) != NULL) {
+ Tcl_AppendToObj(objPtr, buf, strlen(buf));
} else {
- break;
+ Tcl_AppendToObj(objPtr, "UNKNOWN\n", 8);
}
}
- Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1));
+ }
+ if (use_supported) {
+ sk_SSL_CIPHER_free(sk);
}
}
SSL_free(ssl);
SSL_CTX_free(ctx);
+
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ProtocolsObjCmd -- list available protocols
+ *
+ * This procedure is invoked to process the "tls::protocols" command
+ * to list available protocols.
+ *
+ * Results:
+ * A standard Tcl result list.
+ *
+ * Side effects:
+ * none
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+ProtocolsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Obj *objPtr;
+
+ dprintf("Called");
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ objPtr = Tcl_NewListObj(0, NULL);
+
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL2], -1));
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL3], -1));
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1], -1));
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_1], -1));
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_2], -1));
+#endif
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_3], -1));
+#endif
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
clientData = clientData;
}
@@ -718,10 +793,11 @@
unsigned char *key = NULL;
int key_len = 0;
unsigned char *cert = NULL;
int cert_len = 0;
char *ciphers = NULL;
+ char *ciphersuites = NULL;
char *CAfile = NULL;
char *CAdir = NULL;
char *DHparams = NULL;
char *model = NULL;
#ifndef OPENSSL_NO_TLSEXT
@@ -777,10 +853,11 @@
OPTSTR("-cadir", CAdir);
OPTSTR("-cafile", CAfile);
OPTSTR("-certfile", certfile);
OPTSTR("-cipher", ciphers);
+ OPTSTR("-ciphersuites", ciphersuites);
OPTOBJ("-command", script);
OPTSTR("-dhparams", DHparams);
OPTSTR("-keyfile", keyfile);
OPTSTR("-model", model);
OPTOBJ("-password", password);
@@ -799,11 +876,11 @@
OPTBOOL("-tls1.2", tls1_2);
OPTBOOL("-tls1.3", tls1_3);
OPTBYTE("-cert", cert, cert_len);
OPTBYTE("-key", key, key_len);
- OPTBAD("option", "-alpn, -cadir, -cafile, -cert, -certfile, -cipher, -command, -dhparams, -key, -keyfile, -model, -password, -require, -request, -server, -servername, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, or -tls1.3");
+ OPTBAD("option", "-alpn, -cadir, -cafile, -cert, -certfile, -cipher, -ciphersuites, -command, -dhparams, -key, -keyfile, -model, -password, -require, -request, -server, -servername, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, or -tls1.3");
return TCL_ERROR;
}
if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
@@ -820,10 +897,11 @@
if (cert && !*cert) cert = NULL;
if (key && !*key) key = NULL;
if (certfile && !*certfile) certfile = NULL;
if (keyfile && !*keyfile) keyfile = NULL;
if (ciphers && !*ciphers) ciphers = NULL;
+ if (ciphersuites && !*ciphersuites) ciphersuites = NULL;
if (CAfile && !*CAfile) CAfile = NULL;
if (CAdir && !*CAdir) CAdir = NULL;
if (DHparams && !*DHparams) DHparams = NULL;
/* new SSL state */
@@ -873,11 +951,11 @@
return TCL_ERROR;
}
ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx;
} else {
if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, cert,
- key_len, cert_len, CAdir, CAfile, ciphers, DHparams)) == (SSL_CTX*)0) {
+ key_len, cert_len, CAdir, CAfile, ciphers, ciphersuites, DHparams)) == (SSL_CTX*)0) {
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
}
@@ -935,11 +1013,11 @@
}
}
if (alpn) {
/* Convert a Tcl list into a protocol-list in wire-format */
unsigned char *protos, *p;
- unsigned int protoslen = 0;
+ unsigned int protos_len = 0;
int i, len, cnt;
Tcl_Obj **list;
if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
Tls_Free((char *) statePtr);
return TCL_ERROR;
@@ -950,23 +1028,23 @@
if (len > 255) {
Tcl_AppendResult(interp, "alpn protocol name too long", (char *) NULL);
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
- protoslen += 1 + len;
+ protos_len += 1 + len;
}
/* Build the complete protocol-list */
- protos = ckalloc(protoslen);
+ protos = ckalloc(protos_len);
/* protocol-lists consist of 8-bit length-prefixed, byte strings */
for (i = 0, p = protos; i < cnt; i++) {
char *str = Tcl_GetStringFromObj(list[i], &len);
*p++ = len;
memcpy(p, str, len);
p += len;
}
/* Note: This functions reverses the return value convention */
- if (SSL_set_alpn_protos(statePtr->ssl, protos, protoslen)) {
+ if (SSL_set_alpn_protos(statePtr->ssl, protos, protos_len)) {
Tcl_AppendResult(interp, "failed to set alpn protocols", (char *) NULL);
Tls_Free((char *) statePtr);
ckfree(protos);
return TCL_ERROR;
}
@@ -1069,11 +1147,11 @@
*-------------------------------------------------------------------
*/
static SSL_CTX *
CTX_Init(State *statePtr, int isServer, int proto, char *keyfile, char *certfile,
unsigned char *key, unsigned char *cert, int key_len, int cert_len, char *CAdir,
- char *CAfile, char *ciphers, char *DHparams) {
+ char *CAfile, char *ciphers, char *ciphersuites, char *DHparams) {
Tcl_Interp *interp = statePtr->interp;
SSL_CTX *ctx = NULL;
Tcl_DString ds;
Tcl_DString ds1;
int off = 0;
@@ -1086,11 +1164,11 @@
Tcl_AppendResult(interp, "no valid protocol selected", NULL);
return (SSL_CTX *)0;
}
/* create SSL context */
-#if OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
if (ENABLED(proto, TLS_PROTO_SSL2)) {
Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
return (SSL_CTX *)0;
}
#endif
@@ -1124,11 +1202,11 @@
return (SSL_CTX *)0;
}
#endif
switch (proto) {
-#if OPENSSL_VERSION_NUMBER < 0x10101000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
case TLS_PROTO_SSL2:
method = SSLv2_method();
break;
#endif
#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
@@ -1216,12 +1294,17 @@
#if OPENSSL_VERSION_NUMBER < 0x10101000L
SSL_CTX_set_mode(ctx, SSL_MODE_AUTO_RETRY); /* handle new handshakes in background */
#endif
SSL_CTX_sess_set_cache_size(ctx, 128);
- if (ciphers != NULL)
- SSL_CTX_set_cipher_list(ctx, ciphers);
+ /* Set user defined ciphers and cipher suites */
+ if (((ciphers != NULL) && !SSL_CTX_set_cipher_list(ctx, ciphers)) || \
+ ((ciphersuites != NULL) && !SSL_CTX_set_ciphersuites(ctx, ciphersuites))) {
+ Tcl_AppendResult(interp, "Set ciphers failed", (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
/* set some callbacks */
SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback);
#ifndef BSAFE
@@ -1462,10 +1545,136 @@
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1));
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj((char *)proto, (int)len));
#endif
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("version", -1));
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_version(statePtr->ssl), -1));
+
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ConnectionInfoObjCmd -- return connection info from OpenSSL.
+ *
+ * Results:
+ * A list of connection info
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int ConnectionInfoObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Channel chan; /* The channel to set a mode on. */
+ State *statePtr; /* client state for ssl socket */
+ Tcl_Obj *objPtr;
+ const SSL *ssl;
+ const SSL_CIPHER *cipher;
+
+#if !defined(OPENSSL_NO_TLSEXT) && OPENSSL_VERSION_NUMBER >= 0x10002000L
+ const unsigned char *proto;
+ unsigned int len;
+#endif
+#if defined(HAVE_SSL_COMPRESSION) && OPENSSL_VERSION_NUMBER >= 0x10002000L
+ const COMP_METHOD *comp;
+#endif
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel");
+ return(TCL_ERROR);
+ }
+
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return(TCL_ERROR);
+ }
+
+ /*
+ * Make sure to operate on the topmost channel
+ */
+ chan = Tcl_GetTopChannel(chan);
+ if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
+ Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL);
+ return(TCL_ERROR);
+ }
+
+ objPtr = Tcl_NewListObj(0, NULL);
+
+ /* Get connection state */
+ statePtr = (State *)Tcl_GetChannelInstanceData(chan);
+ ssl = statePtr->ssl;
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("state", -1));
+ if (SSL_is_init_finished(ssl)) {
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("established", -1));
+ } else if (SSL_in_init(ssl)) {
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("handshake", -1));
+ } else {
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("initializing", -1));
+ }
+
+ /* Get server name */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("server", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name), -1));
+
+ /* Get protocol */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("protocol", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_version(ssl), -1));
+
+ /* Get cipher */
+ cipher = SSL_get_current_cipher(ssl);
+ if (cipher != NULL) {
+ char buf[BUFSIZ] = {0};
+ int bits, alg_bits;
+
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("cipher", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_get_name(cipher), -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("standard_name", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_standard_name(cipher), -1));
+
+ bits = SSL_CIPHER_get_bits(cipher, &alg_bits);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("bits", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(bits));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("secret_bits", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(alg_bits));
+ /* alg_bits is actual key secret bits. If use bits and secret (algorithm) bits differ,
+ the rest of the bits are fixed, i.e. for limited export ciphers (bits < 56) */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("min_version", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_get_version(cipher), -1));
+
+ if (SSL_CIPHER_description(cipher, buf, sizeof(buf)) != NULL) {
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("description", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1));
+ }
+ }
+
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("renegotiation", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
+ SSL_get_secure_renegotiation_support(ssl) ? "allowed" : "disallowed", -1));
+
+#if !defined(OPENSSL_NO_TLSEXT) && OPENSSL_VERSION_NUMBER >= 0x10002000L
+ /* Report the selected protocol as a result of the negotiation */
+ SSL_get0_alpn_selected(ssl, &proto, &len);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj((char *)proto, (int)len));
+#endif
+
+ /* Session info */
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_reused", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_session_reused(ssl)));
+
+#if defined(HAVE_SSL_COMPRESSION) && OPENSSL_VERSION_NUMBER >= 0x10002000L
+ /* Compression info */
+ comp = SSL_get_current_compression(ssl);
+ if (comp != NULL) {
+ expansion = SSL_get_current_expansion(ssl);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("compression", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_COMP_get_name(comp), -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("expansion", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_COMP_get_name(expansion), -1));
+ }
+#endif
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
clientData = clientData;
}
@@ -1845,16 +2054,18 @@
Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::connection", ConnectionInfoObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::protocols", ProtocolsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
if (interp) {
Tcl_Eval(interp, tlsTclInitScript);
}
Index: library/tls.tcl
==================================================================
--- library/tls.tcl
+++ library/tls.tcl
@@ -35,10 +35,11 @@
{* -cadir iopts 1}
{* -cafile iopts 1}
{* -cert iopts 1}
{* -certfile iopts 1}
{* -cipher iopts 1}
+ {* -ciphersuites iopts 1}
{* -command iopts 1}
{* -dhparams iopts 1}
{* -key iopts 1}
{* -keyfile iopts 1}
{* -password iopts 1}
ADDED tests/README.txt
Index: tests/README.txt
==================================================================
--- /dev/null
+++ tests/README.txt
@@ -0,0 +1,17 @@
+Create Test Cases
+
+1. Create test case *.csv file. You can use multiple files. Generally it's a good idea to group like functions in the same file.
+
+2. Add test cases to *.csv files.
+ Each test case is on a separate line. Each column defines the equivalent input the tcltest tool expects.
+
+3. Define any common functions in common.tcl or in *.csv file.
+
+4. To create the test cases script, execute make_test_files.tcl. This will use the *.csv files to create the *.test files.
+
+Execute Test Suite
+
+5. To run the test suite, execute the all.tcl file. The results will be output to the stdoutlog.txt file.
+ On Windows you can also use the run_all_tests.bat file.
+
+6. Review stdoutlog.txt for the count of test cases executed successfully and view details of those that failed.
Index: tests/all.tcl
==================================================================
--- tests/all.tcl
+++ tests/all.tcl
@@ -7,53 +7,47 @@
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: all.tcl,v 1.5 2000/08/15 18:45:01 hobbs Exp $
+set path [file normalize [file dirname [file join [pwd] [info script]]]]
#set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]]
-set auto_path [linsert $auto_path 0 [file normalize [pwd]]]
+set auto_path [linsert $auto_path 0 [file dirname $path] [file normalize [pwd]]]
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import ::tcltest::*
}
+
+# Get common functions
+if {[file exists [file join $path common.tcl]]} {
+ source [file join $path common.tcl]
+}
set ::tcltest::testSingleFile false
set ::tcltest::testsDirectory [file dir [info script]]
# We should ensure that the testsDirectory is absolute.
# This was introduced in Tcl 8.3+'s tcltest, so we need a catch.
catch {::tcltest::normalizePath ::tcltest::testsDirectory}
-puts stdout "Tests running in interp: [info nameofexecutable]"
-puts stdout "Tests running in working dir: $::tcltest::testsDirectory"
-if {[llength $::tcltest::skip] > 0} {
- puts stdout "Skipping tests that match: $::tcltest::skip"
-}
-if {[llength $::tcltest::match] > 0} {
- puts stdout "Only running tests that match: $::tcltest::match"
-}
-
-if {[llength $::tcltest::skipFiles] > 0} {
- puts stdout "Skipping test files that match: $::tcltest::skipFiles"
-}
-if {[llength $::tcltest::matchFiles] > 0} {
- puts stdout "Only sourcing test files that match: $::tcltest::matchFiles"
-}
-
-set timeCmd {clock format [clock seconds]}
-puts stdout "Tests began at [eval $timeCmd]"
-
-# source each of the specified tests
-foreach file [lsort [::tcltest::getMatchingFiles]] {
- set tail [file tail $file]
- puts stdout $tail
- if {[catch {source $file} msg]} {
- puts stdout $msg
- }
-}
-
-# cleanup
-puts stdout "\nTests ended at [eval $timeCmd]"
-::tcltest::cleanupTests 1
-return
-
+#
+# Run all tests in current and any sub directories with an all.tcl file.
+#
+set exitCode 0
+if {[package vsatisfies [package require tcltest] 2.5-]} {
+ if {[::tcltest::runAllTests] == 1} {
+ set exitCode 1
+ }
+
+} else {
+ # Hook to determine if any of the tests failed. Then we can exit with the
+ # proper exit code: 0=all passed, 1=one or more failed
+ proc tcltest::cleanupTestsHook {} {
+ variable numTests
+ set exitCode [expr {$numTests(Total) == 0 || $numTests(Failed) > 0}]
+ }
+ ::tcltest::runAllTests
+}
+
+# Exit code: 0=all passed, 1=one or more failed
+exit $exitCode
ADDED tests/ciphers.csv
Index: tests/ciphers.csv
==================================================================
--- /dev/null
+++ tests/ciphers.csv
@@ -0,0 +1,46 @@
+# Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes
+command,package require tls,,,,,,,,,
+command,,,,,,,,,,
+command,# Make sure path includes location of OpenSSL executable,,,,,,,,,
+command,"if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin] "";"" $::env(path)}",,,,,,,,,
+command,,,,,,,,,,
+command,# Constraints,,,,,,,,,
+command,set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3],,,,,,,,,
+command,foreach protocol $protocols {::tcltest::testConstraint $protocol 0},,,,,,,,,
+command,foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1},,,,,,,,,
+command,"::tcltest::testConstraint OpenSSL [string match ""OpenSSL*"" [::tls::version]]",,,,,,,,,
+,,,,,,,,,,
+command,# Helper functions,,,,,,,,,
+command,"proc lcompare {list1 list2} {set m """";set u """";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list ""missing"" $m ""unexpected"" $u]}",,,,,,,,,
+command,proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]},,,,,,,,,
+,,,,,,,,,,
+command,# Test protocols,,,,,,,,,
+Protocols,All,,,lcompare $protocols [::tls::protocols],,,missing {ssl2 ssl3} unexpected {},,,
+,,,,,,,,,,
+command,# Test ciphers,,,,,,,,,
+CiphersAll,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2] [::tls::ciphers ssl2]",,,missing {} unexpected {},,,
+CiphersAll,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3] [::tls::ciphers ssl3]",,,missing {} unexpected {},,,
+CiphersAll,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1] [::tls::ciphers tls1]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1] [::tls::ciphers tls1.1]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2] [::tls::ciphers tls1.2]",,,missing {} unexpected {},,,
+CiphersAll,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3] [::tls::ciphers tls1.3]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test cipher descriptions,,,,,,,,,
+CiphersDesc,SSL2,ssl2,,"lcompare [exec_get ""\r\n"" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,SSL3,ssl3,,"lcompare [exec_get ""\r\n"" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1,tls1,,"lcompare [exec_get ""\r\n"" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.1,tls1.1,,"lcompare [exec_get ""\r\n"" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.2,tls1.2,,"lcompare [exec_get ""\r\n"" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]",,,missing {} unexpected {},,,
+CiphersDesc,TLS1.3,tls1.3,,"lcompare [exec_get ""\r\n"" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test protocol specific ciphers,,,,,,,,,
+CiphersSpecific,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]",,,missing {} unexpected {},,,
+CiphersSpecific,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]",,,missing {} unexpected {},,,
+,,,,,,,,,,
+command,# Test version,,,,,,,,,
+Version,All,,,::tls::version,,glob,*,,,
+Version,OpenSSL,OpenSSL,,::tls::version,,glob,OpenSSL*,,,
Index: tests/ciphers.test
==================================================================
--- tests/ciphers.test
+++ tests/ciphers.test
@@ -1,157 +1,121 @@
-# Commands covered: tls::ciphers
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-
-# All rights reserved.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import ::tcltest::*
-}
-
-# The build dir is added as the first element of $PATH
+# Auto generated test cases for ciphers_and_protocols.csv
+
+# Load Tcl Test package
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]
+
package require tls
-# One of these should == 1, depending on what type of ssl library
-# tls was compiled against. (RSA BSAFE SSL-C or OpenSSL).
-#
-set ::tcltest::testConstraints(rsabsafe) 0
-set ::tcltest::testConstraints(openssl) [string match "OpenSSL*" [tls::version]]
-
-set ::EXPECTEDCIPHERS(rsabsafe) {
- EDH-DSS-RC4-SHA
- EDH-RSA-DES-CBC3-SHA
- EDH-DSS-DES-CBC3-SHA
- DES-CBC3-SHA
- RC4-SHA
- RC4-MD5
- EDH-RSA-DES-CBC-SHA
- EDH-DSS-DES-CBC-SHA
- DES-CBC-SHA
- EXP-EDH-DSS-DES-56-SHA
- EXP-EDH-DSS-RC4-56-SHA
- EXP-DES-56-SHA
- EXP-RC4-56-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
-}
-
-set ::EXPECTEDCIPHERS(openssl) {
- AES128-SHA
- AES256-SHA
- DES-CBC-SHA
- DES-CBC3-SHA
- DHE-DSS-AES128-SHA
- DHE-DSS-AES256-SHA
- DHE-DSS-RC4-SHA
- DHE-RSA-AES128-SHA
- DHE-RSA-AES256-SHA
- EDH-DSS-DES-CBC-SHA
- EDH-DSS-DES-CBC3-SHA
- EDH-RSA-DES-CBC-SHA
- EDH-RSA-DES-CBC3-SHA
- EXP-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
- EXP1024-DES-CBC-SHA
- EXP1024-DHE-DSS-DES-CBC-SHA
- EXP1024-DHE-DSS-RC4-SHA
- EXP1024-RC2-CBC-MD5
- EXP1024-RC4-MD5
- EXP1024-RC4-SHA
- IDEA-CBC-SHA
- RC4-MD5
- RC4-SHA
-}
-
-set ::EXPECTEDCIPHERS(openssl0.9.8) {
- DHE-RSA-AES256-SHA
- DHE-DSS-AES256-SHA
- AES256-SHA
- EDH-RSA-DES-CBC3-SHA
- EDH-DSS-DES-CBC3-SHA
- DES-CBC3-SHA
- DHE-RSA-AES128-SHA
- DHE-DSS-AES128-SHA
- AES128-SHA
- IDEA-CBC-SHA
- RC4-SHA
- RC4-MD5
- EDH-RSA-DES-CBC-SHA
- EDH-DSS-DES-CBC-SHA
- DES-CBC-SHA
- EXP-EDH-RSA-DES-CBC-SHA
- EXP-EDH-DSS-DES-CBC-SHA
- EXP-DES-CBC-SHA
- EXP-RC2-CBC-MD5
- EXP-RC4-MD5
-}
-
-set version ""
-if {[string match "OpenSSL*" [tls::version]]} {
- regexp {OpenSSL ([\d\.]+)} [tls::version] -> version
-}
-if {![info exists ::EXPECTEDCIPHERS(openssl$version)]} {
- set version ""
-}
-
-proc listcompare {wants haves} {
- array set want {}
- array set have {}
- foreach item $wants { set want($item) 1 }
- foreach item $haves { set have($item) 1 }
- foreach item [lsort -dictionary [array names have]] {
- if {[info exists want($item)]} {
- unset want($item) have($item)
- }
- }
- if {[array size want] || [array size have]} {
- return [list MISSING [array names want] UNEXPECTED [array names have]]
- }
-}
-
-test ciphers-1.1 {Tls::ciphers for ssl3} {rsabsafe} {
- # This will fail if you compiled against OpenSSL.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers ssl3]
-} {}
-
-test ciphers-1.2 {Tls::ciphers for tls1} {rsabsafe} {
- # This will fail if you compiled against OpenSSL.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers tls1]
-} {}
-
-test ciphers-1.3 {Tls::ciphers for ssl3} {openssl} {
- # This will fail if you compiled against RSA bsafe or with a
- # different set of defines than the default.
- # Change the constraint setting above.
- listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers ssl3]
-} {}
-
-# This version of the test is correct for OpenSSL only.
-# An equivalent test for the RSA BSAFE SSL-C is earlier in this file.
-
-test ciphers-1.4 {Tls::ciphers for tls1} {openssl} {
- # This will fail if you compiled against RSA bsafe or with a
- # different set of defines than the default.
- # Change the constraint setting in all.tcl
- listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers tls1]
-} {}
-
-
-# cleanup
+# Make sure path includes location of OpenSSL executable
+if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin] ";" $::env(path)}
+
+# Constraints
+set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3]
+foreach protocol $protocols {::tcltest::testConstraint $protocol 0}
+foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1}
+::tcltest::testConstraint OpenSSL [string match "OpenSSL*" [::tls::version]]
+# Helper functions
+proc lcompare {list1 list2} {set m "";set u "";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list "missing" $m "unexpected" $u]}
+proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]}
+# Test protocols
+
+
+test Protocols-1.1 {All} -body {
+ lcompare $protocols [::tls::protocols]
+ } -result {missing {ssl2 ssl3} unexpected {}}
+# Test ciphers
+
+
+test CiphersAll-2.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get ":" ciphers -ssl2] [::tls::ciphers ssl2]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get ":" ciphers -ssl3] [::tls::ciphers ssl3]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get ":" ciphers -tls1] [::tls::ciphers tls1]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get ":" ciphers -tls1_1] [::tls::ciphers tls1.1]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get ":" ciphers -tls1_2] [::tls::ciphers tls1.2]
+ } -result {missing {} unexpected {}}
+
+test CiphersAll-2.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get ":" ciphers -tls1_3] [::tls::ciphers tls1.3]
+ } -result {missing {} unexpected {}}
+# Test cipher descriptions
+
+
+test CiphersDesc-3.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get "\r\n" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get "\r\n" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]
+ } -result {missing {} unexpected {}}
+
+test CiphersDesc-3.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get "\r\n" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]
+ } -result {missing {} unexpected {}}
+# Test protocol specific ciphers
+
+
+test CiphersSpecific-4.1 {SSL2} -constraints {ssl2} -body {
+ lcompare [exec_get ":" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.2 {SSL3} -constraints {ssl3} -body {
+ lcompare [exec_get ":" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.3 {TLS1} -constraints {tls1} -body {
+ lcompare [exec_get ":" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.4 {TLS1.1} -constraints {tls1.1} -body {
+ lcompare [exec_get ":" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.5 {TLS1.2} -constraints {tls1.2} -body {
+ lcompare [exec_get ":" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]
+ } -result {missing {} unexpected {}}
+
+test CiphersSpecific-4.6 {TLS1.3} -constraints {tls1.3} -body {
+ lcompare [exec_get ":" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]
+ } -result {missing {} unexpected {}}
+# Test version
+
+
+test Version-5.1 {All} -body {
+ ::tls::version
+ } -match {glob} -result {*}
+
+test Version-5.2 {OpenSSL} -constraints {OpenSSL} -body {
+ ::tls::version
+ } -match {glob} -result {OpenSSL*}
+
+# Cleanup
::tcltest::cleanupTests
return
ADDED tests/make_test_files.tcl
Index: tests/make_test_files.tcl
==================================================================
--- /dev/null
+++ tests/make_test_files.tcl
@@ -0,0 +1,123 @@
+#
+# Name: Make Test Files From CSV Files
+# Version: 0.2
+# Date: August 6, 2022
+# Author: Brian O'Hagan
+# Email: brian199@comcast.net
+# Legal Notice: (c) Copyright 2020 by Brian O'Hagan
+# Released under the Apache v2.0 license. I would appreciate a copy of any modifications
+# made to this package for possible incorporation in a future release.
+#
+
+#
+# Convert test case file into test files
+#
+proc process_config_file {filename} {
+ set prev ""
+ set test 0
+
+ # Open file with test case indo
+ set in [open $filename r]
+ array set cases [list]
+
+ # Open output test file
+ set out [open [format %s.test [file rootname $filename]] w]
+ array set cases [list]
+
+ # Add setup commands to test file
+ puts $out [format "# Auto generated test cases for %s" [file tail $filename]]
+ #puts $out [format "# Auto generated test cases for %s created on %s" [file tail $filename] [clock format [clock seconds]]]
+
+ # Package requires
+ puts $out "\n# Load Tcl Test package"
+ puts $out [subst -nocommands {if {[lsearch [namespace children] ::tcltest] == -1} {\n\tpackage require tcltest\n\tnamespace import ::tcltest::*\n}\n}]
+ puts $out {set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]}
+ puts $out ""
+
+ # Generate test cases and add to test file
+ while {[gets $in data] > -1} {
+ # Skip comments
+ set data [string trim $data]
+ if {[string match "#*" $data]} continue
+
+ # Split comma separated fields with quotes
+ set list [list]
+ while {[string length $data] > 0} {
+ if {[string index $data 0] eq "\""} {
+ # Quoted
+ set end [string first "\"," $data]
+ if {$end == -1} {set end [expr {[string length $data]+1}]}
+ lappend list [string map [list {""} \"] [string range $data 1 [incr end -1]]]
+ set data [string range $data [incr end 3] end]
+
+ } else {
+ # Not quoted, so no embedded NL, quotes, or commas
+ set index [string first "," $data]
+ if {$index == -1} {set index [expr {[string length $data]+1}]}
+ lappend list [string range $data 0 [incr index -1]]
+ set data [string range $data [incr index 2] end]
+ }
+ }
+
+ # Get command or test case
+ foreach {group name constraints setup body cleanup match result output errorOutput returnCodes} $list {
+ if {$group eq "command"} {
+ # Pass-through command
+ puts $out $name
+
+ } elseif {$group ne "" && $body ne ""} {
+ set group [string map [list " " "_"] $group]
+ if {$group ne $prev} {
+ incr test
+ set prev $group
+ puts $out ""
+ }
+
+ # Test case
+ set buffer [format "\ntest %s-%d.%d {%s}" $group $test [incr cases($group)] $name]
+ foreach opt [list -constraints -setup -body -cleanup -match -result -output -errorOutput -returnCodes] {
+ set cmd [string trim [set [string trimleft $opt "-"]]]
+ if {$cmd ne ""} {
+ if {$opt in [list -setup -body -cleanup]} {
+ append buffer " " $opt " \{\n"
+ foreach line [split $cmd ";"] {
+ append buffer \t [string trim $line] \n
+ }
+ append buffer " \}"
+ } elseif {$opt in [list -output -errorOutput]} {
+ append buffer " " $opt " {" $cmd \n "}"
+ } elseif {$opt in [list -result]} {
+ if {[string index $cmd 0] in [list \[ \" \{]} {
+ append buffer " " $opt " " $cmd
+ } elseif {[string match {*[\\$]*} $cmd]} {
+ append buffer " " $opt " \"" [string map [list \\\\\" \\\"] [string map [list \" \\\" ] $cmd]] "\""
+ } else {
+ append buffer " " $opt " {" $cmd "}"
+ }
+ } else {
+ append buffer " " $opt " {" $cmd "}"
+ }
+ }
+ }
+ puts $out $buffer
+
+ } else {
+ # Empty line
+ }
+ break
+ }
+ }
+
+ # Output clean-up commands
+ puts $out "\n# Cleanup\n::tcltest::cleanupTests\nreturn"
+ close $out
+ close $in
+}
+
+#
+# Call script
+#
+foreach file [glob *.csv] {
+ process_config_file $file
+}
+exit
Index: tests/tlsIO.test
==================================================================
--- tests/tlsIO.test
+++ tests/tlsIO.test
@@ -166,11 +166,11 @@
set remoteServerIP 127.0.0.1
set remoteFile [file join [pwd] remote.tcl]
if {[catch {set remoteProcChan \
[open "|[list $::tcltest::tcltest $remoteFile \
-serverIsSilent -port $remoteServerPort \
- -address $remoteServerIP] 2> /dev/null" w+]} msg] == 0} {
+ -address $remoteServerIP]" w+]} msg] == 0} {
after 1000
if {[catch {set commandSocket [tls::socket -cafile $caCert \
-certfile $clientCert -keyfile $clientKey \
$remoteServerIP $remoteServerPort]} msg] == 0} {
fconfigure $commandSocket -translation crlf -buffering line
@@ -320,11 +320,11 @@
after cancel $timer
close $f
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8828} msg]} {
set x $msg
} else {
@@ -362,11 +362,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
global port
if {[catch {tls::socket -myport $port \
-certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8829} sock]} {
@@ -402,11 +402,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket -myaddr 127.0.0.1 \
-certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8830} sock]} {
set x $sock
@@ -440,11 +440,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey localhost 8831} sock]} {
set x $sock
} else {
@@ -477,11 +477,11 @@
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8832} sock]} {
set x $sock
} else {
@@ -533,11 +533,11 @@
after cancel $timer
close $f
puts done
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8834]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
@@ -580,11 +580,11 @@
after cancel $timer
close $f
puts "done $i"
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket -certfile $clientCert -cafile $caCert \
-keyfile $clientKey 127.0.0.1 8835]
fconfigure $s -buffering line
catch {
@@ -705,11 +705,11 @@
after cancel $timer
close $f
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
if {[catch {tls::socket 127.0.0.1 8828} msg]} {
set x $msg
} else {
lappend x [gets $f]
@@ -732,11 +732,11 @@
puts ready
gets stdin
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set f [open "|[list $::tcltest::tcltest script]" r+]
gets $f
set x [list [catch {tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
-server accept 8828} msg] \
$msg]
@@ -781,11 +781,11 @@
after cancel $t3
close $s
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set f [open "|[list $::tcltest::tcltest script]" r+]
set x [gets $f]
set s1 [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 8828]
fconfigure $s1 -buffering line
@@ -832,15 +832,15 @@
close $s
puts bye
gets stdin
}
close $f
- set p1 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set p1 [open "|[list $::tcltest::tcltest script]" r+]
fconfigure $p1 -buffering line
- set p2 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set p2 [open "|[list $::tcltest::tcltest script]" r+]
fconfigure $p2 -buffering line
- set p3 [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set p3 [open "|[list $::tcltest::tcltest script]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
@@ -930,11 +930,11 @@
package require tls
gets stdin
}
puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848]
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r+]
+ set f [open "|[list $::tcltest::tcltest script]" r+]
proc bgerror args {
global x
set x $args
}
proc accept {s a p} {expr 10 / 0}
@@ -968,11 +968,11 @@
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 8820]
set p [fconfigure $s -peername]
@@ -1001,11 +1001,11 @@
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
- set f [open "|[list $::tcltest::tcltest script] 2> /dev/null" r]
+ set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
set s [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 8821]
set p [fconfigure $s -sockname]
@@ -2012,15 +2012,13 @@
proc accept {s a p} {
fconfigure $s -blocking 0
fileevent $s readable [list do_handshake $s readable readlittle \
-buffering none]
}
- set s [tls::socket \
- -certfile $serverCert -cafile $caCert -keyfile $serverKey \
+ set s [tls::socket -certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 8831]
- set c [tls::socket \
- -certfile $clientCert -cafile $caCert -keyfile $clientKey \
+ set c [tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey \
localhost 8831]
# only the client gets tls::import
set res [tls::unimport $c]
list $res [catch {close $c} err] $err \
[catch {close $s} err] $err
@@ -2041,18 +2039,16 @@
# NOTE: when doing an in-process client/server test, both sides need
# to be non-blocking for the TLS handshake
# Server - Only accept TLS 1.2
set s [tls::socket \
- -certfile $serverCert -cafile $caCert -keyfile $serverKey \
- -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 1 \
- -server Accept 8831]
+ -certfile $serverCert -cafile $caCert -keyfile $serverKey -request 0 \
+ -require 0 -ssl2 0 -ssl3 0 -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 \
+ -server Accept 8831]
# Client - Only propose TLS1.0
- set c [tls::socket -async \
- -cafile $caCert \
- -request 0 -require 0 -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 0 -tls1.2 0 \
- localhost 8831]
+ set c [tls::socket -async -cafile $caCert -request 0 -require 0 \
+ -ssl2 0 -ssl3 0 -tls1 1 -tls1.1 0 -tls1.2 0 -tls1.3 0 localhost 8831]
fconfigure $c -blocking 0
puts $c a ; flush $c
after 5000 [list set ::done timeout]
vwait ::done
switch -exact -- $::done {