Index: doc/tls.html ================================================================== --- doc/tls.html +++ doc/tls.html @@ -11,28 +11,29 @@

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?; 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?
+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.

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::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 +241,66 @@
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?: 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.
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 @@ -488,18 +489,19 @@ * 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; SSL_CTX *ctx = NULL; SSL *ssl = NULL; STACK_OF(SSL_CIPHER) *sk; char *cp, buf[BUFSIZ]; @@ -600,10 +602,63 @@ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1)); } } 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 < 0x10101000L && !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; } @@ -1471,10 +1526,136 @@ } /* *------------------------------------------------------------------- * + * 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; +} + +/* + *------------------------------------------------------------------- + * * VersionObjCmd -- return version string from OpenSSL. * * Results: * A standard Tcl result. * @@ -1845,16 +2026,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: 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