DELETED HEADER
Index: HEADER
==================================================================
--- HEADER
+++ /dev/null
@@ -1,7 +0,0 @@
-TclTLS @@VERS@@
-==========
-
-Release Date: @@DATE@@
-
-https://tcltls.rkeene.org/
-
Index: README.txt
==================================================================
--- README.txt
+++ README.txt
@@ -10,11 +10,11 @@
on any platform as it uses a generic mechanism for layering on SSL and Tcl.
Full filevent sematics should also be intact - see tests directory for
blocking and non-blocking examples.
-The current release is TLS 1.6, with binaries built against OpenSSL 0.9.8g.
+The current release is TLS 1.7, with binaries built against OpenSSL 1.1.1.
For best security and function, always compile from source with the latest
official release of OpenSSL (http://www.openssl.org/).
TLS 1.7 and newer require Tcl 8.4.0+, older versions may be used if older
versions of Tcl need to be used.
ADDED doc/tls.htm
Index: doc/tls.htm
==================================================================
--- /dev/null
+++ doc/tls.htm
@@ -0,0 +1,472 @@
+
+
+
+
+
+
+
+TLS (SSL) Tcl Commands
+
+
+
+
+
+ - NAME
+ - tls - binding to OpenSSL
+ 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::handshake channel
+ - tls::status ?-local? channel
+ - tls::import channel ?options?
+ - tls::unimport channel
+ - tls::ciphers protocol ?verbose?
+ - tls::version
+
+ - COMMANDS
+ - CALLBACK OPTIONS
+ - HTTPS EXAMPLE
+ - SPECIAL CONSIDERATIONS
+ - SEE ALSO
+
+
+
+
+
+
+tls - binding to OpenSSL
+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?
+tls::version
+
+
+
+
+This extension provides a generic binding to OpenSSL, utilizing the
+Tcl_StackChannel
+API for Tcl 8.4 and higher. The sockets behave exactly the same
+as channels created using Tcl's built-in socket
+command with additional options for controlling the SSL session.
+
+
+
+
+Typically one would use the tls::socket command
+which provides compatibility with the native Tcl socket
+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
+ 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::socket ?options?
+ host port
+ - tls::socket ?-server command? ?options? port
+ - This is a helper function that utilizes the underlying
+ commands (tls::import). It behaves
+ exactly the same as the native Tcl socket
+ command except that the options can include any of the
+ applicable tls:import
+ options with one additional option:
+
+
+ - -autoservername bool
+ - Automatically send the -servername as the host argument
+ (default: false)
+
+
+ -
+ - 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
+ 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
+ issuer.
+ - subject dn
+ - The distinguished name (DN) of the certificate
+ subject.
+ - notBefore date
+ - The begin date for the validity of the certificate.
+ - notAfter date
+ - The expiry date for the certificate.
+ - serial n
+ - The serial number of the certificate.
+ - cipher cipher
+ - The current cipher in use between the client and
+ server channels.
+ - sbits n
+ - The number of bits used for the session key.
+ - certificate cert
+ - The PEM encoded certificate.
+ - sha1_hash hash
+ - The SHA1 hash of the certificate.
+ - sha256_hash hash
+ - The SHA256 hash of the certificate.
+ - 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
+
+
+
+
+ - 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
+ - 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)
+
+
+
+
+ - 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::version
+ - Returns the version string defined by OpenSSL.
+
+
+
+
+
+As indicated above, individual channels can be given their own callbacks
+to handle intermediate processing by the OpenSSL library, using the
+-command and -password options passed to either of
+tls::socket or tls::import.
+
+
+
+
+
+ - -command callback
+ -
+ Invokes the specified callback script at
+ several points during the OpenSSL handshake.
+ Except as indicated below, values returned from the
+ callback are ignored.
+ Arguments appended to the script upon callback take one of the
+ following forms:
+
+
+
+
+
+
+
+
+ -
+ info channel major minor message
+
+ -
+ This form of callback is invoked by the OpenSSL function
+
SSL_CTX_set_info_callback().
+
+ The major and minor arguments are used to
+ represent the state information bitmask.
+
+ - Possible values for major are:
+ handshake, alert, connect, accept.- Possible values for minor are:
+ start, done, read, write, loop, exit.
+ The message argument is a descriptive string which may
+ be generated either by
+ SSL_state_string_long() or by
+ SSL_alert_desc_string_long(),
+ depending on context.
+
+
+
+
+ -
+ verify channel depth cert status error
+
+ -
+ This form of callback is invoked by the OpenSSL function
+
SSL_set_verify().
+
+ The depth argument is an integer representing the
+ current depth on the certificate chain, with
+ 0 as the subject certificate and higher values
+ denoting progressively more indirect issuer certificates.
+
+ The cert argument is a list of key-value pairs similar
+ to those returned by
+ tls::status.
+
+ The status argument is an integer representing the
+ current validity of the certificate.
+ A value of 0 means the certificate is deemed invalid.
+ A value of 1 means the certificate is deemed valid.
+
+ The error argument supplies the message, if any, generated
+ by
+ X509_STORE_CTX_get_error().
+
+
+ The callback may override normal validation processing by explicitly
+ returning one of the above status values.
+
+
+
+
+
+
+
+ - -password callback
+ -
+ Invokes the specified callback script when OpenSSL needs to
+ obtain a password. The callback should return a string which
+ represents the password to be used.
+ No arguments are appended to the script upon callback.
+
+
+
+
+
+Reference implementations of these callbacks are provided in the
+distribution as tls::callback and
+tls::password respectively. Note that these are
+sample implementations only. In a more realistic deployment
+you would specify your own callback scripts on each TLS channel
+using the -command and -password options.
+
+
+
+The default behavior when the -command option is not specified is for
+TLS to process the associated library callbacks internally.
+The default behavior when the -password option is not specified is for
+TLS to process the associated library callbacks by attempting to call
+tls::password.
+The difference between these two behaviors is a consequence of maintaining
+compatibility with earlier implementations.
+
+
+
+The tls::debug variable provides some additional
+control over these reference callbacks. Its value is zero by default.
+Higher values produce more diagnostic output, and will also force the
+verify method in tls::callback to accept the
+certificate, even when it is invalid.
+
+
+
+
+The use of the reference callbacks tls::callback and
+tls::password is not recommended. They may be removed
+from future releases.
+
+
+
+
+
+The use of the variable tls::debug is not recommended.
+It may be removed from future releases.
+
+
+
+
+
+TLS key logging can be enabled by setting the environment variable
+SSLKEYLOGFILE to the name of the file to log to. Then whenever TLS
+key material is generated or received it will be logged to the file.
+
+
+
+This example uses a sample server.pem provided with the TLS release,
+courtesy of the OpenSSL project.
+
+
+package require http
+package require tls
+
+http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
+
+set tok [http::geturl https://www.tcl.tk/]
+
+
+
+
+The capabilities of this package can vary enormously based
+upon how your OpenSSL library was configured and built. At the
+most macro-level OpenSSL supports a "no patents" build,
+which disables RSA, IDEA, RC(2,4,5) and SSL2 - if your OpenSSL is
+configured this way then you will need to build TLS with the
+-DNO_PATENTS option - and the resultant module will function
+correctly and also support ADH certificate-less encryption,
+however you will be unable to utilize this to speak to normal Web
+Servers, which typically require RSA support. Please see http://www.openssl.org/ for
+more information on the whole issue of patents and US export
+restrictions.
+
+
+
+socket, fileevent, OpenSSL
+
+
+
+
+Copyright © 1999 Matt Newman.
+Copyright © 2004 Starfish Systems.
+
+
+
DELETED gen_dh_params
Index: gen_dh_params
==================================================================
--- gen_dh_params
+++ /dev/null
@@ -1,280 +0,0 @@
-#! /usr/bin/env sh
-
-bits='2048'
-option_fallback='0'
-for arg in "$@"; do
- case "${arg}" in
- fallback)
- option_fallback='1'
- ;;
- bits=*)
- bits="`echo "${arg}" | cut -f 2 -d =`"
- ;;
- esac
-done
-
-openssl_dhparam() {
- if openssl dhparam -C "$@" | sed \
- -e 's/^\(static \)*DH \*get_dh[0-9]*/static DH *get_dhParams/' \
- -e '/^-----BEGIN DH PARAMETERS-----$/,/^-----END DH PARAMETERS-----$/ d;/^#/ d'
- then
- return 0
- fi
-
- return 1
-}
-
-gen_dh_params_openssl() {
- openssl_dhparam "${bits}" < /dev/null || return 1
- return 0
-}
-
-gen_dh_params_remote() {
- url="https://2ton.com.au/dhparam/${bits}"
-
- r_input="`curl -sS "${url}"`" || \
- r_input="`wget -O - -o /dev/null "${url}"`" || return 1
-
- if r_output="`echo "${r_input}" | openssl_dhparam`"; then
- echo "${r_output}"
-
- return 0
- fi
-
- return 1
-}
-
-gen_dh_params_fallback() {
- cat << \_EOF_
-DH *get_dhParams(void) {
- static unsigned char dhp[] = {
-_EOF_
- case "${bits}" in
- 2048)
- cat << \_EOF_
- 0xC1,0x51,0x58,0x69,0xFB,0xE8,0x6C,0x47,0x2B,0x86,0x61,0x4F,
- 0x20,0x2E,0xD3,0xFC,0x19,0xEE,0xB8,0xF3,0x35,0x7D,0xBA,0x86,
- 0x2A,0xC3,0xC8,0x6E,0xF4,0x99,0x75,0x65,0xD3,0x7A,0x9E,0xDF,
- 0xD4,0x1F,0x88,0xE3,0x17,0xFC,0xA1,0xED,0xA2,0xB6,0x77,0x84,
- 0xAA,0x08,0xF2,0x97,0x59,0x7A,0xA0,0x03,0x0D,0x3E,0x7E,0x6D,
- 0x65,0x6A,0xA4,0xEA,0x54,0xA9,0x52,0x5F,0x63,0xB4,0xBC,0x98,
- 0x4E,0xF6,0xE1,0xA4,0xEE,0x16,0x0A,0xB0,0x01,0xBD,0x9F,0xA1,
- 0xE8,0x23,0x29,0x56,0x40,0x95,0x13,0xEB,0xCB,0xD5,0xFC,0x76,
- 0x1A,0x41,0x26,0xCE,0x20,0xEB,0x30,0x10,0x17,0x07,0xE1,0x8C,
- 0xAC,0x57,0x37,0x8B,0xE8,0x01,0xDE,0xA9,0xEF,0xA4,0xC2,0xA4,
- 0x6E,0x48,0x25,0x11,0x33,0x11,0xD4,0x52,0x79,0x87,0x9F,0x75,
- 0x61,0xF7,0x9C,0x7D,0x36,0x41,0xCB,0xEC,0x8F,0xEA,0x4A,0x47,
- 0x6A,0x36,0x37,0x75,0xB9,0x8E,0xF5,0x5F,0x67,0xCF,0x1F,0xD8,
- 0xCA,0x70,0x42,0xC7,0xA2,0xED,0x0F,0x7D,0xBE,0x43,0x08,0x28,
- 0x66,0x3D,0xDD,0x87,0x0D,0x61,0x6E,0xD0,0xE7,0x49,0xD1,0x70,
- 0xA9,0x4D,0xD5,0xFD,0xED,0xF2,0x6D,0x32,0x17,0x97,0x5B,0x06,
- 0x60,0x9C,0x5F,0xA3,0x5D,0x34,0x14,0x7E,0x63,0x54,0xE4,0x7E,
- 0x09,0x8F,0xBB,0x8E,0xA0,0xD0,0x96,0xAC,0x30,0x20,0x39,0x3B,
- 0x8C,0x92,0x65,0x37,0x0A,0x8F,0xEC,0x72,0x8B,0x61,0x7D,0x62,
- 0x24,0x54,0xE9,0x1D,0x01,0x68,0x89,0xC4,0x7B,0x3C,0x48,0x62,
- 0x9B,0x83,0x11,0x3A,0x0B,0x0D,0xEF,0x5A,0xE4,0x7A,0xA0,0x69,
- 0xF4,0x54,0xB5,0x5B
-_EOF_
- ;;
- 4096)
- cat << \_EOF_
- 0xE3,0xA6,0x64,0x2D,0xE8,0x01,0xD0,0x81,0x67,0xCF,0x12,0x38,
- 0x5C,0x99,0x48,0x37,0xD7,0x0F,0x8D,0x10,0xEA,0x88,0x31,0x6D,
- 0xD4,0x69,0x10,0x57,0x94,0x8E,0xE8,0xF9,0x22,0xFE,0x0D,0x55,
- 0xC6,0x9D,0x29,0x7E,0x45,0x89,0xAA,0xD5,0x98,0xD2,0x98,0xFE,
- 0x03,0x54,0x5E,0x91,0x4C,0x4A,0xA7,0xFF,0x1F,0x2F,0x41,0x34,
- 0x03,0x9B,0x64,0x0A,0xFA,0x53,0xC7,0x45,0xD7,0x41,0x3F,0x16,
- 0xCD,0x40,0x9E,0xF2,0xC3,0xBD,0x49,0x2C,0x0C,0x35,0x9B,0x2F,
- 0x7D,0xA5,0x07,0x58,0xD1,0xFD,0xE9,0x6B,0x7A,0x54,0xA9,0xC2,
- 0xAC,0x09,0x7F,0x58,0xD5,0x52,0xB2,0x8A,0x5D,0xEC,0x41,0x23,
- 0x93,0xF4,0x05,0x8B,0x46,0x0E,0x46,0x46,0xC5,0xB4,0x75,0xCB,
- 0x1D,0x1D,0x6E,0x81,0xC5,0x55,0x24,0x1D,0x09,0x23,0xE2,0x3F,
- 0xF4,0x48,0x60,0xD7,0x95,0xC0,0x8B,0x71,0x11,0xA6,0x0B,0x04,
- 0x29,0xB6,0xAD,0xBF,0x05,0x6F,0x3B,0xB3,0x70,0x34,0xA5,0xF9,
- 0x14,0x81,0xD5,0xEA,0x3C,0x3C,0x38,0x44,0xCF,0x3D,0x32,0x29,
- 0x92,0xD5,0x1A,0x3C,0x25,0xB7,0x3D,0x42,0x17,0x96,0x8B,0xEE,
- 0xC3,0xE7,0x61,0x3A,0x51,0xC5,0x2A,0x51,0xBA,0x8F,0xD0,0x4C,
- 0x51,0x19,0xBE,0x35,0x1A,0x2E,0x9B,0x55,0x02,0xA7,0x5A,0xBF,
- 0xA2,0x00,0xF9,0xFF,0x4B,0xCA,0x76,0x25,0x3D,0x3B,0xB1,0x04,
- 0x9A,0x6D,0x7E,0x12,0xBB,0xBE,0x6A,0x5A,0xB2,0x87,0x8B,0xBC,
- 0xB9,0x7C,0x6A,0xE7,0x5E,0xC3,0x41,0x91,0x24,0xAD,0x5C,0xC7,
- 0x3F,0x24,0x77,0x17,0x53,0x9D,0x6A,0x5A,0x8E,0x39,0x00,0x1B,
- 0x49,0x93,0x07,0x6C,0x67,0xF3,0x1C,0x24,0x57,0x76,0x5E,0x78,
- 0xF1,0x8D,0x81,0xFF,0x81,0xD0,0x1B,0x7A,0x04,0xAC,0x7D,0x5B,
- 0x35,0x5F,0x45,0x25,0xAE,0x30,0x11,0x5B,0x34,0x17,0xE7,0x2D,
- 0x9D,0xE7,0x56,0x90,0x75,0x24,0x0C,0x01,0x84,0x38,0x1A,0x62,
- 0x55,0x43,0x66,0x21,0x29,0x44,0xE5,0x4B,0x90,0x9E,0x48,0x92,
- 0x0B,0x96,0x2A,0xD0,0xCD,0x3A,0xA4,0xBE,0xE7,0xDC,0xA3,0xFB,
- 0x0F,0xA3,0x9B,0xF7,0xA9,0x26,0x5A,0xCC,0x7F,0x4B,0x1A,0x5F,
- 0xD6,0x32,0xA9,0x71,0xA1,0x10,0xE5,0x7C,0x4F,0x59,0xFE,0x3D,
- 0x60,0x41,0x0A,0xA7,0x68,0x60,0x1E,0xDE,0x6E,0xF7,0x71,0x4D,
- 0xBE,0xC8,0x49,0xF8,0x57,0x7C,0x99,0x6E,0x59,0x32,0xF8,0x26,
- 0xF1,0x25,0x94,0xC5,0xDA,0x78,0xBB,0x48,0x97,0xE8,0xDF,0x70,
- 0x05,0x86,0xE2,0xE7,0x35,0xD7,0x3F,0x23,0x18,0xAA,0x86,0x53,
- 0x6B,0x0D,0xEC,0x93,0x89,0xA4,0xD0,0xDA,0xE3,0xDD,0x11,0x06,
- 0xCE,0xDD,0x4D,0xD3,0xBF,0x9A,0x71,0x5E,0xA7,0x39,0x9A,0x31,
- 0x4B,0x56,0xB3,0x22,0x1B,0x81,0xDC,0xBE,0x0E,0x7B,0x8A,0xAA,
- 0x37,0x61,0xED,0x4D,0xEE,0x1A,0xC3,0x54,0xBC,0x4F,0x0E,0x61,
- 0x38,0x00,0xAA,0x45,0x18,0xC2,0xDF,0xA5,0x3D,0x75,0x98,0x16,
- 0xBB,0x0A,0x39,0x9A,0xFE,0x1F,0x53,0xAD,0xC3,0xEA,0xDF,0xC6,
- 0x3D,0xD5,0xBA,0xC8,0xF3,0x03,0x3A,0x3B,0x8D,0x03,0x84,0xCD,
- 0x86,0xED,0x42,0xDB,0xD8,0xE0,0xC1,0xAF,0xB1,0xDD,0xB5,0x35,
- 0x28,0xB1,0x02,0xE2,0x9B,0x12,0x2E,0x12,0x02,0x1C,0x7D,0x3B,
- 0x3B,0x8D,0xAF,0x9D,0x3F,0xD6,0xE0,0x53
-_EOF_
- ;;
- 8192)
- cat << \_EOF_
- 0x9C,0xC3,0x9C,0x6C,0x61,0xC5,0xFA,0x32,0xB8,0x86,0x5A,0x38,
- 0xED,0x46,0x5C,0x81,0x08,0xD9,0x69,0x11,0x44,0x50,0x97,0x4D,
- 0xCB,0x09,0xFC,0xD1,0x68,0x9F,0x4E,0x96,0x10,0xFF,0xDA,0xD7,
- 0xA3,0xC9,0x74,0xE9,0xBA,0xDB,0x6B,0x04,0xB8,0xBF,0xF4,0x72,
- 0x6D,0x18,0xB1,0xF4,0x9A,0x77,0xA9,0x94,0xE8,0x13,0xF7,0x1D,
- 0x92,0x12,0x7B,0xB9,0x92,0x71,0x54,0x83,0x73,0x71,0xF6,0xA7,
- 0x12,0xEC,0x62,0xB8,0xDC,0xA1,0x2E,0x00,0x88,0x53,0xF3,0x01,
- 0xAF,0x52,0xF7,0xBB,0xE1,0x7B,0xF1,0x2A,0xD9,0xEF,0x21,0xD4,
- 0x88,0x18,0xEC,0x98,0x72,0x05,0x60,0xEC,0x5A,0x1C,0x2D,0x0D,
- 0x43,0x5D,0x19,0xD6,0x1D,0xD2,0x3C,0x8E,0xD3,0x43,0x62,0x6C,
- 0x32,0x14,0x40,0xD6,0xBE,0xE7,0x84,0x6E,0x76,0xA5,0x90,0x14,
- 0xC8,0x40,0xA3,0x2E,0x6A,0x3D,0x3B,0x43,0x5D,0xB1,0x3F,0x5F,
- 0x6E,0xD5,0x1B,0xE0,0x20,0x82,0x8A,0xEE,0xC5,0x65,0x05,0x62,
- 0xB5,0x96,0xEE,0x27,0xF1,0xF3,0x32,0xE4,0x00,0x7D,0x6A,0x6C,
- 0x45,0x05,0x00,0x4A,0x9C,0x9D,0xB9,0x19,0x77,0xC5,0x31,0xEE,
- 0x6E,0x30,0x54,0x0D,0x08,0xFF,0x19,0xC4,0x34,0xD7,0x9F,0xC9,
- 0x5B,0x89,0x22,0x4E,0xC0,0xBF,0x16,0x3E,0x10,0xBB,0x58,0xBA,
- 0x31,0x5C,0xDC,0xD3,0xD9,0xFF,0x73,0xD9,0x29,0x66,0x4A,0xE6,
- 0xB0,0xBA,0x4B,0x1A,0x3C,0x5E,0xA7,0x19,0x19,0xD8,0x84,0xD2,
- 0x54,0x47,0x86,0xE3,0xCA,0xF7,0x8A,0xC9,0xDB,0x3A,0x5A,0xB7,
- 0xB7,0xA4,0x27,0x57,0x53,0x34,0x9D,0xF2,0xF2,0x26,0x0D,0xAC,
- 0xC5,0xFA,0xE9,0x9A,0xC5,0xDA,0x9D,0xA3,0x2E,0x40,0x85,0x92,
- 0xF4,0x2F,0xEA,0xF7,0xA4,0x6F,0x36,0x36,0x41,0xFA,0x41,0x5B,
- 0x02,0x4E,0xFC,0xDF,0xBB,0x5F,0x74,0x7B,0xFF,0x81,0xEB,0x60,
- 0x08,0x55,0x91,0xBF,0x0C,0x1E,0x80,0xB3,0xC3,0x39,0x5A,0x5D,
- 0x08,0x3E,0x3C,0xB8,0x76,0xE1,0x92,0x37,0xF1,0xCC,0x0C,0x3F,
- 0x46,0xED,0x51,0x2D,0x6F,0x57,0x05,0x47,0x78,0xB5,0xF1,0x6B,
- 0x7C,0xEA,0x51,0xA6,0x88,0xD8,0x63,0x18,0x8E,0x42,0x0E,0x50,
- 0xF1,0xAC,0xD0,0x75,0x0A,0xB5,0x9B,0xD5,0x07,0x3A,0xF0,0x75,
- 0x04,0x27,0xC5,0xBD,0xA6,0xAE,0x18,0xEE,0x30,0x22,0x70,0x56,
- 0x09,0xA7,0xC2,0x26,0x61,0x3B,0x56,0x27,0x82,0x97,0xF6,0xFE,
- 0x7A,0x3D,0x17,0x3C,0xC2,0x27,0x39,0xD3,0xBB,0x80,0xB6,0x42,
- 0x4D,0x20,0xB1,0xC1,0x89,0x00,0x77,0x8C,0x6F,0xDD,0x6F,0x1D,
- 0x44,0xAD,0x1B,0x92,0x6F,0xD6,0x56,0x11,0x6E,0x12,0x5C,0x7F,
- 0x69,0x33,0x17,0x7A,0x20,0xE8,0x5D,0x81,0xC0,0xDD,0x1E,0xBE,
- 0xEF,0x62,0x81,0xF2,0xEA,0xEA,0xDE,0x7B,0xA1,0x8C,0x7D,0x91,
- 0x8B,0x62,0xBD,0x13,0x53,0x41,0xB9,0x45,0x65,0x11,0xB0,0x00,
- 0x7C,0xA6,0x12,0x19,0xDC,0x77,0x26,0xD6,0x13,0xC8,0xDF,0x47,
- 0x7A,0xCE,0xEB,0xD8,0xC3,0xDF,0x7F,0x21,0x27,0x5C,0x4A,0x6B,
- 0xE9,0x27,0xC7,0x60,0x56,0x6E,0xA2,0x5F,0xF2,0xAD,0xB0,0xC3,
- 0x97,0xF6,0xE9,0xDF,0xFB,0x1F,0xE9,0x17,0x06,0x36,0xC5,0x10,
- 0xC0,0x49,0xD5,0x59,0xEA,0x97,0x27,0xE7,0x43,0x64,0xDE,0x31,
- 0xD7,0x14,0x9D,0xDC,0x78,0xC5,0x0E,0xEF,0x6A,0x76,0x57,0x33,
- 0xAF,0x54,0xB1,0x30,0xD0,0x91,0x24,0x09,0x24,0x40,0xD5,0x00,
- 0x9B,0x84,0xF7,0xFC,0xAD,0x7F,0x41,0xBB,0x00,0x84,0x49,0x49,
- 0xA1,0x43,0x44,0xA0,0xA3,0xD1,0xBA,0x49,0xD8,0xCE,0x60,0x90,
- 0x07,0x20,0xCD,0xC8,0xEB,0xD4,0x02,0x71,0xB8,0x60,0xDF,0xA9,
- 0x6B,0xEC,0x25,0x8D,0x71,0x28,0x6A,0x2E,0xF6,0x52,0xF0,0x24,
- 0xF3,0xF5,0x1E,0x00,0x7B,0x7C,0xCA,0x6A,0x6B,0xD7,0x4F,0x3E,
- 0x5E,0x4B,0x85,0xCF,0xF1,0x67,0x9F,0x89,0x5A,0xF4,0x3A,0x29,
- 0x73,0xFF,0xDC,0x68,0x25,0xA5,0x60,0x10,0xFC,0x9A,0x73,0x78,
- 0xEA,0x28,0xC1,0x11,0x3B,0x07,0x46,0xEB,0xDE,0xF1,0xF3,0x2E,
- 0xC7,0xC1,0x24,0xFB,0xC2,0x6C,0x4A,0x38,0x6C,0x9A,0x7F,0x87,
- 0x76,0x30,0xF4,0xCC,0x21,0x49,0xC1,0x66,0x3D,0x95,0xE4,0xAA,
- 0xE2,0x75,0x08,0xAB,0xEF,0xA2,0x51,0x30,0xFE,0x86,0xD0,0xE1,
- 0x4C,0x05,0x0C,0xDE,0x63,0x93,0xB3,0x37,0x11,0x81,0xB5,0x8F,
- 0x84,0xE2,0x48,0xC1,0xF6,0xF6,0xD6,0x50,0x91,0xDE,0x61,0x14,
- 0x7B,0x6E,0x88,0x95,0x30,0x52,0xEF,0xA5,0x03,0x99,0xBE,0x50,
- 0x97,0xE3,0x25,0x8F,0x50,0x01,0x9C,0x54,0x99,0x2E,0x4C,0x6A,
- 0x61,0xD7,0x0D,0xB9,0xFE,0xE9,0xFC,0x37,0xC1,0x6A,0xDF,0x84,
- 0xF4,0x5A,0x7E,0xBA,0x95,0x23,0x5C,0x41,0x35,0xDB,0xF9,0x1E,
- 0x93,0xC6,0x29,0x8E,0x57,0x28,0x3D,0x3A,0xDE,0x31,0x86,0x69,
- 0x3D,0xC3,0x8F,0x27,0x62,0x84,0x77,0x58,0x02,0x7F,0x90,0x76,
- 0x2D,0xDF,0x45,0x70,0x3F,0x04,0x44,0x5C,0xD1,0x8C,0x73,0x5E,
- 0xB5,0xC8,0x9A,0x72,0x3E,0xA9,0x4D,0xFC,0xDC,0xAC,0x7B,0xFF,
- 0x54,0xC2,0x7B,0x3B,0x11,0x6B,0x14,0xA3,0x50,0xDB,0x14,0xB0,
- 0x89,0x5A,0xE7,0xDD,0xBF,0x1E,0x27,0xBC,0xC6,0x30,0xC4,0xD6,
- 0x74,0x13,0x26,0xBA,0x67,0x15,0x56,0x42,0xED,0xDA,0xFF,0x9F,
- 0x4B,0xBE,0x3E,0xBC,0xD0,0xA8,0xCA,0xB1,0x8E,0xB7,0xD0,0xFF,
- 0xE0,0x87,0x67,0xE4,0x51,0xA4,0xB9,0xF3,0x47,0xFA,0x13,0xFA,
- 0xB1,0xDA,0xB6,0xF8,0xEC,0x6D,0x0B,0x2E,0x99,0x37,0xB8,0x66,
- 0x80,0x83,0x3A,0xCA,0x46,0x6D,0xDC,0x24,0x9F,0x83,0x54,0xA9,
- 0x70,0x62,0x21,0x6D,0x28,0x0E,0x63,0x8B,0x91,0x7F,0xFF,0xCD,
- 0x80,0xF5,0xAC,0xE6,0x90,0x97,0x3C,0xB5,0xE8,0x00,0x90,0x96,
- 0xB7,0x26,0x2C,0xB2,0x9C,0xEF,0xBF,0xCC,0xD6,0xA8,0x01,0xA0,
- 0xFC,0x20,0x61,0xBD,0xA9,0xEE,0x5F,0x8B,0x32,0x1C,0x62,0xF0,
- 0x94,0x81,0x86,0x30,0x1B,0xB1,0x12,0xF5,0x58,0x52,0x8D,0xE4,
- 0x99,0x43,0x60,0x9B,0x24,0xF8,0x8B,0x14,0x63,0x0C,0x93,0xF4,
- 0x7A,0x70,0x0A,0xE1,0x45,0x16,0x92,0x9D,0x12,0x50,0x05,0x3C,
- 0x05,0xEE,0x40,0x32,0x4D,0x99,0xFF,0xF6,0x14,0x25,0xF6,0xDF,
- 0xD8,0xDA,0xE0,0x85,0x1B,0x3F,0x2C,0x50,0xD9,0x01,0x4B,0x01,
- 0x65,0x2C,0x75,0x32,0xBA,0x6F,0x00,0x56,0xD3,0x83,0xC8,0x44,
- 0x9B,0x62,0x3F,0x88,0xA7,0x18,0xAC,0x69,0xBB,0xF3,0x14,0xD3,
- 0xA4,0x09,0x6C,0x4A,0x14,0x0C,0x55,0x95,0x7A,0x33,0x21,0x99,
- 0x0F,0x01,0x00,0x5D,0x2D,0xAB,0xEB,0x7A,0x76,0x03,0xE7,0x2A,
- 0x1D,0xC2,0x86,0x4B
-_EOF_
- ;;
- *)
- return 1
- ;;
- esac
-
- cat << \_EOF_
- };
- static unsigned char dhg[] = {
- 0x02,
- };
-
- DH *dh = DH_new();;
- BIGNUM *dhp_bn, *dhg_bn;
-
- if (dh == NULL) {
- return NULL;
- }
-
- dhp_bn = BN_bin2bn(dhp, sizeof (dhp), NULL);
- dhg_bn = BN_bin2bn(dhg, sizeof (dhg), NULL);
-
-#ifdef TCLTLS_OPENSSL_PRE_1_1_API
- dh->p = dhp_bn;
- dh->g = dhg_bn;
-
- if (dhp_bn == NULL || dhg_bn == NULL) {
-#else
- if (dhp_bn == NULL || dhg_bn == NULL || !DH_set0_pqg(dh, dhp_bn, NULL, dhg_bn)) {
-#endif
- DH_free(dh);
- BN_free(dhp_bn);
- BN_free(dhg_bn);
- return(NULL);
- }
-
- return(dh);
-}
-_EOF_
-
- return 0
-}
-
-# Enable support for giving the same DH params each time
-if [ "${option_fallback}" = '1' ]; then
- gen_dh_params_fallback && exit 0
-
- echo "Unable to generate fallback parameters for DH of ${bits} bits" >&2
-
- exit 1
-fi
-
-echo "*****************************" >&2
-echo "** Generating DH Primes. **" >&2
-echo "** This will take a while. **" >&2
-echo "*****************************" >&2
-echo "Use OpenSSL" >&2
-gen_dh_params_openssl && exit 0
-echo "Use Remote" >&2
-gen_dh_params_remote && exit 0
-echo "Use fallback" >&2
-gen_dh_params_fallback && exit 0
-
-echo "Unable to generate parameters for DH of ${bits} bits" >&2
-
-exit 1
ADDED generic/HEADER
Index: generic/HEADER
==================================================================
--- /dev/null
+++ generic/HEADER
@@ -0,0 +1,7 @@
+TclTLS @@VERS@@
+==========
+
+Release Date: @@DATE@@
+
+https://tcltls.rkeene.org/
+
ADDED generic/gen_dh_params
Index: generic/gen_dh_params
==================================================================
--- /dev/null
+++ generic/gen_dh_params
@@ -0,0 +1,280 @@
+#! /usr/bin/env sh
+
+bits='2048'
+option_fallback='0'
+for arg in "$@"; do
+ case "${arg}" in
+ fallback)
+ option_fallback='1'
+ ;;
+ bits=*)
+ bits="`echo "${arg}" | cut -f 2 -d =`"
+ ;;
+ esac
+done
+
+openssl_dhparam() {
+ if openssl dhparam -C "$@" | sed \
+ -e 's/^\(static \)*DH \*get_dh[0-9]*/static DH *get_dhParams/' \
+ -e '/^-----BEGIN DH PARAMETERS-----$/,/^-----END DH PARAMETERS-----$/ d;/^#/ d'
+ then
+ return 0
+ fi
+
+ return 1
+}
+
+gen_dh_params_openssl() {
+ openssl_dhparam "${bits}" < /dev/null || return 1
+ return 0
+}
+
+gen_dh_params_remote() {
+ url="https://2ton.com.au/dhparam/${bits}"
+
+ r_input="`curl -sS "${url}"`" || \
+ r_input="`wget -O - -o /dev/null "${url}"`" || return 1
+
+ if r_output="`echo "${r_input}" | openssl_dhparam`"; then
+ echo "${r_output}"
+
+ return 0
+ fi
+
+ return 1
+}
+
+gen_dh_params_fallback() {
+ cat << \_EOF_
+DH *get_dhParams(void) {
+ static unsigned char dhp[] = {
+_EOF_
+ case "${bits}" in
+ 2048)
+ cat << \_EOF_
+ 0xC1,0x51,0x58,0x69,0xFB,0xE8,0x6C,0x47,0x2B,0x86,0x61,0x4F,
+ 0x20,0x2E,0xD3,0xFC,0x19,0xEE,0xB8,0xF3,0x35,0x7D,0xBA,0x86,
+ 0x2A,0xC3,0xC8,0x6E,0xF4,0x99,0x75,0x65,0xD3,0x7A,0x9E,0xDF,
+ 0xD4,0x1F,0x88,0xE3,0x17,0xFC,0xA1,0xED,0xA2,0xB6,0x77,0x84,
+ 0xAA,0x08,0xF2,0x97,0x59,0x7A,0xA0,0x03,0x0D,0x3E,0x7E,0x6D,
+ 0x65,0x6A,0xA4,0xEA,0x54,0xA9,0x52,0x5F,0x63,0xB4,0xBC,0x98,
+ 0x4E,0xF6,0xE1,0xA4,0xEE,0x16,0x0A,0xB0,0x01,0xBD,0x9F,0xA1,
+ 0xE8,0x23,0x29,0x56,0x40,0x95,0x13,0xEB,0xCB,0xD5,0xFC,0x76,
+ 0x1A,0x41,0x26,0xCE,0x20,0xEB,0x30,0x10,0x17,0x07,0xE1,0x8C,
+ 0xAC,0x57,0x37,0x8B,0xE8,0x01,0xDE,0xA9,0xEF,0xA4,0xC2,0xA4,
+ 0x6E,0x48,0x25,0x11,0x33,0x11,0xD4,0x52,0x79,0x87,0x9F,0x75,
+ 0x61,0xF7,0x9C,0x7D,0x36,0x41,0xCB,0xEC,0x8F,0xEA,0x4A,0x47,
+ 0x6A,0x36,0x37,0x75,0xB9,0x8E,0xF5,0x5F,0x67,0xCF,0x1F,0xD8,
+ 0xCA,0x70,0x42,0xC7,0xA2,0xED,0x0F,0x7D,0xBE,0x43,0x08,0x28,
+ 0x66,0x3D,0xDD,0x87,0x0D,0x61,0x6E,0xD0,0xE7,0x49,0xD1,0x70,
+ 0xA9,0x4D,0xD5,0xFD,0xED,0xF2,0x6D,0x32,0x17,0x97,0x5B,0x06,
+ 0x60,0x9C,0x5F,0xA3,0x5D,0x34,0x14,0x7E,0x63,0x54,0xE4,0x7E,
+ 0x09,0x8F,0xBB,0x8E,0xA0,0xD0,0x96,0xAC,0x30,0x20,0x39,0x3B,
+ 0x8C,0x92,0x65,0x37,0x0A,0x8F,0xEC,0x72,0x8B,0x61,0x7D,0x62,
+ 0x24,0x54,0xE9,0x1D,0x01,0x68,0x89,0xC4,0x7B,0x3C,0x48,0x62,
+ 0x9B,0x83,0x11,0x3A,0x0B,0x0D,0xEF,0x5A,0xE4,0x7A,0xA0,0x69,
+ 0xF4,0x54,0xB5,0x5B
+_EOF_
+ ;;
+ 4096)
+ cat << \_EOF_
+ 0xE3,0xA6,0x64,0x2D,0xE8,0x01,0xD0,0x81,0x67,0xCF,0x12,0x38,
+ 0x5C,0x99,0x48,0x37,0xD7,0x0F,0x8D,0x10,0xEA,0x88,0x31,0x6D,
+ 0xD4,0x69,0x10,0x57,0x94,0x8E,0xE8,0xF9,0x22,0xFE,0x0D,0x55,
+ 0xC6,0x9D,0x29,0x7E,0x45,0x89,0xAA,0xD5,0x98,0xD2,0x98,0xFE,
+ 0x03,0x54,0x5E,0x91,0x4C,0x4A,0xA7,0xFF,0x1F,0x2F,0x41,0x34,
+ 0x03,0x9B,0x64,0x0A,0xFA,0x53,0xC7,0x45,0xD7,0x41,0x3F,0x16,
+ 0xCD,0x40,0x9E,0xF2,0xC3,0xBD,0x49,0x2C,0x0C,0x35,0x9B,0x2F,
+ 0x7D,0xA5,0x07,0x58,0xD1,0xFD,0xE9,0x6B,0x7A,0x54,0xA9,0xC2,
+ 0xAC,0x09,0x7F,0x58,0xD5,0x52,0xB2,0x8A,0x5D,0xEC,0x41,0x23,
+ 0x93,0xF4,0x05,0x8B,0x46,0x0E,0x46,0x46,0xC5,0xB4,0x75,0xCB,
+ 0x1D,0x1D,0x6E,0x81,0xC5,0x55,0x24,0x1D,0x09,0x23,0xE2,0x3F,
+ 0xF4,0x48,0x60,0xD7,0x95,0xC0,0x8B,0x71,0x11,0xA6,0x0B,0x04,
+ 0x29,0xB6,0xAD,0xBF,0x05,0x6F,0x3B,0xB3,0x70,0x34,0xA5,0xF9,
+ 0x14,0x81,0xD5,0xEA,0x3C,0x3C,0x38,0x44,0xCF,0x3D,0x32,0x29,
+ 0x92,0xD5,0x1A,0x3C,0x25,0xB7,0x3D,0x42,0x17,0x96,0x8B,0xEE,
+ 0xC3,0xE7,0x61,0x3A,0x51,0xC5,0x2A,0x51,0xBA,0x8F,0xD0,0x4C,
+ 0x51,0x19,0xBE,0x35,0x1A,0x2E,0x9B,0x55,0x02,0xA7,0x5A,0xBF,
+ 0xA2,0x00,0xF9,0xFF,0x4B,0xCA,0x76,0x25,0x3D,0x3B,0xB1,0x04,
+ 0x9A,0x6D,0x7E,0x12,0xBB,0xBE,0x6A,0x5A,0xB2,0x87,0x8B,0xBC,
+ 0xB9,0x7C,0x6A,0xE7,0x5E,0xC3,0x41,0x91,0x24,0xAD,0x5C,0xC7,
+ 0x3F,0x24,0x77,0x17,0x53,0x9D,0x6A,0x5A,0x8E,0x39,0x00,0x1B,
+ 0x49,0x93,0x07,0x6C,0x67,0xF3,0x1C,0x24,0x57,0x76,0x5E,0x78,
+ 0xF1,0x8D,0x81,0xFF,0x81,0xD0,0x1B,0x7A,0x04,0xAC,0x7D,0x5B,
+ 0x35,0x5F,0x45,0x25,0xAE,0x30,0x11,0x5B,0x34,0x17,0xE7,0x2D,
+ 0x9D,0xE7,0x56,0x90,0x75,0x24,0x0C,0x01,0x84,0x38,0x1A,0x62,
+ 0x55,0x43,0x66,0x21,0x29,0x44,0xE5,0x4B,0x90,0x9E,0x48,0x92,
+ 0x0B,0x96,0x2A,0xD0,0xCD,0x3A,0xA4,0xBE,0xE7,0xDC,0xA3,0xFB,
+ 0x0F,0xA3,0x9B,0xF7,0xA9,0x26,0x5A,0xCC,0x7F,0x4B,0x1A,0x5F,
+ 0xD6,0x32,0xA9,0x71,0xA1,0x10,0xE5,0x7C,0x4F,0x59,0xFE,0x3D,
+ 0x60,0x41,0x0A,0xA7,0x68,0x60,0x1E,0xDE,0x6E,0xF7,0x71,0x4D,
+ 0xBE,0xC8,0x49,0xF8,0x57,0x7C,0x99,0x6E,0x59,0x32,0xF8,0x26,
+ 0xF1,0x25,0x94,0xC5,0xDA,0x78,0xBB,0x48,0x97,0xE8,0xDF,0x70,
+ 0x05,0x86,0xE2,0xE7,0x35,0xD7,0x3F,0x23,0x18,0xAA,0x86,0x53,
+ 0x6B,0x0D,0xEC,0x93,0x89,0xA4,0xD0,0xDA,0xE3,0xDD,0x11,0x06,
+ 0xCE,0xDD,0x4D,0xD3,0xBF,0x9A,0x71,0x5E,0xA7,0x39,0x9A,0x31,
+ 0x4B,0x56,0xB3,0x22,0x1B,0x81,0xDC,0xBE,0x0E,0x7B,0x8A,0xAA,
+ 0x37,0x61,0xED,0x4D,0xEE,0x1A,0xC3,0x54,0xBC,0x4F,0x0E,0x61,
+ 0x38,0x00,0xAA,0x45,0x18,0xC2,0xDF,0xA5,0x3D,0x75,0x98,0x16,
+ 0xBB,0x0A,0x39,0x9A,0xFE,0x1F,0x53,0xAD,0xC3,0xEA,0xDF,0xC6,
+ 0x3D,0xD5,0xBA,0xC8,0xF3,0x03,0x3A,0x3B,0x8D,0x03,0x84,0xCD,
+ 0x86,0xED,0x42,0xDB,0xD8,0xE0,0xC1,0xAF,0xB1,0xDD,0xB5,0x35,
+ 0x28,0xB1,0x02,0xE2,0x9B,0x12,0x2E,0x12,0x02,0x1C,0x7D,0x3B,
+ 0x3B,0x8D,0xAF,0x9D,0x3F,0xD6,0xE0,0x53
+_EOF_
+ ;;
+ 8192)
+ cat << \_EOF_
+ 0x9C,0xC3,0x9C,0x6C,0x61,0xC5,0xFA,0x32,0xB8,0x86,0x5A,0x38,
+ 0xED,0x46,0x5C,0x81,0x08,0xD9,0x69,0x11,0x44,0x50,0x97,0x4D,
+ 0xCB,0x09,0xFC,0xD1,0x68,0x9F,0x4E,0x96,0x10,0xFF,0xDA,0xD7,
+ 0xA3,0xC9,0x74,0xE9,0xBA,0xDB,0x6B,0x04,0xB8,0xBF,0xF4,0x72,
+ 0x6D,0x18,0xB1,0xF4,0x9A,0x77,0xA9,0x94,0xE8,0x13,0xF7,0x1D,
+ 0x92,0x12,0x7B,0xB9,0x92,0x71,0x54,0x83,0x73,0x71,0xF6,0xA7,
+ 0x12,0xEC,0x62,0xB8,0xDC,0xA1,0x2E,0x00,0x88,0x53,0xF3,0x01,
+ 0xAF,0x52,0xF7,0xBB,0xE1,0x7B,0xF1,0x2A,0xD9,0xEF,0x21,0xD4,
+ 0x88,0x18,0xEC,0x98,0x72,0x05,0x60,0xEC,0x5A,0x1C,0x2D,0x0D,
+ 0x43,0x5D,0x19,0xD6,0x1D,0xD2,0x3C,0x8E,0xD3,0x43,0x62,0x6C,
+ 0x32,0x14,0x40,0xD6,0xBE,0xE7,0x84,0x6E,0x76,0xA5,0x90,0x14,
+ 0xC8,0x40,0xA3,0x2E,0x6A,0x3D,0x3B,0x43,0x5D,0xB1,0x3F,0x5F,
+ 0x6E,0xD5,0x1B,0xE0,0x20,0x82,0x8A,0xEE,0xC5,0x65,0x05,0x62,
+ 0xB5,0x96,0xEE,0x27,0xF1,0xF3,0x32,0xE4,0x00,0x7D,0x6A,0x6C,
+ 0x45,0x05,0x00,0x4A,0x9C,0x9D,0xB9,0x19,0x77,0xC5,0x31,0xEE,
+ 0x6E,0x30,0x54,0x0D,0x08,0xFF,0x19,0xC4,0x34,0xD7,0x9F,0xC9,
+ 0x5B,0x89,0x22,0x4E,0xC0,0xBF,0x16,0x3E,0x10,0xBB,0x58,0xBA,
+ 0x31,0x5C,0xDC,0xD3,0xD9,0xFF,0x73,0xD9,0x29,0x66,0x4A,0xE6,
+ 0xB0,0xBA,0x4B,0x1A,0x3C,0x5E,0xA7,0x19,0x19,0xD8,0x84,0xD2,
+ 0x54,0x47,0x86,0xE3,0xCA,0xF7,0x8A,0xC9,0xDB,0x3A,0x5A,0xB7,
+ 0xB7,0xA4,0x27,0x57,0x53,0x34,0x9D,0xF2,0xF2,0x26,0x0D,0xAC,
+ 0xC5,0xFA,0xE9,0x9A,0xC5,0xDA,0x9D,0xA3,0x2E,0x40,0x85,0x92,
+ 0xF4,0x2F,0xEA,0xF7,0xA4,0x6F,0x36,0x36,0x41,0xFA,0x41,0x5B,
+ 0x02,0x4E,0xFC,0xDF,0xBB,0x5F,0x74,0x7B,0xFF,0x81,0xEB,0x60,
+ 0x08,0x55,0x91,0xBF,0x0C,0x1E,0x80,0xB3,0xC3,0x39,0x5A,0x5D,
+ 0x08,0x3E,0x3C,0xB8,0x76,0xE1,0x92,0x37,0xF1,0xCC,0x0C,0x3F,
+ 0x46,0xED,0x51,0x2D,0x6F,0x57,0x05,0x47,0x78,0xB5,0xF1,0x6B,
+ 0x7C,0xEA,0x51,0xA6,0x88,0xD8,0x63,0x18,0x8E,0x42,0x0E,0x50,
+ 0xF1,0xAC,0xD0,0x75,0x0A,0xB5,0x9B,0xD5,0x07,0x3A,0xF0,0x75,
+ 0x04,0x27,0xC5,0xBD,0xA6,0xAE,0x18,0xEE,0x30,0x22,0x70,0x56,
+ 0x09,0xA7,0xC2,0x26,0x61,0x3B,0x56,0x27,0x82,0x97,0xF6,0xFE,
+ 0x7A,0x3D,0x17,0x3C,0xC2,0x27,0x39,0xD3,0xBB,0x80,0xB6,0x42,
+ 0x4D,0x20,0xB1,0xC1,0x89,0x00,0x77,0x8C,0x6F,0xDD,0x6F,0x1D,
+ 0x44,0xAD,0x1B,0x92,0x6F,0xD6,0x56,0x11,0x6E,0x12,0x5C,0x7F,
+ 0x69,0x33,0x17,0x7A,0x20,0xE8,0x5D,0x81,0xC0,0xDD,0x1E,0xBE,
+ 0xEF,0x62,0x81,0xF2,0xEA,0xEA,0xDE,0x7B,0xA1,0x8C,0x7D,0x91,
+ 0x8B,0x62,0xBD,0x13,0x53,0x41,0xB9,0x45,0x65,0x11,0xB0,0x00,
+ 0x7C,0xA6,0x12,0x19,0xDC,0x77,0x26,0xD6,0x13,0xC8,0xDF,0x47,
+ 0x7A,0xCE,0xEB,0xD8,0xC3,0xDF,0x7F,0x21,0x27,0x5C,0x4A,0x6B,
+ 0xE9,0x27,0xC7,0x60,0x56,0x6E,0xA2,0x5F,0xF2,0xAD,0xB0,0xC3,
+ 0x97,0xF6,0xE9,0xDF,0xFB,0x1F,0xE9,0x17,0x06,0x36,0xC5,0x10,
+ 0xC0,0x49,0xD5,0x59,0xEA,0x97,0x27,0xE7,0x43,0x64,0xDE,0x31,
+ 0xD7,0x14,0x9D,0xDC,0x78,0xC5,0x0E,0xEF,0x6A,0x76,0x57,0x33,
+ 0xAF,0x54,0xB1,0x30,0xD0,0x91,0x24,0x09,0x24,0x40,0xD5,0x00,
+ 0x9B,0x84,0xF7,0xFC,0xAD,0x7F,0x41,0xBB,0x00,0x84,0x49,0x49,
+ 0xA1,0x43,0x44,0xA0,0xA3,0xD1,0xBA,0x49,0xD8,0xCE,0x60,0x90,
+ 0x07,0x20,0xCD,0xC8,0xEB,0xD4,0x02,0x71,0xB8,0x60,0xDF,0xA9,
+ 0x6B,0xEC,0x25,0x8D,0x71,0x28,0x6A,0x2E,0xF6,0x52,0xF0,0x24,
+ 0xF3,0xF5,0x1E,0x00,0x7B,0x7C,0xCA,0x6A,0x6B,0xD7,0x4F,0x3E,
+ 0x5E,0x4B,0x85,0xCF,0xF1,0x67,0x9F,0x89,0x5A,0xF4,0x3A,0x29,
+ 0x73,0xFF,0xDC,0x68,0x25,0xA5,0x60,0x10,0xFC,0x9A,0x73,0x78,
+ 0xEA,0x28,0xC1,0x11,0x3B,0x07,0x46,0xEB,0xDE,0xF1,0xF3,0x2E,
+ 0xC7,0xC1,0x24,0xFB,0xC2,0x6C,0x4A,0x38,0x6C,0x9A,0x7F,0x87,
+ 0x76,0x30,0xF4,0xCC,0x21,0x49,0xC1,0x66,0x3D,0x95,0xE4,0xAA,
+ 0xE2,0x75,0x08,0xAB,0xEF,0xA2,0x51,0x30,0xFE,0x86,0xD0,0xE1,
+ 0x4C,0x05,0x0C,0xDE,0x63,0x93,0xB3,0x37,0x11,0x81,0xB5,0x8F,
+ 0x84,0xE2,0x48,0xC1,0xF6,0xF6,0xD6,0x50,0x91,0xDE,0x61,0x14,
+ 0x7B,0x6E,0x88,0x95,0x30,0x52,0xEF,0xA5,0x03,0x99,0xBE,0x50,
+ 0x97,0xE3,0x25,0x8F,0x50,0x01,0x9C,0x54,0x99,0x2E,0x4C,0x6A,
+ 0x61,0xD7,0x0D,0xB9,0xFE,0xE9,0xFC,0x37,0xC1,0x6A,0xDF,0x84,
+ 0xF4,0x5A,0x7E,0xBA,0x95,0x23,0x5C,0x41,0x35,0xDB,0xF9,0x1E,
+ 0x93,0xC6,0x29,0x8E,0x57,0x28,0x3D,0x3A,0xDE,0x31,0x86,0x69,
+ 0x3D,0xC3,0x8F,0x27,0x62,0x84,0x77,0x58,0x02,0x7F,0x90,0x76,
+ 0x2D,0xDF,0x45,0x70,0x3F,0x04,0x44,0x5C,0xD1,0x8C,0x73,0x5E,
+ 0xB5,0xC8,0x9A,0x72,0x3E,0xA9,0x4D,0xFC,0xDC,0xAC,0x7B,0xFF,
+ 0x54,0xC2,0x7B,0x3B,0x11,0x6B,0x14,0xA3,0x50,0xDB,0x14,0xB0,
+ 0x89,0x5A,0xE7,0xDD,0xBF,0x1E,0x27,0xBC,0xC6,0x30,0xC4,0xD6,
+ 0x74,0x13,0x26,0xBA,0x67,0x15,0x56,0x42,0xED,0xDA,0xFF,0x9F,
+ 0x4B,0xBE,0x3E,0xBC,0xD0,0xA8,0xCA,0xB1,0x8E,0xB7,0xD0,0xFF,
+ 0xE0,0x87,0x67,0xE4,0x51,0xA4,0xB9,0xF3,0x47,0xFA,0x13,0xFA,
+ 0xB1,0xDA,0xB6,0xF8,0xEC,0x6D,0x0B,0x2E,0x99,0x37,0xB8,0x66,
+ 0x80,0x83,0x3A,0xCA,0x46,0x6D,0xDC,0x24,0x9F,0x83,0x54,0xA9,
+ 0x70,0x62,0x21,0x6D,0x28,0x0E,0x63,0x8B,0x91,0x7F,0xFF,0xCD,
+ 0x80,0xF5,0xAC,0xE6,0x90,0x97,0x3C,0xB5,0xE8,0x00,0x90,0x96,
+ 0xB7,0x26,0x2C,0xB2,0x9C,0xEF,0xBF,0xCC,0xD6,0xA8,0x01,0xA0,
+ 0xFC,0x20,0x61,0xBD,0xA9,0xEE,0x5F,0x8B,0x32,0x1C,0x62,0xF0,
+ 0x94,0x81,0x86,0x30,0x1B,0xB1,0x12,0xF5,0x58,0x52,0x8D,0xE4,
+ 0x99,0x43,0x60,0x9B,0x24,0xF8,0x8B,0x14,0x63,0x0C,0x93,0xF4,
+ 0x7A,0x70,0x0A,0xE1,0x45,0x16,0x92,0x9D,0x12,0x50,0x05,0x3C,
+ 0x05,0xEE,0x40,0x32,0x4D,0x99,0xFF,0xF6,0x14,0x25,0xF6,0xDF,
+ 0xD8,0xDA,0xE0,0x85,0x1B,0x3F,0x2C,0x50,0xD9,0x01,0x4B,0x01,
+ 0x65,0x2C,0x75,0x32,0xBA,0x6F,0x00,0x56,0xD3,0x83,0xC8,0x44,
+ 0x9B,0x62,0x3F,0x88,0xA7,0x18,0xAC,0x69,0xBB,0xF3,0x14,0xD3,
+ 0xA4,0x09,0x6C,0x4A,0x14,0x0C,0x55,0x95,0x7A,0x33,0x21,0x99,
+ 0x0F,0x01,0x00,0x5D,0x2D,0xAB,0xEB,0x7A,0x76,0x03,0xE7,0x2A,
+ 0x1D,0xC2,0x86,0x4B
+_EOF_
+ ;;
+ *)
+ return 1
+ ;;
+ esac
+
+ cat << \_EOF_
+ };
+ static unsigned char dhg[] = {
+ 0x02,
+ };
+
+ DH *dh = DH_new();;
+ BIGNUM *dhp_bn, *dhg_bn;
+
+ if (dh == NULL) {
+ return NULL;
+ }
+
+ dhp_bn = BN_bin2bn(dhp, sizeof (dhp), NULL);
+ dhg_bn = BN_bin2bn(dhg, sizeof (dhg), NULL);
+
+#ifdef TCLTLS_OPENSSL_PRE_1_1_API
+ dh->p = dhp_bn;
+ dh->g = dhg_bn;
+
+ if (dhp_bn == NULL || dhg_bn == NULL) {
+#else
+ if (dhp_bn == NULL || dhg_bn == NULL || !DH_set0_pqg(dh, dhp_bn, NULL, dhg_bn)) {
+#endif
+ DH_free(dh);
+ BN_free(dhp_bn);
+ BN_free(dhg_bn);
+ return(NULL);
+ }
+
+ return(dh);
+}
+_EOF_
+
+ return 0
+}
+
+# Enable support for giving the same DH params each time
+if [ "${option_fallback}" = '1' ]; then
+ gen_dh_params_fallback && exit 0
+
+ echo "Unable to generate fallback parameters for DH of ${bits} bits" >&2
+
+ exit 1
+fi
+
+echo "*****************************" >&2
+echo "** Generating DH Primes. **" >&2
+echo "** This will take a while. **" >&2
+echo "*****************************" >&2
+echo "Use OpenSSL" >&2
+gen_dh_params_openssl && exit 0
+echo "Use Remote" >&2
+gen_dh_params_remote && exit 0
+echo "Use fallback" >&2
+gen_dh_params_fallback && exit 0
+
+echo "Unable to generate parameters for DH of ${bits} bits" >&2
+
+exit 1
ADDED generic/tclOpts.h
Index: generic/tclOpts.h
==================================================================
--- /dev/null
+++ generic/tclOpts.h
@@ -0,0 +1,59 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman
+ *
+ * Stylized option processing - requires consistent
+ * external vars: opt, idx, objc, objv
+ */
+
+#ifndef _TCL_OPTS_H
+#define _TCL_OPTS_H
+
+#define OPT_PROLOG(option) \
+ if (strcmp(opt, (option)) == 0) { \
+ if (++idx >= objc) { \
+ Tcl_AppendResult(interp, \
+ "no argument given for ", \
+ (option), " option", \
+ (char *) NULL); \
+ return TCL_ERROR; \
+ }
+#define OPT_POSTLOG() \
+ continue; \
+ }
+#define OPTOBJ(option, var) \
+ OPT_PROLOG(option) \
+ var = objv[idx]; \
+ OPT_POSTLOG()
+
+#define OPTSTR(option, var) \
+ OPT_PROLOG(option) \
+ var = Tcl_GetStringFromObj(objv[idx], NULL);\
+ OPT_POSTLOG()
+
+#define OPTINT(option, var) \
+ OPT_PROLOG(option) \
+ if (Tcl_GetIntFromObj(interp, objv[idx], \
+ &(var)) != TCL_OK) { \
+ return TCL_ERROR; \
+ } \
+ OPT_POSTLOG()
+
+#define OPTBOOL(option, var) \
+ OPT_PROLOG(option) \
+ if (Tcl_GetBooleanFromObj(interp, objv[idx],\
+ &(var)) != TCL_OK) { \
+ return TCL_ERROR; \
+ } \
+ OPT_POSTLOG()
+
+#define OPTBYTE(option, var, lvar) \
+ OPT_PROLOG(option) \
+ var = Tcl_GetByteArrayFromObj(objv[idx], &(lvar));\
+ OPT_POSTLOG()
+
+#define OPTBAD(type, list) \
+ Tcl_AppendResult(interp, "bad ", (type), \
+ " \"", opt, "\": must be ", \
+ (list), (char *) NULL)
+
+#endif /* _TCL_OPTS_H */
ADDED generic/tcltls.syms.in
Index: generic/tcltls.syms.in
==================================================================
--- /dev/null
+++ generic/tcltls.syms.in
@@ -0,0 +1,1 @@
+@SYMPREFIX@Tls_Init
ADDED generic/tcltls.vers
Index: generic/tcltls.vers
==================================================================
--- /dev/null
+++ generic/tcltls.vers
@@ -0,0 +1,6 @@
+{
+ global:
+ Tls_Init;
+ local:
+ *;
+};
ADDED generic/tls.c
Index: generic/tls.c
==================================================================
--- /dev/null
+++ generic/tls.c
@@ -0,0 +1,2030 @@
+/*
+ * Copyright (C) 1997-1999 Matt Newman
+ * some modifications:
+ * Copyright (C) 2000 Ajuba Solutions
+ * Copyright (C) 2002 ActiveState Corporation
+ * Copyright (C) 2004 Starfish Systems
+ *
+ * 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
+ * OpenSSL 0.9.2B
+ *
+ * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
+ * providing the Tcl_ReplaceChannel mechanism and working closely with me
+ * to enhance it to support full fileevent semantics.
+ *
+ * Also work done by the follow people provided the impetus to do this "right":
+ * tclSSL (Colin McCormack, Shared Technology)
+ * SSLtcl (Peter Antman)
+ *
+ */
+
+#include "tlsInt.h"
+#include "tclOpts.h"
+#include
+#include
+#include
+
+/*
+ * External functions
+ */
+
+/*
+ * Forward declarations
+ */
+
+#define F2N(key, dsp) \
+ (((key) == NULL) ? (char *) NULL : \
+ Tcl_TranslateFileName(interp, (key), (dsp)))
+#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);
+
+static int TlsLibInit(int uninitialize);
+
+#define TLS_PROTO_SSL2 0x01
+#define TLS_PROTO_SSL3 0x02
+#define TLS_PROTO_TLS1 0x04
+#define TLS_PROTO_TLS1_1 0x08
+#define TLS_PROTO_TLS1_2 0x10
+#define TLS_PROTO_TLS1_3 0x20
+#define ENABLED(flag, mask) (((flag) & (mask)) == (mask))
+
+#define SSLKEYLOGFILE "SSLKEYLOGFILE"
+
+/*
+ * Static data structures
+ */
+
+#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
+#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.
+ */
+
+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 */
+
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * InfoCallback --
+ *
+ * monitors SSL connection process
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Calls callback (if defined)
+ *-------------------------------------------------------------------
+ */
+static void
+InfoCallback(const SSL *ssl, int where, int ret) {
+ State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
+ Tcl_Obj *cmdPtr;
+ char *major; char *minor;
+
+ dprintf("Called");
+
+ if (statePtr->callback == (Tcl_Obj*)NULL)
+ return;
+
+ cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+
+#if 0
+ if (where & SSL_CB_ALERT) {
+ sev = SSL_alert_type_string_long(ret);
+ if (strcmp(sev, "fatal")==0) { /* Map to error */
+ Tls_Error(statePtr, SSL_ERROR(ssl, 0));
+ return;
+ }
+ }
+#endif
+ if (where & SSL_CB_HANDSHAKE_START) {
+ major = "handshake";
+ minor = "start";
+ } else if (where & SSL_CB_HANDSHAKE_DONE) {
+ major = "handshake";
+ minor = "done";
+ } else {
+ if (where & SSL_CB_ALERT) major = "alert";
+ else if (where & SSL_ST_CONNECT) major = "connect";
+ else if (where & SSL_ST_ACCEPT) major = "accept";
+ else major = "unknown";
+
+ if (where & SSL_CB_READ) minor = "read";
+ else if (where & SSL_CB_WRITE) minor = "write";
+ 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_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+ Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(major, -1));
+ Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(minor, -1));
+
+ if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) {
+ Tcl_ListObjAppendElement(statePtr->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));
+ } else {
+ Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
+ Tcl_NewStringObj(SSL_state_string_long(ssl), -1));
+ }
+ Tcl_Preserve((ClientData) statePtr->interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(cmdPtr);
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) statePtr->interp);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * VerifyCallback --
+ *
+ * Monitors SSL certificate validation process.
+ * This is called whenever a certificate is inspected
+ * or decided invalid.
+ *
+ * Results:
+ * A callback bound to the socket may return one of:
+ * 0 - the certificate is deemed invalid
+ * 1 - the certificate is deemed valid
+ * empty string - no change to certificate validation
+ *
+ * Side effects:
+ * The err field of the currently operative State is set
+ * to a string describing the SSL negotiation failure reason
+ *-------------------------------------------------------------------
+ */
+static int
+VerifyCallback(int ok, X509_STORE_CTX *ctx) {
+ Tcl_Obj *cmdPtr, *result;
+ 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);
+ int depth = X509_STORE_CTX_get_error_depth(ctx);
+ int err = X509_STORE_CTX_get_error(ctx);
+ int code;
+
+ dprintf("Verify: %d", ok);
+
+ if (!ok) {
+ errStr = (char*)X509_verify_cert_error_string(err);
+ } else {
+ errStr = (char *)0;
+ }
+
+ if (statePtr->callback == (Tcl_Obj*)NULL) {
+ if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
+ return ok;
+ } else {
+ 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_Preserve((ClientData) statePtr);
+
+ statePtr->flags |= TLS_TCL_CALLBACK;
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(statePtr->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);
+#else
+ Tcl_BackgroundException(statePtr->interp, code);
+#endif
+ ok = 0;
+ } else {
+ result = Tcl_GetObjResult(statePtr->interp);
+ string = Tcl_GetStringFromObj(result, &length);
+ /* An empty result leaves verification unchanged. */
+ if (string != NULL && length > 0) {
+ code = Tcl_GetIntFromObj(statePtr->interp, result, &ok);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->interp, code);
+#endif
+ ok = 0;
+ }
+ }
+ }
+ Tcl_DecrRefCount(cmdPtr);
+
+ statePtr->flags &= ~(TLS_TCL_CALLBACK);
+
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) statePtr->interp);
+ return(ok); /* By default, leave verification unchanged. */
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Error --
+ *
+ * Calls callback with $fd and $msg - so the callback can decide
+ * what to do with errors.
+ *
+ * Side effects:
+ * The err field of the currently operative State is set
+ * to a string describing the SSL negotiation failure reason
+ *-------------------------------------------------------------------
+ */
+void
+Tls_Error(State *statePtr, char *msg) {
+ Tcl_Obj *cmdPtr;
+ int code;
+
+ dprintf("Called");
+
+ if (msg && *msg) {
+ Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL);
+ } else {
+ msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->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);
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->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_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+
+ Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
+ Tcl_NewStringObj(msg, -1));
+
+ Tcl_Preserve((ClientData) statePtr->interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->interp, code);
+#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) statePtr->interp);
+}
+
+void KeyLogCallback(const SSL *ssl, const char *line) {
+ char *str = getenv(SSLKEYLOGFILE);
+ FILE *fd;
+ if (str) {
+ fd = fopen(str, "a");
+ fprintf(fd, "%s\n",line);
+ fclose(fd);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * PasswordCallback --
+ *
+ * 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;
+ int code;
+
+ dprintf("Called");
+
+ if (statePtr->password == NULL) {
+ if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) == TCL_OK) {
+ char *ret = (char *) Tcl_GetStringResult(interp);
+ strncpy(buf, ret, (size_t) size);
+ return (int)strlen(ret);
+ } else {
+ return -1;
+ }
+ }
+
+ cmdPtr = Tcl_DuplicateObj(statePtr->password);
+
+ 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);
+
+ if (code == TCL_OK) {
+ char *ret = (char *) Tcl_GetStringResult(interp);
+ if (strlen(ret) < size - 1) {
+ strncpy(buf, ret, (size_t) size);
+ Tcl_Release((ClientData) interp);
+ return (int)strlen(ret);
+ }
+ }
+ Tcl_Release((ClientData) interp);
+ return -1;
+ verify = verify;
+}
+#endif
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * CiphersObjCmd -- list available ciphers
+ *
+ * This procedure is invoked to process the "tls::ciphers" command
+ * to list available ciphers, based upon protocol selected.
+ *
+ * Results:
+ * A standard Tcl result list.
+ *
+ * Side effects:
+ * constructs and destroys SSL context (CTX)
+ *
+ *-------------------------------------------------------------------
+ */
+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];
+ int index, verbose = 0;
+
+ dprintf("Called");
+
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?");
+ 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;
+ }
+ switch ((enum protocol)index) {
+ case TLS_SSL2:
+#if OPENSSL_VERSION_NUMBER >= 0x10101000L || 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)
+ 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)
+ 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)
+ 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)
+ Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
+ return TCL_ERROR;
+#else
+ ctx = SSL_CTX_new(TLSv1_2_method()); break;
+#endif
+ case TLS_TLS1_3:
+#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
+ Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
+ return TCL_ERROR;
+#else
+ ctx = SSL_CTX_new(TLS_method());
+ SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION);
+ SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION);
+ break;
+#endif
+ default:
+ break;
+ }
+ 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));
+ }
+ } 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';
+ } else {
+ break;
+ }
+ }
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1));
+ }
+ }
+ SSL_free(ssl);
+ SSL_CTX_free(ctx);
+
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * HandshakeObjCmd --
+ *
+ * This command is used to verify whether the handshake is complete
+ * or not.
+ *
+ * Results:
+ * A standard Tcl result. 1 means handshake complete, 0 means pending.
+ *
+ * Side effects:
+ * May force SSL negotiation to take place.
+ *
+ *-------------------------------------------------------------------
+ */
+static int HandshakeObjCmd(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 */
+ const char *errStr = NULL;
+ int ret = 1;
+ int err = 0;
+
+ dprintf("Called");
+
+ 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);
+ }
+ statePtr = (State *)Tcl_GetChannelInstanceData(chan);
+
+ dprintf("Calling Tls_WaitForConnect");
+ ret = Tls_WaitForConnect(statePtr, &err, 1);
+ dprintf("Tls_WaitForConnect returned: %i", ret);
+
+ if (ret < 0 && ((statePtr->flags & TLS_TCL_ASYNC) && (err == EAGAIN))) {
+ dprintf("Async set and err = EAGAIN");
+ ret = 0;
+ } else if (ret < 0) {
+ errStr = statePtr->err;
+ Tcl_ResetResult(interp);
+ Tcl_SetErrno(err);
+
+ if (!errStr || (*errStr == 0)) {
+ errStr = Tcl_PosixError(interp);
+ }
+
+ Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL);
+ dprintf("Returning TCL_ERROR with handshake failed: %s", errStr);
+ return(TCL_ERROR);
+ } else {
+ if (err != 0) {
+ dprintf("Got an error with a completed handshake: err = %i", err);
+ }
+ ret = 1;
+ }
+
+ dprintf("Returning TCL_OK with data \"%i\"", ret);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
+ return(TCL_OK);
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ImportObjCmd --
+ *
+ * This procedure is invoked to process the "ssl" command
+ *
+ * The ssl command pushes SSL over a (newly connected) tcp socket
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May modify the behavior of an IO channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+ImportObjCmd(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 */
+ SSL_CTX *ctx = NULL;
+ Tcl_Obj *script = NULL;
+ Tcl_Obj *password = NULL;
+ Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar;
+ int idx, len;
+ int flags = TLS_TCL_INIT;
+ int server = 0; /* is connection incoming or outgoing? */
+ char *keyfile = NULL;
+ char *certfile = NULL;
+ unsigned char *key = NULL;
+ int key_len = 0;
+ unsigned char *cert = NULL;
+ int cert_len = 0;
+ char *ciphers = 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 */
+ 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 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)
+ 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)
+ ssl3 = 1;
+#endif
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
+ tls1 = 0;
+#endif
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
+ tls1_1 = 0;
+#endif
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
+ tls1_2 = 0;
+#endif
+#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
+ tls1_3 = 0;
+#endif
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?");
+ 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);
+
+ for (idx = 2; idx < objc; idx++) {
+ char *opt = Tcl_GetStringFromObj(objv[idx], NULL);
+
+ if (opt[0] != '-')
+ break;
+
+ OPTSTR("-cadir", CAdir);
+ OPTSTR("-cafile", CAfile);
+ OPTSTR("-certfile", certfile);
+ OPTSTR("-cipher", ciphers);
+ OPTOBJ("-command", script);
+ OPTSTR("-dhparams", DHparams);
+ OPTSTR("-keyfile", keyfile);
+ OPTSTR("-model", model);
+ OPTOBJ("-password", password);
+ OPTBOOL("-require", require);
+ OPTBOOL("-request", request);
+ OPTBOOL("-server", server);
+#ifndef OPENSSL_NO_TLSEXT
+ OPTSTR("-servername", servername);
+ 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");
+
+ return TCL_ERROR;
+ }
+ if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
+ if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
+ if (verify == 0) verify = SSL_VERIFY_NONE;
+
+ proto |= (ssl2 ? TLS_PROTO_SSL2 : 0);
+ proto |= (ssl3 ? TLS_PROTO_SSL3 : 0);
+ proto |= (tls1 ? TLS_PROTO_TLS1 : 0);
+ proto |= (tls1_1 ? TLS_PROTO_TLS1_1 : 0);
+ proto |= (tls1_2 ? TLS_PROTO_TLS1_2 : 0);
+ proto |= (tls1_3 ? TLS_PROTO_TLS1_3 : 0);
+
+ /* reset to NULL if blank string provided */
+ 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 (CAfile && !*CAfile) CAfile = NULL;
+ if (CAdir && !*CAdir) CAdir = NULL;
+ if (DHparams && !*DHparams) DHparams = NULL;
+
+ /* new SSL state */
+ statePtr = (State *) ckalloc((unsigned) sizeof(State));
+ memset(statePtr, 0, sizeof(State));
+
+ statePtr->flags = flags;
+ statePtr->interp = interp;
+ statePtr->vflags = verify;
+ statePtr->err = "";
+
+ /* allocate script */
+ if (script) {
+ (void) Tcl_GetStringFromObj(script, &len);
+ if (len) {
+ statePtr->callback = script;
+ Tcl_IncrRefCount(statePtr->callback);
+ }
+ }
+
+ /* allocate password */
+ if (password) {
+ (void) Tcl_GetStringFromObj(password, &len);
+ if (len) {
+ statePtr->password = password;
+ Tcl_IncrRefCount(statePtr->password);
+ }
+ }
+
+ if (model != NULL) {
+ int mode;
+ /* Get the "model" context */
+ chan = Tcl_GetChannel(interp, model, &mode);
+ if (chan == (Tcl_Channel) NULL) {
+ Tls_Free((char *) statePtr);
+ 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);
+ Tls_Free((char *) statePtr);
+ 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) {
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ }
+
+ statePtr->ctx = ctx;
+
+ /*
+ * We need to make sure that the channel works in binary (for the
+ * encryption not to get goofed up).
+ * We only want to adjust the buffering in pre-v2 channels, where
+ * each channel in the stack maintained its own buffers.
+ */
+ Tcl_DStringInit(&upperChannelTranslation);
+ Tcl_DStringInit(&upperChannelBlocking);
+ Tcl_DStringInit(&upperChannelEOFChar);
+ Tcl_DStringInit(&upperChannelEncoding);
+ Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar);
+ Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding);
+ Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation);
+ Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking);
+ Tcl_SetChannelOption(interp, chan, "-translation", "binary");
+ Tcl_SetChannelOption(interp, chan, "-blocking", "true");
+ dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan));
+ statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan);
+ dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self));
+ if (statePtr->self == (Tcl_Channel) NULL) {
+ /*
+ * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
+ */
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetChannelOption(interp, statePtr->self, "-translation", Tcl_DStringValue(&upperChannelTranslation));
+ Tcl_SetChannelOption(interp, statePtr->self, "-encoding", Tcl_DStringValue(&upperChannelEncoding));
+ Tcl_SetChannelOption(interp, statePtr->self, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar));
+ Tcl_SetChannelOption(interp, statePtr->self, "-blocking", Tcl_DStringValue(&upperChannelBlocking));
+
+ /*
+ * SSL Initialization
+ */
+ statePtr->ssl = SSL_new(statePtr->ctx);
+ if (!statePtr->ssl) {
+ /* SSL library error */
+ Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+
+#ifndef OPENSSL_NO_TLSEXT
+ if (servername) {
+ 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;
+ }
+ }
+ if (alpn) {
+ /* Convert a Tcl list into a protocol-list in wire-format */
+ unsigned char *protos, *p;
+ unsigned int protoslen = 0;
+ int i, len, cnt;
+ Tcl_Obj **list;
+ if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ /* Determine the memory required for the protocol-list */
+ for (i = 0; i < cnt; i++) {
+ Tcl_GetStringFromObj(list[i], &len);
+ if (len > 255) {
+ Tcl_AppendResult(interp, "alpn protocol name too long", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ protoslen += 1 + len;
+ }
+ /* Build the complete protocol-list */
+ protos = ckalloc(protoslen);
+ /* 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)) {
+ 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);
+ }
+#endif
+
+ /*
+ * SSL Callbacks
+ */
+ SSL_set_app_data(statePtr->ssl, (void *)statePtr); /* point back to us */
+ SSL_set_verify(statePtr->ssl, verify, VerifyCallback);
+ SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);
+
+ /* Create Tcl_Channel BIO Handler */
+ statePtr->p_bio = BIO_new_tcl(statePtr, BIO_NOCLOSE);
+ statePtr->bio = BIO_new(BIO_f_ssl());
+
+ if (server) {
+ statePtr->flags |= TLS_TCL_SERVER;
+ SSL_set_accept_state(statePtr->ssl);
+ } else {
+ 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);
+
+ /*
+ * End of SSL Init
+ */
+ dprintf("Returning %s", Tcl_GetChannelName(statePtr->self));
+ Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), TCL_VOLATILE);
+
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * UnimportObjCmd --
+ *
+ * This procedure is invoked to remove the topmost channel filter.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May modify the behavior of an IO channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+UnimportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Channel chan; /* The channel to set a mode on. */
+
+ dprintf("Called");
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel");
+ return TCL_ERROR;
+ }
+
+ 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
+ */
+ 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;
+ }
+
+ if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * CTX_Init -- construct a SSL_CTX instance
+ *
+ * Results:
+ * A valid SSL_CTX instance or NULL.
+ *
+ * Side effects:
+ * constructs SSL context (CTX)
+ *
+ *-------------------------------------------------------------------
+ */
+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) {
+ Tcl_Interp *interp = statePtr->interp;
+ SSL_CTX *ctx = NULL;
+ Tcl_DString ds;
+ Tcl_DString ds1;
+ int off = 0;
+ int load_private_key;
+ const SSL_METHOD *method;
+
+ dprintf("Called");
+
+ if (!proto) {
+ 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 (ENABLED(proto, TLS_PROTO_SSL2)) {
+ Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
+ if (ENABLED(proto, TLS_PROTO_SSL3)) {
+ Tcl_AppendResult(interp, "SSL3 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
+ if (ENABLED(proto, TLS_PROTO_TLS1)) {
+ Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
+ if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
+ Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
+ if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
+ Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
+ if (ENABLED(proto, TLS_PROTO_TLS1_3)) {
+ Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+
+ switch (proto) {
+#if OPENSSL_VERSION_NUMBER < 0x10101000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ case TLS_PROTO_SSL2:
+ method = SSLv2_method();
+ break;
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ case TLS_PROTO_SSL3:
+ method = SSLv3_method();
+ break;
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+ case TLS_PROTO_TLS1:
+ method = TLSv1_method();
+ break;
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+ case TLS_PROTO_TLS1_1:
+ method = TLSv1_1_method();
+ break;
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+ case TLS_PROTO_TLS1_2:
+ method = TLSv1_2_method();
+ break;
+#endif
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
+ case TLS_PROTO_TLS1_3:
+ /*
+ * The version range is constrained below,
+ * after the context is created. Use the
+ * generic method here.
+ */
+ method = TLS_method();
+ break;
+#endif
+ default:
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L
+ /* Negotiate highest available SSL/TLS version */
+ method = TLS_method();
+#else
+ method = SSLv23_method();
+#endif
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2);
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3);
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1);
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1);
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2);
+#endif
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3);
+#endif
+ break;
+ }
+
+ ctx = SSL_CTX_new(method);
+
+ if (!ctx) {
+ return(NULL);
+ }
+
+ if (getenv(SSLKEYLOGFILE)) {
+ SSL_CTX_set_keylog_callback(ctx, KeyLogCallback);
+ }
+
+#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
+
+ 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 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);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+#else
+ {
+ DH* dh;
+ if (DHparams != NULL) {
+ BIO *bio;
+ Tcl_DStringInit(&ds);
+ bio = BIO_new_file(F2N(DHparams, &ds), "r");
+ if (!bio) {
+ Tcl_DStringFree(&ds);
+ Tcl_AppendResult(interp, "Could not find DH parameters file", (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+
+ dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL);
+ BIO_free(bio);
+ Tcl_DStringFree(&ds);
+ if (!dh) {
+ Tcl_AppendResult(interp, "Could not read DH parameters from file", (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+ } else {
+ dh = get_dhParams();
+ }
+ SSL_CTX_set_tmp_dh(ctx, dh);
+ DH_free(dh);
+ }
+#endif
+
+ /* set our certificate */
+ load_private_key = 0;
+ if (certfile != NULL) {
+ load_private_key = 1;
+
+ Tcl_DStringInit(&ds);
+
+ if (SSL_CTX_use_certificate_file(ctx, F2N(certfile, &ds), SSL_FILETYPE_PEM) <= 0) {
+ Tcl_DStringFree(&ds);
+ Tcl_AppendResult(interp, "unable to set certificate file ", certfile, ": ",
+ REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+ } else if (cert != NULL) {
+ load_private_key = 1;
+ if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) {
+ Tcl_DStringFree(&ds);
+ Tcl_AppendResult(interp, "unable to set certificate: ",
+ REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+ } else {
+ certfile = (char*)X509_get_default_cert_file();
+
+ if (SSL_CTX_use_certificate_file(ctx, certfile, SSL_FILETYPE_PEM) <= 0) {
+#if 0
+ Tcl_DStringFree(&ds);
+ Tcl_AppendResult(interp, "unable to use default certificate file ", certfile, ": ",
+ REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+#endif
+ }
+ }
+
+ /* set our private key */
+ if (load_private_key) {
+ if (keyfile == NULL && key == NULL) {
+ keyfile = certfile;
+ }
+
+ if (keyfile != NULL) {
+ /* get the private key associated with this certificate */
+ if (keyfile == NULL) {
+ keyfile = certfile;
+ }
+
+ if (SSL_CTX_use_PrivateKey_file(ctx, F2N(keyfile, &ds), SSL_FILETYPE_PEM) <= 0) {
+ Tcl_DStringFree(&ds);
+ /* flush the passphrase which might be left in the result */
+ Tcl_SetResult(interp, NULL, TCL_STATIC);
+ Tcl_AppendResult(interp, "unable to set public key file ", keyfile, " ",
+ REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+ Tcl_DStringFree(&ds);
+
+ } else if (key != NULL) {
+ if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 0) {
+ Tcl_DStringFree(&ds);
+ /* flush the passphrase which might be left in the result */
+ Tcl_SetResult(interp, NULL, TCL_STATIC);
+ Tcl_AppendResult(interp, "unable to set public key: ", REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+ }
+ /* Now we know that a key and cert have been set against
+ * the SSL context */
+ if (!SSL_CTX_check_private_key(ctx)) {
+ Tcl_AppendResult(interp, "private key does not match the certificate public key",
+ (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+ }
+ }
+
+ /* Set verification CAs */
+ Tcl_DStringInit(&ds);
+ Tcl_DStringInit(&ds1);
+ if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) ||
+ !SSL_CTX_set_default_verify_paths(ctx)) {
+#if 0
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&ds1);
+ /* Don't currently care if this fails */
+ Tcl_AppendResult(interp, "SSL default verify paths: ", REASON(), (char *) NULL);
+ SSL_CTX_free(ctx);
+ return (SSL_CTX *)0;
+#endif
+ }
+
+ /* https://sourceforge.net/p/tls/bugs/57/ */
+ /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */
+ if (CAfile != NULL) {
+ STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file(F2N(CAfile, &ds));
+ if (certNames != NULL) {
+ SSL_CTX_set_client_CA_list(ctx, certNames);
+ }
+ }
+
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&ds1);
+ return ctx;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * StatusObjCmd -- return certificate for connected peer.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+StatusObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ State *statePtr;
+ 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
+
+ dprintf("Called");
+
+ switch (objc) {
+ case 2:
+ channelName = Tcl_GetStringFromObj(objv[1], NULL);
+ break;
+
+ case 3:
+ if (!strcmp (Tcl_GetString (objv[1]), "-local")) {
+ channelName = Tcl_GetStringFromObj(objv[2], NULL);
+ break;
+ }
+ /* else fall-through ... */
+#if defined(__GNUC__)
+ __attribute__((fallthrough));
+#endif
+ default:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel");
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_GetChannel(interp, channelName, &mode);
+ 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;
+ }
+ statePtr = (State *) Tcl_GetChannelInstanceData(chan);
+ if (objc == 2) {
+ peer = SSL_get_peer_certificate(statePtr->ssl);
+ } else {
+ peer = SSL_get_certificate(statePtr->ssl);
+ }
+ if (peer) {
+ objPtr = Tls_NewX509Obj(interp, peer);
+ if (objc == 2) { X509_free(peer); }
+ } else {
+ objPtr = Tcl_NewListObj(0, NULL);
+ }
+
+ 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
+ /* 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;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * VersionObjCmd -- return version string from OpenSSL.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+VersionObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ Tcl_Obj *objPtr;
+
+ dprintf("Called");
+
+ objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1);
+ Tcl_SetObjResult(interp, objPtr);
+
+ return TCL_OK;
+ clientData = clientData;
+ objc = objc;
+ objv = objv;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * MiscObjCmd -- misc commands
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+MiscObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ static const char *commands [] = { "req", "strreq", NULL };
+ enum command { C_REQ, C_STRREQ, C_DUMMY };
+ int cmd, isStr;
+ char buffer[16384];
+
+ dprintf("Called");
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,&cmd) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ isStr = (cmd == C_STRREQ);
+ switch ((enum command) cmd) {
+ case C_REQ:
+ case C_STRREQ: {
+ EVP_PKEY *pkey=NULL;
+ X509 *cert=NULL;
+ X509_NAME *name=NULL;
+ Tcl_Obj **listv;
+ int listc,i;
+
+ BIO *out=NULL;
+
+ 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
+ BIGNUM *bne = NULL;
+ RSA *rsa = NULL;
+#else
+ EVP_PKEY_CTX *ctx = NULL;
+#endif
+
+ if ((objc<5) || (objc>6)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ keyout=Tcl_GetString(objv[3]);
+ pemout=Tcl_GetString(objv[4]);
+ if (isStr) {
+ Tcl_SetVar(interp,keyout,"",0);
+ Tcl_SetVar(interp,pemout,"",0);
+ }
+
+ if (objc>=6) {
+ if (Tcl_ListObjGetElements(interp, objv[5],
+ &listc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if ((listc%2) != 0) {
+ Tcl_SetResult(interp,"Information list must have even number of arguments",NULL);
+ return TCL_ERROR;
+ }
+ for (i=0; i 0x10100000L && 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);
+ X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, (const unsigned char *) k_ST, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, (const unsigned char *) k_L, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, (const unsigned char *) k_O, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, (const unsigned char *) k_OU, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, (const unsigned char *) k_CN, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, (const unsigned char *) k_Email, -1, -1, 0);
+
+ 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
+ BN_free(bne);
+#endif
+ Tcl_SetResult(interp,"Error signing certificate",NULL);
+ return TCL_ERROR;
+ }
+
+ if (isStr) {
+ out=BIO_new(BIO_s_mem());
+ PEM_write_bio_X509(out,cert);
+ i=BIO_read(out,buffer,sizeof(buffer)-1);
+ i=(i<0) ? 0 : i;
+ buffer[i]='\0';
+ Tcl_SetVar(interp,pemout,buffer,0);
+ BIO_flush(out);
+ BIO_free(out);
+ } else {
+ out=BIO_new(BIO_s_file());
+ BIO_write_filename(out,pemout);
+ PEM_write_bio_X509(out,cert);
+ BIO_free_all(out);
+ }
+
+ X509_free(cert);
+ EVP_PKEY_free(pkey);
+#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Free --
+ *
+ * This procedure cleans up when a SSL socket based channel
+ * is closed and its reference count falls below 1
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * Frees all the state
+ *
+ *-------------------------------------------------------------------
+ */
+void
+Tls_Free(char *blockPtr) {
+ State *statePtr = (State *)blockPtr;
+
+ dprintf("Called");
+
+ Tls_Clean(statePtr);
+ ckfree(blockPtr);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Clean --
+ *
+ * This procedure cleans up when a SSL socket based channel
+ * is closed and its reference count falls below 1. This should
+ * be called synchronously by the CloseProc, not in the
+ * EventuallyFree callback.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * Frees all the state
+ *
+ *-------------------------------------------------------------------
+ */
+void Tls_Clean(State *statePtr) {
+ dprintf("Called");
+
+ /*
+ * we're assuming here that we're single-threaded
+ */
+ if (statePtr->timer != (Tcl_TimerToken) NULL) {
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ statePtr->timer = 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;
+ }
+ if (statePtr->ssl) {
+ dprintf("SSL_free(%p)", statePtr->ssl);
+ SSL_free(statePtr->ssl);
+ statePtr->ssl = NULL;
+ }
+ if (statePtr->ctx) {
+ SSL_CTX_free(statePtr->ctx);
+ statePtr->ctx = NULL;
+ }
+ if (statePtr->callback) {
+ Tcl_DecrRefCount(statePtr->callback);
+ statePtr->callback = NULL;
+ }
+ if (statePtr->password) {
+ Tcl_DecrRefCount(statePtr->password);
+ statePtr->password = NULL;
+ }
+
+ dprintf("Returning");
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Init --
+ *
+ * This is a package initialization procedure, which is called
+ * by Tcl when this package is to be added to an interpreter.
+ *
+ * Results: Ssl configured and loaded
+ *
+ * Side effects:
+ * create the ssl command, initialize ssl context
+ *
+ *-------------------------------------------------------------------
+ */
+DLLEXPORT int Tls_Init(Tcl_Interp *interp) {
+ const char tlsTclInitScript[] = {
+#include "tls.tcl.h"
+ 0x00
+ };
+
+ dprintf("Called");
+
+ /*
+ * We only support Tcl 8.4 or newer
+ */
+ if (
+#ifdef USE_TCL_STUBS
+ Tcl_InitStubs(interp, "8.4", 0)
+#else
+ Tcl_PkgRequire(interp, "Tcl", "8.4-", 0)
+#endif
+ == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (TlsLibInit(0) != TCL_OK) {
+ 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::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);
+
+ if (interp) {
+ Tcl_Eval(interp, tlsTclInitScript);
+ }
+
+ return(Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION));
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ * Tls_SafeInit --
+ *
+ * ------------------------------------------------*
+ * Standard procedure required by 'load'.
+ * Initializes this extension for a safe interpreter.
+ * ------------------------------------------------*
+ *
+ * Side effects:
+ * As of 'Tls_Init'
+ *
+ * Result:
+ * A standard Tcl error code.
+ *
+ *------------------------------------------------------*
+ */
+DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp) {
+ dprintf("Called");
+ return(Tls_Init(interp));
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ * TlsLibInit --
+ *
+ * ------------------------------------------------*
+ * Initializes SSL library once per application
+ * ------------------------------------------------*
+ *
+ * Side effects:
+ * initializes SSL library
+ *
+ * Result:
+ * none
+ *
+ *------------------------------------------------------*
+ */
+static int TlsLibInit(int uninitialize) {
+ static int initialized = 0;
+ int status = TCL_OK;
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ size_t num_locks;
+#endif
+
+ if (uninitialize) {
+ if (!initialized) {
+ dprintf("Asked to uninitialize, but we are not initialized");
+
+ return(TCL_OK);
+ }
+
+ 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;
+ }
+#endif
+ initialized = 0;
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ Tcl_MutexUnlock(&init_mx);
+#endif
+
+ return(TCL_OK);
+ }
+
+ if (initialized) {
+ dprintf("Called, but using cached value");
+ return(status);
+ }
+
+ dprintf("Called");
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+ 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
+ /* 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
+ OPENSSL_init_crypto(OPENSSL_INIT_LOAD_CRYPTO_STRINGS, NULL);
+#endif
+
+ BIO_new_tcl(NULL, 0);
+
+#if 0
+ /*
+ * XXX:TODO: Remove this code and replace it with a check
+ * for enough entropy and do not try to create our own
+ * terrible entropy
+ */
+ /*
+ * Seed the random number generator in the SSL library,
+ * using the do/while construct because of the bug note in the
+ * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1
+ *
+ * The crux of the problem is that Solaris 7 does not have a
+ * /dev/random or /dev/urandom device so it cannot gather enough
+ * entropy from the RAND_seed() when TLS initializes and refuses
+ * to go further. Earlier versions of OpenSSL carried on regardless.
+ */
+ srand((unsigned int) time((time_t *) NULL));
+ do {
+ for (i = 0; i < 16; i++) {
+ rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0));
+ }
+ 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);
+}
ADDED generic/tls.h
Index: generic/tls.h
==================================================================
--- /dev/null
+++ generic/tls.h
@@ -0,0 +1,30 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman
+ *
+ * TLS (aka SSL) Channel - can be layered on any bi-directional
+ * Tcl_Channel (Note: Requires Trf Core Patch)
+ *
+ * This was built from scratch based upon observation of OpenSSL 0.9.2B
+ *
+ * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
+ * providing the Tcl_ReplaceChannel mechanism and working closely with me
+ * to enhance it to support full fileevent semantics.
+ *
+ * Also work done by the follow people provided the impetus to do this "right":-
+ * tclSSL (Colin McCormack, Shared Technology)
+ * SSLtcl (Peter Antman)
+ *
+ */
+
+#ifndef _TLS_H
+#define _TLS_H
+
+#include
+
+/*
+ * Initialization routines -- our entire public C API.
+ */
+DLLEXPORT int Tls_Init(Tcl_Interp *interp);
+DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp);
+
+#endif /* _TLS_H */
ADDED generic/tlsBIO.c
Index: generic/tlsBIO.c
==================================================================
--- /dev/null
+++ generic/tlsBIO.c
@@ -0,0 +1,341 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman
+ *
+ * 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;
+
+ chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
+
+ dprintf("[chan=%p] BioWrite(%p, , %d)", (void *)chan, (void *) bio, bufLen);
+
+ ret = Tcl_WriteRaw(chan, buf, bufLen);
+
+ tclEofChan = Tcl_Eof(chan);
+ tclErrno = Tcl_GetErrno();
+
+ dprintf("[chan=%p] BioWrite(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno());
+
+ BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY);
+
+ if (tclEofChan && ret <= 0) {
+ dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
+ Tcl_SetErrno(ECONNRESET);
+ ret = 0;
+
+ } else if (ret == 0) {
+ dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0");
+ dprintf("Setting retry read flag");
+ BIO_set_retry_read(bio);
+
+ } else if (ret < 0) {
+ 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);
+ }
+
+ } else {
+ dprintf("Successfully wrote some data");
+ }
+
+ if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
+ if (BIO_should_read(bio)) {
+ dprintf("Setting should retry read flag");
+
+ BIO_set_retry_read(bio);
+ }
+ }
+ return(ret);
+}
+
+static int BioRead(BIO *bio, char *buf, int bufLen) {
+ Tcl_Channel chan;
+ int ret = 0;
+ int tclEofChan, tclErrno;
+
+ chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
+
+ dprintf("[chan=%p] BioRead(%p, , %d)", (void *) chan, (void *) bio, bufLen);
+
+ if (buf == NULL) {
+ return 0;
+ }
+
+ ret = Tcl_ReadRaw(chan, buf, bufLen);
+
+ tclEofChan = Tcl_Eof(chan);
+ tclErrno = Tcl_GetErrno();
+
+ dprintf("[chan=%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, tclErrno);
+
+ BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY);
+
+ if (tclEofChan && ret <= 0) {
+ dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
+ Tcl_SetErrno(ECONNRESET);
+ ret = 0;
+
+ } else if (ret == 0) {
+ dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0");
+ dprintf("Setting retry read flag");
+ BIO_set_retry_read(bio);
+
+ } else if (ret < 0) {
+ 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);
+ }
+
+ } else {
+ dprintf("Successfully read some data");
+ }
+
+ if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
+ if (BIO_should_write(bio)) {
+ dprintf("Setting should retry write flag");
+
+ BIO_set_retry_write(bio);
+ }
+ }
+
+ dprintf("BioRead(%p, , %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret);
+
+ return(ret);
+}
+
+static int BioPuts(BIO *bio, const char *str) {
+ dprintf("BioPuts(%p, ) called", bio, str);
+
+ return BioWrite(bio, str, (int) strlen(str));
+}
+
+static long BioCtrl(BIO *bio, int cmd, long num, void *ptr) {
+ Tcl_Channel chan;
+ long ret = 1;
+
+ chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
+
+ dprintf("BioCtrl(%p, 0x%x, 0x%lx, %p)", (void *) bio, cmd, num, ptr);
+
+ switch (cmd) {
+ case BIO_CTRL_RESET:
+ dprintf("Got BIO_CTRL_RESET");
+ num = 0;
+ ret = 0;
+ break;
+ case BIO_C_FILE_SEEK:
+ dprintf("Got BIO_C_FILE_SEEK");
+ ret = 0;
+ break;
+ case BIO_C_FILE_TELL:
+ dprintf("Got BIO_C_FILE_TELL");
+ ret = 0;
+ break;
+ case BIO_CTRL_INFO:
+ dprintf("Got BIO_CTRL_INFO");
+ ret = 1;
+ break;
+ case BIO_C_SET_FD:
+ dprintf("Unsupported call: BIO_C_SET_FD");
+ ret = -1;
+ break;
+ case BIO_C_GET_FD:
+ dprintf("Unsupported call: BIO_C_GET_FD");
+ ret = -1;
+ break;
+ case BIO_CTRL_GET_CLOSE:
+ dprintf("Got BIO_CTRL_CLOSE");
+ ret = BIO_get_shutdown(bio);
+ break;
+ case BIO_CTRL_SET_CLOSE:
+ dprintf("Got BIO_SET_CLOSE");
+ BIO_set_shutdown(bio, num);
+ break;
+ case BIO_CTRL_EOF:
+ dprintf("Got BIO_CTRL_EOF");
+ ret = ((chan) ? Tcl_Eof(chan) : 1);
+ break;
+ case BIO_CTRL_PENDING:
+ dprintf("Got BIO_CTRL_PENDING");
+ ret = ((chan) ? ((Tcl_InputBuffered(chan) ? 1 : 0)) : 0);
+ dprintf("BIO_CTRL_PENDING(%d)", (int) ret);
+ break;
+ case BIO_CTRL_WPENDING:
+ dprintf("Got BIO_CTRL_WPENDING");
+ ret = 0;
+ break;
+ case BIO_CTRL_DUP:
+ dprintf("Got BIO_CTRL_DUP");
+ break;
+ case BIO_CTRL_FLUSH:
+ dprintf("Got BIO_CTRL_FLUSH");
+ ret = ((chan) && (Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
+ dprintf("BIO_CTRL_FLUSH returning value %li", ret);
+ break;
+ case BIO_CTRL_PUSH:
+ dprintf("Got BIO_CTRL_PUSH");
+ ret = 0;
+ break;
+ case BIO_CTRL_POP:
+ dprintf("Got BIO_CTRL_POP");
+ ret = 0;
+ break;
+ case BIO_CTRL_SET:
+ dprintf("Got BIO_CTRL_SET");
+ ret = 0;
+ break;
+ case BIO_CTRL_GET :
+ dprintf("Got BIO_CTRL_GET ");
+ ret = 0;
+ break;
+#ifdef BIO_CTRL_GET_KTLS_SEND
+ case BIO_CTRL_GET_KTLS_SEND:
+ dprintf("Got BIO_CTRL_GET_KTLS_SEND");
+ ret = 0;
+ break;
+#endif
+#ifdef BIO_CTRL_GET_KTLS_RECV
+ case BIO_CTRL_GET_KTLS_RECV:
+ dprintf("Got BIO_CTRL_GET_KTLS_RECV");
+ ret = 0;
+ break;
+#endif
+ default:
+ dprintf("Got unknown control command (%i)", cmd);
+ ret = 0;
+ break;
+ }
+ return(ret);
+}
+
+static int BioNew(BIO *bio) {
+ dprintf("BioNew(%p) called", bio);
+
+ BIO_set_init(bio, 0);
+ BIO_set_data(bio, NULL);
+ BIO_clear_flags(bio, -1);
+ return(1);
+}
+
+static int BioFree(BIO *bio) {
+ if (bio == NULL) {
+ return(0);
+ }
+
+ dprintf("BioFree(%p) called", bio);
+
+ if (BIO_get_shutdown(bio)) {
+ if (BIO_get_init(bio)) {
+ /*shutdown(bio->num, 2) */
+ /*closesocket(bio->num) */
+ }
+
+ BIO_set_init(bio, 0);
+ BIO_clear_flags(bio, -1);
+ }
+ return(1);
+}
+
+BIO *BIO_new_tcl(State *statePtr, int flags) {
+ BIO *bio;
+ static BIO_METHOD *BioMethods = NULL;
+#ifdef TCLTLS_SSL_USE_FASTPATH
+ Tcl_Channel parentChannel;
+ const Tcl_ChannelType *parentChannelType;
+ void *parentChannelFdIn_p, *parentChannelFdOut_p;
+ int parentChannelFdIn, parentChannelFdOut, parentChannelFd;
+ int validParentChannelFd;
+ int tclGetChannelHandleRet;
+#endif
+
+ dprintf("BIO_new_tcl() called");
+
+ if (BioMethods == NULL) {
+ BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl");
+ BIO_meth_set_write(BioMethods, BioWrite);
+ BIO_meth_set_read(BioMethods, BioRead);
+ BIO_meth_set_puts(BioMethods, BioPuts);
+ BIO_meth_set_ctrl(BioMethods, BioCtrl);
+ BIO_meth_set_create(BioMethods, BioNew);
+ BIO_meth_set_destroy(BioMethods, BioFree);
+ }
+
+ if (statePtr == NULL) {
+ dprintf("Asked to setup a NULL state, just creating the initial configuration");
+
+ return(NULL);
+ }
+
+#ifdef TCLTLS_SSL_USE_FASTPATH
+ /*
+ * If the channel can be mapped back to a file descriptor, just use the file descriptor
+ * with the SSL library since it will likely be optimized for this.
+ */
+ parentChannel = Tls_GetParent(statePtr, 0);
+ parentChannelType = Tcl_GetChannelType(parentChannel);
+
+ validParentChannelFd = 0;
+ if (strcmp(parentChannelType->typeName, "tcp") == 0) {
+ tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, (ClientData) &parentChannelFdIn_p);
+ if (tclGetChannelHandleRet == TCL_OK) {
+ tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, (ClientData) &parentChannelFdOut_p);
+ if (tclGetChannelHandleRet == TCL_OK) {
+ parentChannelFdIn = PTR2INT(parentChannelFdIn_p);
+ parentChannelFdOut = PTR2INT(parentChannelFdOut_p);
+ if (parentChannelFdIn == parentChannelFdOut) {
+ parentChannelFd = parentChannelFdIn;
+ validParentChannelFd = 1;
+ }
+ }
+ }
+ }
+
+ if (validParentChannelFd) {
+ dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn);
+ bio = BIO_new_socket(parentChannelFd, flags);
+ statePtr->flags |= TLS_TCL_FASTPATH;
+ return(bio);
+ }
+
+ dprintf("Falling back to Tcl I/O for this channel");
+#endif
+
+ bio = BIO_new(BioMethods);
+ BIO_set_data(bio, statePtr);
+ BIO_set_shutdown(bio, flags);
+ BIO_set_init(bio, 1);
+ return(bio);
+}
ADDED generic/tlsIO.c
Index: generic/tlsIO.c
==================================================================
--- /dev/null
+++ generic/tlsIO.c
@@ -0,0 +1,990 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman
+ * Copyright (C) 2000 Ajuba Solutions
+ *
+ * TLS (aka SSL) Channel - can be layered on any bi-directional
+ * Tcl_Channel (Note: Requires Trf Core Patch)
+ *
+ * This was built from scratch based upon observation of OpenSSL 0.9.2B
+ *
+ * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
+ * providing the Tcl_ReplaceChannel mechanism and working closely with me
+ * to enhance it to support full fileevent semantics.
+ *
+ * Also work done by the follow people provided the impetus to do this "right":
+ * tclSSL (Colin McCormack, Shared Technology)
+ * SSLtcl (Peter Antman)
+ *
+ */
+
+#include "tlsInt.h"
+
+/*
+ * Forward declarations
+ */
+static void TlsChannelHandlerTimer(ClientData clientData);
+
+/*
+ * TLS Channel Type
+ */
+static Tcl_ChannelType *tlsChannelType = NULL;
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsBlockModeProc --
+ *
+ * This procedure is invoked by the generic IO level
+ * to set blocking and nonblocking modes
+ * Results:
+ * 0 if successful, errno when failed.
+ *
+ * Side effects:
+ * Sets the device into blocking or nonblocking mode.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsBlockModeProc(ClientData instanceData, int mode) {
+ State *statePtr = (State *) instanceData;
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ statePtr->flags |= TLS_TCL_ASYNC;
+ } else {
+ statePtr->flags &= ~(TLS_TCL_ASYNC);
+ }
+ return(0);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsCloseProc --
+ *
+ * This procedure is invoked by the generic IO level to perform
+ * channel-type-specific cleanup when a SSL socket based channel
+ * is closed.
+ *
+ * Note: we leave the underlying socket alone, is this right?
+ *
+ * Results:
+ * 0 if successful, the value of Tcl_GetErrno() if failed.
+ *
+ * Side effects:
+ * Closes the socket of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsCloseProc(ClientData instanceData, Tcl_Interp *interp) {
+ State *statePtr = (State *) instanceData;
+
+ dprintf("TlsCloseProc(%p)", (void *) statePtr);
+
+ Tls_Clean(statePtr);
+ Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
+ return(0);
+
+ /* Interp is unused. */
+ interp = interp;
+}
+
+static int TlsCloseProc2(ClientData instanceData, Tcl_Interp *interp, int flags) {
+ if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
+ return TlsCloseProc(instanceData, interp);
+ }
+ return EINVAL;
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ * Tls_WaitForConnect --
+ *
+ * Sideeffects:
+ * Issues SSL_accept or SSL_connect
+ *
+ * Result:
+ * None.
+ *
+ *------------------------------------------------------*
+ */
+int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) {
+ unsigned long backingError;
+ int err, rc;
+ int bioShouldRetry;
+
+ dprintf("WaitForConnect(%p)", (void *) statePtr);
+ dprintFlags(statePtr);
+
+ if (!(statePtr->flags & TLS_TCL_INIT)) {
+ dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success");
+ *errorCodePtr = 0;
+ return(0);
+ }
+
+ if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
+ /*
+ * Different types of operations have different requirements
+ * SSL being established
+ */
+ if (handshakeFailureIsPermanent) {
+ dprintf("Asked to wait for a TLS handshake that has already failed. Returning fatal error");
+ *errorCodePtr = ECONNABORTED;
+ } else {
+ dprintf("Asked to wait for a TLS handshake that has already failed. Returning soft error");
+ *errorCodePtr = ECONNRESET;
+ }
+ return(-1);
+ }
+
+ for (;;) {
+ /* Not initialized yet! */
+ if (statePtr->flags & TLS_TCL_SERVER) {
+ dprintf("Calling SSL_accept()");
+ err = SSL_accept(statePtr->ssl);
+
+ } else {
+ dprintf("Calling SSL_connect()");
+ err = SSL_connect(statePtr->ssl);
+ }
+
+ if (err > 0) {
+ dprintf("That seems to have gone okay");
+
+ err = BIO_flush(statePtr->bio);
+ if (err <= 0) {
+ dprintf("Flushing the lower layers failed, this will probably terminate this session");
+ }
+ }
+
+ rc = SSL_get_error(statePtr->ssl, err);
+
+ dprintf("Got error: %i (rc = %i)", err, rc);
+
+ 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;
+ } else if (BIO_should_retry(statePtr->bio)) {
+ bioShouldRetry = 1;
+ } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) {
+ bioShouldRetry = 1;
+ }
+ } else {
+ if (!SSL_is_init_finished(statePtr->ssl)) {
+ bioShouldRetry = 1;
+ }
+ }
+
+ if (bioShouldRetry) {
+ dprintf("The I/O did not complete -- but we should try it again");
+
+ if (statePtr->flags & TLS_TCL_ASYNC) {
+ dprintf("Returning EAGAIN so that it can be retried later");
+
+ *errorCodePtr = EAGAIN;
+ return(-1);
+ } else {
+ dprintf("Doing so now");
+
+ continue;
+ }
+ }
+
+ dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though");
+ break;
+ }
+
+ *errorCodePtr = EINVAL;
+
+ switch (rc) {
+ case SSL_ERROR_NONE:
+ /* The connection is up, we are done here */
+ dprintf("The connection is up");
+ break;
+ case SSL_ERROR_ZERO_RETURN:
+ dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...")
+ return(-1);
+ case SSL_ERROR_SYSCALL:
+ backingError = ERR_get_error();
+
+ if (backingError == 0 && err == 0) {
+ dprintf("EOF reached")
+ *errorCodePtr = ECONNRESET;
+ } else if (backingError == 0 && err == -1) {
+ dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ if (*errorCodePtr == ECONNRESET) {
+ *errorCodePtr = ECONNABORTED;
+ }
+ } else {
+ dprintf("I/O error occurred (backingError = %lu)", backingError);
+ *errorCodePtr = backingError;
+ if (*errorCodePtr == ECONNRESET) {
+ *errorCodePtr = ECONNABORTED;
+ }
+ }
+
+ statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+ return(-1);
+
+ case SSL_ERROR_SSL:
+ dprintf("Got permanent fatal SSL error, aborting immediately");
+ Tls_Error(statePtr, (char *)ERR_reason_error_string(ERR_get_error()));
+ statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+ *errorCodePtr = ECONNABORTED;
+ return(-1);
+
+ case SSL_ERROR_WANT_CONNECT:
+ case SSL_ERROR_WANT_ACCEPT:
+ case SSL_ERROR_WANT_X509_LOOKUP:
+ default:
+ dprintf("We got a confusing reply: %i", rc);
+ *errorCodePtr = Tcl_GetErrno();
+ dprintf("ERR(%d, %d) ", rc, *errorCodePtr);
+ return(-1);
+ }
+
+#if 0
+ if (statePtr->flags & TLS_TCL_SERVER) {
+ dprintf("This is an TLS server, checking the certificate for the peer");
+
+ err = SSL_get_verify_result(statePtr->ssl);
+ if (err != X509_V_OK) {
+ dprintf("Invalid certificate, returning in failure");
+
+ Tls_Error(statePtr, (char *)X509_verify_cert_error_string(err));
+ statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+ *errorCodePtr = ECONNABORTED;
+ return(-1);
+ }
+ }
+#endif
+
+ dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake");
+ statePtr->flags &= ~TLS_TCL_INIT;
+
+ dprintf("Returning in success");
+ *errorCodePtr = 0;
+ return(0);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsInputProc --
+ *
+ * This procedure is invoked by the generic IO level
+ * to read input from a SSL socket based channel.
+ *
+ * Results:
+ * The number of bytes read is returned or -1 on error. An output
+ * argument contains the POSIX error code on error, or zero if no
+ * error occurred.
+ *
+ * Side effects:
+ * Reads input from the input device of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsInputProc(ClientData instanceData, char *buf, int bufSize, int *errorCodePtr) {
+ unsigned long backingError;
+ State *statePtr = (State *) instanceData;
+ int bytesRead;
+ int tlsConnect;
+ int err;
+
+ *errorCodePtr = 0;
+
+ dprintf("BIO_read(%d)", bufSize);
+
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ /* don't process any bytes while verify callback is running */
+ dprintf("Callback is running, reading 0 bytes");
+ return(0);
+ }
+
+ dprintf("Calling Tls_WaitForConnect");
+ tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 0);
+ if (tlsConnect < 0) {
+ dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
+
+ bytesRead = -1;
+ if (*errorCodePtr == ECONNRESET) {
+ dprintf("Got connection reset");
+ /* Soft EOF */
+ *errorCodePtr = 0;
+ bytesRead = 0;
+ }
+ return(bytesRead);
+ }
+
+ /*
+ * We need to clear the SSL error stack now because we sometimes reach
+ * this function with leftover errors in the stack. If BIO_read
+ * returns -1 and intends EAGAIN, there is a leftover error, it will be
+ * misconstrued as an error, not EAGAIN.
+ *
+ * Alternatively, we may want to handle the <0 return codes from
+ * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO
+ * functions play with the retry flags though, and this seems to work
+ * correctly. Similar fix in TlsOutputProc. - hobbs
+ */
+ ERR_clear_error();
+ bytesRead = BIO_read(statePtr->bio, buf, bufSize);
+ dprintf("BIO_read -> %d", bytesRead);
+
+ err = SSL_get_error(statePtr->ssl, bytesRead);
+
+#if 0
+ if (bytesRead <= 0) {
+ if (BIO_should_retry(statePtr->bio)) {
+ dprintf("I/O failed, will retry based on EAGAIN");
+ *errorCodePtr = EAGAIN;
+ }
+ }
+#endif
+
+ switch (err) {
+ case SSL_ERROR_NONE:
+ dprintBuffer(buf, bytesRead);
+ break;
+
+ case SSL_ERROR_SSL:
+ dprintf("SSL negotiation error, indicating that the connection has been aborted");
+
+ Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, bytesRead));
+ *errorCodePtr = ECONNABORTED;
+ bytesRead = -1;
+ break;
+
+ case SSL_ERROR_SYSCALL:
+ backingError = ERR_get_error();
+
+ if (backingError == 0 && bytesRead == 0) {
+ dprintf("EOF reached")
+ *errorCodePtr = 0;
+ bytesRead = 0;
+ } else if (backingError == 0 && bytesRead == -1) {
+ dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ bytesRead = -1;
+ } else {
+ dprintf("I/O error occurred (backingError = %lu)", backingError);
+ *errorCodePtr = backingError;
+ bytesRead = -1;
+ }
+ break;
+
+ case SSL_ERROR_ZERO_RETURN:
+ dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached");
+ bytesRead = 0;
+ *errorCodePtr = 0;
+ break;
+
+ case SSL_ERROR_WANT_READ:
+ dprintf("Got SSL_ERROR_WANT_READ, mapping this to EAGAIN");
+ bytesRead = -1;
+ *errorCodePtr = EAGAIN;
+ break;
+
+ default:
+ dprintf("Unknown error (err = %i), mapping to EOF", err);
+ *errorCodePtr = 0;
+ bytesRead = 0;
+ break;
+ }
+
+ dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
+ return(bytesRead);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsOutputProc --
+ *
+ * This procedure is invoked by the generic IO level
+ * to write output to a SSL socket based channel.
+ *
+ * Results:
+ * The number of bytes written is returned. An output argument is
+ * set to a POSIX error code if an error occurred, or zero.
+ *
+ * Side effects:
+ * Writes output on the output device of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) {
+ unsigned long backingError;
+ State *statePtr = (State *) instanceData;
+ int written, err;
+ int tlsConnect;
+
+ *errorCodePtr = 0;
+
+ dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite);
+ dprintBuffer(buf, toWrite);
+
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ dprintf("Don't process output while callbacks are running");
+ written = -1;
+ *errorCodePtr = EAGAIN;
+ return(-1);
+ }
+
+ dprintf("Calling Tls_WaitForConnect");
+ tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 1);
+ if (tlsConnect < 0) {
+ dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
+
+ written = -1;
+ if (*errorCodePtr == ECONNRESET) {
+ dprintf("Got connection reset");
+ /* Soft EOF */
+ *errorCodePtr = 0;
+ written = 0;
+ }
+ return(written);
+ }
+
+ if (toWrite == 0) {
+ dprintf("zero-write");
+ err = BIO_flush(statePtr->bio);
+
+ if (err <= 0) {
+ dprintf("Flushing failed");
+
+ *errorCodePtr = EIO;
+ written = 0;
+ return(-1);
+ }
+
+ written = 0;
+ *errorCodePtr = 0;
+ return(0);
+ }
+
+ /*
+ * We need to clear the SSL error stack now because we sometimes reach
+ * this function with leftover errors in the stack. If BIO_write
+ * returns -1 and intends EAGAIN, there is a leftover error, it will be
+ * misconstrued as an error, not EAGAIN.
+ *
+ * Alternatively, we may want to handle the <0 return codes from
+ * BIO_write specially (as advised in the RSA docs). TLS's lower level
+ * BIO functions play with the retry flags though, and this seems to
+ * work correctly. Similar fix in TlsInputProc. - hobbs
+ */
+ ERR_clear_error();
+ written = BIO_write(statePtr->bio, buf, toWrite);
+ dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written);
+
+ err = SSL_get_error(statePtr->ssl, written);
+ switch (err) {
+ case SSL_ERROR_NONE:
+ if (written < 0) {
+ written = 0;
+ }
+ break;
+
+ case SSL_ERROR_WANT_WRITE:
+ dprintf("Got SSL_ERROR_WANT_WRITE, mapping it to EAGAIN");
+ *errorCodePtr = EAGAIN;
+ written = -1;
+ break;
+
+ case SSL_ERROR_WANT_READ:
+ dprintf(" write R BLOCK");
+ break;
+
+ case SSL_ERROR_WANT_X509_LOOKUP:
+ dprintf(" write X BLOCK");
+ break;
+
+ case SSL_ERROR_ZERO_RETURN:
+ dprintf(" closed");
+ written = 0;
+ *errorCodePtr = 0;
+ break;
+
+ case SSL_ERROR_SYSCALL:
+ backingError = ERR_get_error();
+
+ if (backingError == 0 && written == 0) {
+ dprintf("EOF reached")
+ *errorCodePtr = 0;
+ written = 0;
+ } else if (backingError == 0 && written == -1) {
+ dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ written = -1;
+ } else {
+ dprintf("I/O error occurred (backingError = %lu)", backingError);
+ *errorCodePtr = backingError;
+ written = -1;
+ }
+ break;
+
+ case SSL_ERROR_SSL:
+ Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written));
+ *errorCodePtr = ECONNABORTED;
+ written = -1;
+ break;
+
+ default:
+ dprintf(" unknown err: %d", err);
+ break;
+ }
+
+ dprintf("Output(%d) -> %d", toWrite, written);
+ return(written);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsSetOptionProc --
+ *
+ * Computes an option value for a SSL socket based channel, or a
+ * list of all options and their values.
+ *
+ * Results:
+ * A standard Tcl result. The value of the specified option or a
+ * list of all options and their values is returned in the
+ * supplied DString.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+TlsSetOptionProc(ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For errors - can be NULL. */
+ const char *optionName, /* Name of the option to set the value for, or
+ * NULL to get all options and their values. */
+ const char *optionValue) /* Value for option. */
+{
+ State *statePtr = (State *) instanceData;
+
+ Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
+ Tcl_DriverSetOptionProc *setOptionProc;
+
+ setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
+ if (setOptionProc != NULL) {
+ return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue);
+ } else if (optionName == (char*) NULL) {
+ /*
+ * Request is query for all options, this is ok.
+ */
+ return TCL_OK;
+ }
+ /*
+ * Request for a specific option has to fail, we don't have any.
+ */
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsGetOptionProc --
+ *
+ * Computes an option value for a SSL socket based channel, or a
+ * list of all options and their values.
+ *
+ * Results:
+ * A standard Tcl result. The value of the specified option or a
+ * list of all options and their values is returned in the
+ * supplied DString.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+TlsGetOptionProc(ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For errors - can be NULL. */
+ const char *optionName, /* Name of the option to retrieve the value for, or
+ * NULL to get all options and their values. */
+ Tcl_DString *dsPtr) /* Where to store the computed value initialized by caller. */
+{
+ State *statePtr = (State *) instanceData;
+
+ Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
+ Tcl_DriverGetOptionProc *getOptionProc;
+
+ getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
+ if (getOptionProc != NULL) {
+ return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr);
+ } else if (optionName == (char*) NULL) {
+ /*
+ * Request is query for all options, this is ok.
+ */
+ return TCL_OK;
+ }
+ /*
+ * Request for a specific option has to fail, we don't have any.
+ */
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsWatchProc --
+ *
+ * Initialize the notifier to watch Tcl_Files from this channel.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets up the notifier so that a future event on the channel
+ * will be seen by Tcl.
+ *
+ *-------------------------------------------------------------------
+ */
+static void
+TlsWatchProc(ClientData instanceData, /* The socket state. */
+ int mask) /* Events of interest; an OR-ed combination of
+ * TCL_READABLE, TCL_WRITABLE and TCL_EXCEPTION. */
+{
+ Tcl_Channel downChan;
+ State *statePtr = (State *) instanceData;
+
+ dprintf("TlsWatchProc(0x%x)", mask);
+
+ /* Pretend to be dead as long as the verify callback is running.
+ * Otherwise that callback could be invoked recursively. */
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ dprintf("Callback is on-going, doing nothing");
+ return;
+ }
+
+ dprintFlags(statePtr);
+
+ downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
+
+ if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
+ dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here");
+ dprintf("Unregistering interest in the lower channel");
+
+ (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), 0);
+ statePtr->watchMask = 0;
+ return;
+ }
+
+ statePtr->watchMask = mask;
+
+ /* No channel handlers any more. We will be notified automatically
+ * about events on the channel below via a call to our
+ * 'TransformNotifyProc'. But we have to pass the interest down now.
+ * We are allowed to add additional 'interest' to the mask if we want
+ * to. But this transformation has no such interest. It just passes
+ * the request down, unchanged.
+ */
+ dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan);
+ (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
+
+ /*
+ * Management of the internal timer.
+ */
+ if (statePtr->timer != (Tcl_TimerToken) NULL) {
+ dprintf("A timer was found, deleting it");
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ statePtr->timer = (Tcl_TimerToken) NULL;
+ }
+
+ if ((mask & TCL_READABLE) &&
+ ((Tcl_InputBuffered(statePtr->self) > 0) || (BIO_ctrl_pending(statePtr->bio) > 0))) {
+ /*
+ * There is interest in readable events and we actually have
+ * data waiting, so generate a timer to flush that.
+ */
+ dprintf("Creating a new timer since data appears to be waiting");
+ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsGetHandleProc --
+ *
+ * Called from Tcl_GetChannelFile to retrieve o/s file handler
+ * from the SSL socket based channel.
+ *
+ * Results:
+ * The appropriate Tcl_File or NULL if not present.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr) {
+ State *statePtr = (State *) instanceData;
+
+ return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr));
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsNotifyProc --
+ *
+ * Handler called by Tcl to inform us of activity
+ * on the underlying channel.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May process the incoming event by itself.
+ *
+ *-------------------------------------------------------------------
+ */
+static int TlsNotifyProc(ClientData instanceData, int mask) {
+ State *statePtr = (State *) instanceData;
+ int errorCode;
+
+ /*
+ * An event occurred in the underlying channel. This
+ * transformation doesn't process such events thus returns the
+ * incoming mask unchanged.
+ */
+ if (statePtr->timer != (Tcl_TimerToken) NULL) {
+ /*
+ * Delete an existing timer. It was not fired, yet we are
+ * here, so the channel below generated such an event and we
+ * don't have to. The renewal of the interest after the
+ * execution of channel handlers will eventually cause us to
+ * recreate the timer (in WatchProc).
+ */
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ statePtr->timer = (Tcl_TimerToken) NULL;
+ }
+
+ if (statePtr->flags & TLS_TCL_CALLBACK) {
+ dprintf("Returning 0 due to callback");
+ return 0;
+ }
+
+ dprintf("Calling Tls_WaitForConnect");
+ errorCode = 0;
+ if (Tls_WaitForConnect(statePtr, &errorCode, 1) < 0) {
+ if (errorCode == EAGAIN) {
+ dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0");
+
+ return 0;
+ }
+
+ dprintf("Tls_WaitForConnect returned an error");
+ }
+
+ dprintf("Returning %i", mask);
+
+ return(mask);
+}
+
+#if 0
+/*
+ *------------------------------------------------------*
+ *
+ * TlsChannelHandler --
+ *
+ * ------------------------------------------------*
+ * Handler called by Tcl as a result of
+ * Tcl_CreateChannelHandler - to inform us of activity
+ * on the underlying channel.
+ * ------------------------------------------------*
+ *
+ * Sideeffects:
+ * May generate subsequent calls to
+ * Tcl_NotifyChannel.
+ *
+ * Result:
+ * None.
+ *
+ *------------------------------------------------------*
+ */
+static void
+TlsChannelHandler (ClientData clientData, int mask) {
+ State *statePtr = (State *) clientData;
+
+ dprintf("HANDLER(0x%x)", mask);
+ Tcl_Preserve((ClientData)statePtr);
+
+ if (mask & TCL_READABLE) {
+ BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ);
+ } else {
+ BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ);
+ }
+
+ if (mask & TCL_WRITABLE) {
+ BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
+ } else {
+ BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
+ }
+
+ mask = 0;
+ if (BIO_wpending(statePtr->bio)) {
+ mask |= TCL_WRITABLE;
+ }
+ if (BIO_pending(statePtr->bio)) {
+ mask |= TCL_READABLE;
+ }
+
+ /*
+ * The following NotifyChannel calls seems to be important, but
+ * we don't know why. It looks like if the mask is ever non-zero
+ * that it will enter an infinite loop.
+ *
+ * Notify the upper channel of the current BIO state so the event
+ * continues to propagate up the chain.
+ *
+ * stanton: It looks like this could result in an infinite loop if
+ * the upper channel doesn't cause ChannelHandler to be removed
+ * before Tcl_NotifyChannel calls channel handlers on the lower channel.
+ */
+ Tcl_NotifyChannel(statePtr->self, mask);
+
+ if (statePtr->timer != (Tcl_TimerToken)NULL) {
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ statePtr->timer = (Tcl_TimerToken)NULL;
+ }
+ if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
+ /*
+ * Data is waiting, flush it out in short time
+ */
+ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr);
+ }
+ Tcl_Release((ClientData)statePtr);
+}
+#endif
+
+/*
+ *------------------------------------------------------*
+ *
+ * TlsChannelHandlerTimer --
+ *
+ * ------------------------------------------------*
+ * Called by the notifier (-> timer) to flush out
+ * information waiting in channel buffers.
+ * ------------------------------------------------*
+ *
+ * Sideeffects:
+ * As of 'TlsChannelHandler'.
+ *
+ * Result:
+ * None.
+ *
+ *------------------------------------------------------*
+ */
+static void TlsChannelHandlerTimer(ClientData clientData) {
+ State *statePtr = (State *) clientData;
+ int mask = 0;
+
+ dprintf("Called");
+
+ statePtr->timer = (Tcl_TimerToken) NULL;
+
+ if (BIO_wpending(statePtr->bio)) {
+ dprintf("[chan=%p] BIO writable", statePtr->self);
+
+ mask |= TCL_WRITABLE;
+ }
+
+ if (BIO_pending(statePtr->bio)) {
+ dprintf("[chan=%p] BIO readable", statePtr->self);
+
+ mask |= TCL_READABLE;
+ }
+
+ dprintf("Notifying ourselves");
+ Tcl_NotifyChannel(statePtr->self, mask);
+
+ dprintf("Returning");
+
+ return;
+}
+
+Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) {
+ dprintf("Requested to get parent of channel %p", statePtr->self);
+
+ if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) {
+ dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL");
+ return(NULL);
+ }
+ return(Tcl_GetStackedChannel(statePtr->self));
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_ChannelType --
+ *
+ * Return the correct TLS channel driver info
+ *
+ * Results:
+ * The correct channel driver for the current version of Tcl.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+Tcl_ChannelType *Tls_ChannelType(void) {
+ unsigned int size;
+
+ /*
+ * Initialize the channel type if necessary
+ */
+ if (tlsChannelType == NULL) {
+ /*
+ * Allocate new channeltype structure
+ */
+ size = sizeof(Tcl_ChannelType); /* Base size */
+
+ tlsChannelType = (Tcl_ChannelType *) ckalloc(size);
+ memset((void *) tlsChannelType, 0, size);
+
+ tlsChannelType->typeName = "tls";
+#ifdef TCL_CHANNEL_VERSION_5
+ tlsChannelType->version = TCL_CHANNEL_VERSION_5;
+ tlsChannelType->closeProc = TlsCloseProc;
+ tlsChannelType->inputProc = TlsInputProc;
+ tlsChannelType->outputProc = TlsOutputProc;
+ tlsChannelType->seekProc = NULL;
+ tlsChannelType->setOptionProc = TlsSetOptionProc;
+ tlsChannelType->getOptionProc = TlsGetOptionProc;
+ tlsChannelType->watchProc = TlsWatchProc;
+ tlsChannelType->getHandleProc = TlsGetHandleProc;
+ tlsChannelType->close2Proc = TlsCloseProc2;
+ tlsChannelType->blockModeProc = TlsBlockModeProc;
+ tlsChannelType->flushProc = NULL;
+ tlsChannelType->handlerProc = TlsNotifyProc;
+ tlsChannelType->wideSeekProc = NULL;
+ tlsChannelType->threadActionProc = NULL;
+ tlsChannelType->truncateProc = NULL;
+#else
+ tlsChannelType->version = TCL_CHANNEL_VERSION_2;
+ tlsChannelType->closeProc = TlsCloseProc;
+ tlsChannelType->inputProc = TlsInputProc;
+ tlsChannelType->outputProc = TlsOutputProc;
+ tlsChannelType->seekProc = NULL;
+ tlsChannelType->setOptionProc = TlsSetOptionProc;
+ tlsChannelType->getOptionProc = TlsGetOptionProc;
+ tlsChannelType->watchProc = TlsWatchProc;
+ tlsChannelType->getHandleProc = TlsGetHandleProc;
+ tlsChannelType->close2Proc = NULL;
+ tlsChannelType->blockModeProc = TlsBlockModeProc;
+ tlsChannelType->flushProc = NULL;
+ tlsChannelType->handlerProc = TlsNotifyProc;
+#endif
+ }
+ return(tlsChannelType);
+}
ADDED generic/tlsInt.h
Index: generic/tlsInt.h
==================================================================
--- /dev/null
+++ generic/tlsInt.h
@@ -0,0 +1,178 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman
+ *
+ * TLS (aka SSL) Channel - can be layered on any bi-directional
+ * Tcl_Channel (Note: Requires Trf Core Patch)
+ *
+ * This was built from scratch based upon observation of OpenSSL 0.9.2B
+ *
+ * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
+ * providing the Tcl_ReplaceChannel mechanism and working closely with me
+ * to enhance it to support full fileevent semantics.
+ *
+ * Also work done by the follow people provided the impetus to do this "right":-
+ * tclSSL (Colin McCormack, Shared Technology)
+ * SSLtcl (Peter Antman)
+ *
+ */
+#ifndef _TLSINT_H
+#define _TLSINT_H
+
+#include "tls.h"
+#include
+#include
+#include
+
+#ifdef _WIN32
+#define WIN32_LEAN_AND_MEAN
+#include
+#include /* OpenSSL needs this on Windows */
+#endif
+
+/* 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 */
+#endif
+
+#ifdef TCLEXT_TCLTLS_DEBUG
+#include
+#define dprintf(...) { \
+ char dprintfBuffer[8192], *dprintfBuffer_p; \
+ dprintfBuffer_p = &dprintfBuffer[0]; \
+ dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \
+ dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \
+ fprintf(stderr, "%s\n", dprintfBuffer); \
+}
+#define dprintBuffer(bufferName, bufferLength) { \
+ int dprintBufferIdx; \
+ unsigned char dprintBufferChar; \
+ fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \
+ for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \
+ dprintBufferChar = bufferName[dprintBufferIdx]; \
+ if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \
+ fprintf(stderr, "'%c' ", dprintBufferChar); \
+ } else { \
+ fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \
+ }; \
+ }; \
+ fprintf(stderr, "}\n"); \
+}
+#define dprintFlags(statePtr) { \
+ char dprintfBuffer[8192], *dprintfBuffer_p; \
+ dprintfBuffer_p = &dprintfBuffer[0]; \
+ dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \
+ if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \
+ if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \
+ if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \
+ if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \
+ if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \
+ if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \
+ if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \
+ fprintf(stderr, "%s\n", dprintfBuffer); \
+}
+#else
+#define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); }
+#define dprintBuffer(bufferName, bufferLength) /**/
+#define dprintFlags(statePtr) /**/
+#endif
+
+#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err))))
+/*
+ * OpenSSL BIO Routines
+ */
+#define BIO_TYPE_TCL (19|0x0400)
+
+/*
+ * Defines for State.flags
+ */
+#define TLS_TCL_ASYNC (1<<0) /* non-blocking mode */
+#define TLS_TCL_SERVER (1<<1) /* Server-Side */
+#define TLS_TCL_INIT (1<<2) /* Initializing connection */
+#define TLS_TCL_DEBUG (1<<3) /* Show debug tracing */
+#define TLS_TCL_CALLBACK (1<<4) /* In a callback, prevent update
+ * looping problem. [Bug 1652380] */
+#define TLS_TCL_HANDSHAKE_FAILED (1<<5) /* Set on handshake failures and once set, all
+ * further I/O will result in ECONNABORTED errors. */
+#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */
+#define TLS_TCL_DELAY (5)
+
+/*
+ * This structure describes the per-instance state of an SSL channel.
+ *
+ * The SSL processing context is maintained here, in the ClientData
+ */
+typedef struct State {
+ Tcl_Channel self; /* this socket channel */
+ Tcl_TimerToken timer;
+
+ int flags; /* see State.flags above */
+ int watchMask; /* current WatchProc mask */
+ int mode; /* current mode of parent channel */
+
+ Tcl_Interp *interp; /* interpreter in which this resides */
+ Tcl_Obj *callback; /* script called for tracing, verifying and errors */
+ Tcl_Obj *password; /* script called for certificate password */
+
+ 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 *err;
+} State;
+
+#ifdef USE_TCL_STUBS
+#ifndef Tcl_StackChannel
+#error "Unable to compile on this version of Tcl"
+#endif /* Tcl_GetStackedChannel */
+#endif /* USE_TCL_STUBS */
+
+/*
+ * Forward declarations
+ */
+Tcl_ChannelType *Tls_ChannelType(void);
+Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags);
+
+Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert);
+void Tls_Error(State *statePtr, char *msg);
+void Tls_Free(char *blockPtr);
+void Tls_Clean(State *statePtr);
+int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent);
+
+BIO *BIO_new_tcl(State* statePtr, int flags);
+
+#define PTR2INT(x) ((int) ((intptr_t) (x)))
+
+#endif /* _TLSINT_H */
ADDED generic/tlsX509.c
Index: generic/tlsX509.c
==================================================================
--- /dev/null
+++ generic/tlsX509.c
@@ -0,0 +1,213 @@
+/*
+ * Copyright (C) 1997-2000 Sensus Consulting Ltd.
+ * Matt Newman
+ */
+#include
+#include
+#include
+#include
+#include
+#include
+#include "tlsInt.h"
+
+/*
+ * Ensure these are not macros - known to be defined on Win32
+ */
+#ifdef min
+#undef min
+#endif
+
+#ifdef max
+#undef max
+#endif
+
+static int min(int a, int b)
+{
+ return (a < b) ? a : b;
+}
+
+static int max(int a, int b)
+{
+ return (a > b) ? a : b;
+}
+
+/*
+ * ASN1_UTCTIME_tostr --
+ */
+static char *
+ASN1_UTCTIME_tostr(ASN1_UTCTIME *tm)
+{
+ static char bp[128];
+ char *v;
+ int gmt=0;
+ static char *mon[12]={
+ "Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"};
+ int i;
+ int y=0,M=0,d=0,h=0,m=0,s=0;
+
+ i=tm->length;
+ v=(char *)tm->data;
+
+ if (i < 10) goto err;
+ if (v[i-1] == 'Z') gmt=1;
+ for (i=0; i<10; i++)
+ if ((v[i] > '9') || (v[i] < '0')) goto err;
+ y= (v[0]-'0')*10+(v[1]-'0');
+ if (y < 70) y+=100;
+ M= (v[2]-'0')*10+(v[3]-'0');
+ if ((M > 12) || (M < 1)) goto err;
+ d= (v[4]-'0')*10+(v[5]-'0');
+ h= (v[6]-'0')*10+(v[7]-'0');
+ m= (v[8]-'0')*10+(v[9]-'0');
+ if ((v[10] >= '0') && (v[10] <= '9') && (v[11] >= '0') && (v[11] <= '9'))
+ s= (v[10]-'0')*10+(v[11]-'0');
+
+ sprintf(bp,"%s %2d %02d:%02d:%02d %d%s", mon[M-1],d,h,m,s,y+1900,(gmt)?" GMT":"");
+ return bp;
+ err:
+ return "Bad time value";
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ * Tls_NewX509Obj --
+ *
+ * ------------------------------------------------*
+ * Converts a X509 certificate into a Tcl_Obj
+ * ------------------------------------------------*
+ *
+ * Sideeffects:
+ * None
+ *
+ * Result:
+ * A Tcl List Object representing the provided
+ * X509 certificate.
+ *
+ *------------------------------------------------------*
+ */
+
+#define CERT_STR_SIZE 16384
+
+Tcl_Obj*
+Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert) {
+ Tcl_Obj *certPtr = Tcl_NewListObj(0, NULL);
+ BIO *bio;
+ int n;
+ unsigned long flags;
+ char subject[BUFSIZ];
+ char issuer[BUFSIZ];
+ 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";
+
+ 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;
+ serial[0] = 0;
+ } else {
+ flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT;
+ flags &= ~ASN1_STRFLGS_ESC_MSB;
+
+ X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags);
+ n = BIO_read(bio, subject, min(BIO_pending(bio), BUFSIZ - 1));
+ n = max(n, 0);
+ subject[n] = 0;
+ (void)BIO_flush(bio);
+
+ X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags);
+ n = BIO_read(bio, issuer, min(BIO_pending(bio), BUFSIZ - 1));
+ n = max(n, 0);
+ issuer[n] = 0;
+ (void)BIO_flush(bio);
+
+ i2a_ASN1_INTEGER(bio, X509_get_serialNumber(cert));
+ n = BIO_read(bio, serial, min(BIO_pending(bio), BUFSIZ - 1));
+ n = max(n, 0);
+ serial[n] = 0;
+ (void)BIO_flush(bio);
+
+ if (PEM_write_bio_X509(bio, cert)) {
+ certStr_p = certStr;
+ certStr_len = 0;
+ while (1) {
+ toRead = min(BIO_pending(bio), CERT_STR_SIZE - certStr_len - 1);
+ toRead = min(toRead, BUFSIZ);
+ if (toRead == 0) {
+ break;
+ }
+ dprintf("Reading %i bytes from the certificate...", toRead);
+ n = BIO_read(bio, certStr_p, toRead);
+ if (n <= 0) {
+ break;
+ }
+ certStr_len += n;
+ certStr_p += n;
+ }
+ *certStr_p = '\0';
+ (void)BIO_flush(bio);
+ }
+
+ 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
+
+#ifndef NO_SSL_SHA
+ /* SHA1 */
+ 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) );
+
+ /* SHA256 */
+ 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) );
+
+ return certPtr;
+}
ADDED library/tls.tcl
Index: library/tls.tcl
==================================================================
--- /dev/null
+++ library/tls.tcl
@@ -0,0 +1,399 @@
+#
+# Copyright (C) 1997-2000 Matt Newman
+#
+namespace eval tls {
+ variable logcmd tclLog
+ variable debug 0
+
+ # Default flags passed to tls::import
+ variable defaults {}
+
+ # Maps UID to Server Socket
+ variable srvmap
+ variable srvuid 0
+
+ # Over-ride this if you are using a different socket command
+ variable socketCmd
+ if {![info exists socketCmd]} {
+ set socketCmd [info command ::socket]
+ }
+
+ # This is the possible arguments to tls::socket and tls::init
+ # The format of this is a list of lists
+ ## Each inner list contains the following elements
+ ### Server (matched against "string match" for 0/1)
+ ### Option name
+ ### Variable to add the option to:
+ #### sopts: [socket] option
+ #### iopts: [tls::import] option
+ ### How many arguments the following the option to consume
+ variable socketOptionRules {
+ {0 -async sopts 0}
+ {* -myaddr sopts 1}
+ {0 -myport sopts 1}
+ {* -type sopts 1}
+ {* -cadir iopts 1}
+ {* -cafile iopts 1}
+ {* -cert iopts 1}
+ {* -certfile iopts 1}
+ {* -cipher iopts 1}
+ {* -command iopts 1}
+ {* -dhparams iopts 1}
+ {* -key iopts 1}
+ {* -keyfile iopts 1}
+ {* -password iopts 1}
+ {* -request iopts 1}
+ {* -require iopts 1}
+ {* -autoservername discardOpts 1}
+ {* -servername iopts 1}
+ {* -alpn iopts 1}
+ {* -ssl2 iopts 1}
+ {* -ssl3 iopts 1}
+ {* -tls1 iopts 1}
+ {* -tls1.1 iopts 1}
+ {* -tls1.2 iopts 1}
+ {* -tls1.3 iopts 1}
+ }
+
+ # tls::socket and tls::init options as a humane readable string
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+
+ # Internal [switch] body to validate options
+ variable socketOptionsSwitchBody
+}
+
+proc tls::_initsocketoptions {} {
+ variable socketOptionRules
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ # Do not re-run if we have already been initialized
+ if {[info exists socketOptionsSwitchBody]} {
+ return
+ }
+
+ # Create several structures from our list of options
+ ## 1. options: a text representation of the valid options for the current
+ ## server type
+ ## 2. argSwitchBody: Switch body for processing arguments
+ set options(0) [list]
+ set options(1) [list]
+ set argSwitchBody [list]
+ foreach optionRule $socketOptionRules {
+ set ruleServer [lindex $optionRule 0]
+ set ruleOption [lindex $optionRule 1]
+ set ruleVarToUpdate [lindex $optionRule 2]
+ set ruleVarArgsToConsume [lindex $optionRule 3]
+
+ foreach server [list 0 1] {
+ if {![string match $ruleServer $server]} {
+ continue
+ }
+
+ lappend options($server) $ruleOption
+ }
+
+ switch -- $ruleVarArgsToConsume {
+ 0 {
+ set argToExecute {
+ lappend @VAR@ $arg
+ set argsArray($arg) true
+ }
+ }
+ 1 {
+ set argToExecute {
+ incr idx
+ if {$idx >= [llength $args]} {
+ return -code error "\"$arg\" option must be followed by value"
+ }
+ set argValue [lindex $args $idx]
+ lappend @VAR@ $arg $argValue
+ set argsArray($arg) $argValue
+ }
+ }
+ default {
+ return -code error "Internal argument construction error"
+ }
+ }
+
+ lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
+ }
+
+ # Add in the final options
+ lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
+ lappend argSwitchBody default break
+
+ # Set the final variables
+ set socketOptionsNoServer [join $options(0) {, }]
+ set socketOptionsServer [join $options(1) {, }]
+ set socketOptionsSwitchBody $argSwitchBody
+}
+
+proc tls::initlib {dir dll} {
+ # Package index cd's into the package directory for loading.
+ # Irrelevant to unixoids, but for Windows this enables the OS to find
+ # the dependent DLL's in the CWD, where they may be.
+ set cwd [pwd]
+ catch {cd $dir}
+ if {[string equal $::tcl_platform(platform) "windows"] &&
+ ![string equal [lindex [file system $dir] 0] "native"]} {
+ # If it is a wrapped executable running on windows, the openssl
+ # dlls must be copied out of the virtual filesystem to the disk
+ # where Windows will find them when resolving the dependency in
+ # the tls dll. We choose to make them siblings of the executable.
+ package require starkit
+ set dst [file nativename [file dirname $starkit::topdir]]
+ foreach sdll [glob -nocomplain -directory $dir -tails libssl32.dll libcrypto*.dll libssl*.dll libssp*.dll] {
+ catch {file delete -force $dst/$sdll}
+ catch {file copy -force $dir/$sdll $dst/$sdll}
+ }
+ }
+ set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
+ catch {cd $cwd}
+ if {$res} {
+ namespace eval [namespace parent] {namespace delete tls}
+ return -code $res $err
+ }
+ rename tls::initlib {}
+}
+
+
+#
+# Backwards compatibility, also used to set the default
+# context options
+#
+proc tls::init {args} {
+ variable defaults
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ tls::_initsocketoptions
+
+ # Technically a third option should be used here: Options that are valid
+ # only a both servers and non-servers
+ set server -1
+ set options $socketOptionsServer
+
+ # Validate arguments passed
+ set initialArgs $args
+ set argc [llength $args]
+
+ array set argsArray [list]
+ for {set idx 0} {$idx < $argc} {incr idx} {
+ set arg [lindex $args $idx]
+ switch -glob -- $server,$arg $socketOptionsSwitchBody
+ }
+
+ set defaults $initialArgs
+}
+#
+# Helper function - behaves exactly as the native socket command.
+#
+proc tls::socket {args} {
+ variable socketCmd
+ variable defaults
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ tls::_initsocketoptions
+
+ set idx [lsearch $args -server]
+ if {$idx != -1} {
+ set server 1
+ set callback [lindex $args [expr {$idx+1}]]
+ set args [lreplace $args $idx [expr {$idx+1}]]
+
+ set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
+ set options $socketOptionsServer
+ } else {
+ set server 0
+
+ set usage "wrong # args: should be \"tls::socket ?options? host port\""
+ set options $socketOptionsNoServer
+ }
+
+ # Combine defaults with current options
+ set args [concat $defaults $args]
+
+ set argc [llength $args]
+ set sopts {}
+ set iopts [list -server $server]
+
+ array set argsArray [list]
+ for {set idx 0} {$idx < $argc} {incr idx} {
+ set arg [lindex $args $idx]
+ switch -glob -- $server,$arg $socketOptionsSwitchBody
+ }
+
+ if {$server} {
+ if {($idx + 1) != $argc} {
+ return -code error $usage
+ }
+ set uid [incr ::tls::srvuid]
+
+ set port [lindex $args [expr {$argc-1}]]
+ lappend sopts $port
+ #set sopts [linsert $sopts 0 -server $callback]
+ set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
+ #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
+ } else {
+ if {($idx + 2) != $argc} {
+ return -code error $usage
+ }
+
+ set host [lindex $args [expr {$argc-2}]]
+ set port [lindex $args [expr {$argc-1}]]
+
+ # If an "-autoservername" option is found, honor it
+ if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
+ if {![info exists argsArray(-servername)]} {
+ set argsArray(-servername) $host
+ lappend iopts -servername $host
+ }
+ }
+
+ lappend sopts $host $port
+ }
+ #
+ # Create TCP/IP socket
+ #
+ set chan [eval $socketCmd $sopts]
+ if {!$server && [catch {
+ #
+ # Push SSL layer onto socket
+ #
+ eval [list tls::import] $chan $iopts
+ } err]} {
+ set info ${::errorInfo}
+ catch {close $chan}
+ return -code error -errorinfo $info $err
+ }
+ return $chan
+}
+
+# tls::_accept --
+#
+# This is the actual accept that TLS sockets use, which then calls
+# the callback registered by tls::socket.
+#
+# Arguments:
+# iopts tls::import opts
+# callback server callback to invoke
+# chan socket channel to accept/deny
+# ipaddr calling IP address
+# port calling port
+#
+# Results:
+# Returns an error if the callback throws one.
+#
+proc tls::_accept { iopts callback chan ipaddr port } {
+ log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]
+
+ set chan [eval [list tls::import $chan] $iopts]
+
+ lappend callback $chan $ipaddr $port
+ if {[catch {
+ uplevel #0 $callback
+ } err]} {
+ log 1 "tls::_accept error: ${::errorInfo}"
+ close $chan
+ error $err $::errorInfo $::errorCode
+ } else {
+ log 2 "tls::_accept - called \"$callback\" succeeded"
+ }
+}
+#
+# Sample callback for hooking: -
+#
+# error
+# verify
+# info
+#
+proc tls::callback {option args} {
+ variable debug
+
+ #log 2 [concat $option $args]
+
+ switch -- $option {
+ "error" {
+ foreach {chan msg} $args break
+
+ log 0 "TLS/$chan: error: $msg"
+ }
+ "verify" {
+ # poor man's lassign
+ foreach {chan depth cert rc err} $args break
+
+ array set c $cert
+
+ if {$rc != "1"} {
+ log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
+ } else {
+ log 2 "TLS/$chan: verify/$depth: $c(subject)"
+ }
+ if {$debug > 0} {
+ return 1; # FORCE OK
+ } else {
+ return $rc
+ }
+ }
+ "info" {
+ # poor man's lassign
+ foreach {chan major minor state msg} $args break
+
+ if {$msg != ""} {
+ append state ": $msg"
+ }
+ # For tracing
+ upvar #0 tls::$chan cb
+ set cb($major) $minor
+
+ log 2 "TLS/$chan: $major/$minor: $state"
+ }
+ default {
+ return -code error "bad option \"$option\":\
+ must be one of error, info, or verify"
+ }
+ }
+}
+
+proc tls::xhandshake {chan} {
+ upvar #0 tls::$chan cb
+
+ if {[info exists cb(handshake)] && \
+ $cb(handshake) == "done"} {
+ return 1
+ }
+ while {1} {
+ vwait tls::${chan}(handshake)
+ if {![info exists cb(handshake)]} {
+ return 0
+ }
+ if {$cb(handshake) == "done"} {
+ return 1
+ }
+ }
+}
+
+proc tls::password {} {
+ log 0 "TLS/Password: did you forget to set your passwd!"
+ # Return the worlds best kept secret password.
+ return "secret"
+}
+
+proc tls::log {level msg} {
+ variable debug
+ variable logcmd
+
+ if {$level > $debug || $logcmd == ""} {
+ return
+ }
+ set cmd $logcmd
+ lappend cmd $msg
+ uplevel #0 $cmd
+}
+
DELETED tclOpts.h
Index: tclOpts.h
==================================================================
--- tclOpts.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Matt Newman
- *
- * Stylized option processing - requires consistent
- * external vars: opt, idx, objc, objv
- */
-
-#ifndef _TCL_OPTS_H
-#define _TCL_OPTS_H
-
-#define OPT_PROLOG(option) \
- if (strcmp(opt, (option)) == 0) { \
- if (++idx >= objc) { \
- Tcl_AppendResult(interp, \
- "no argument given for ", \
- (option), " option", \
- (char *) NULL); \
- return TCL_ERROR; \
- }
-#define OPT_POSTLOG() \
- continue; \
- }
-#define OPTOBJ(option, var) \
- OPT_PROLOG(option) \
- var = objv[idx]; \
- OPT_POSTLOG()
-
-#define OPTSTR(option, var) \
- OPT_PROLOG(option) \
- var = Tcl_GetStringFromObj(objv[idx], NULL);\
- OPT_POSTLOG()
-
-#define OPTINT(option, var) \
- OPT_PROLOG(option) \
- if (Tcl_GetIntFromObj(interp, objv[idx], \
- &(var)) != TCL_OK) { \
- return TCL_ERROR; \
- } \
- OPT_POSTLOG()
-
-#define OPTBOOL(option, var) \
- OPT_PROLOG(option) \
- if (Tcl_GetBooleanFromObj(interp, objv[idx],\
- &(var)) != TCL_OK) { \
- return TCL_ERROR; \
- } \
- OPT_POSTLOG()
-
-#define OPTBYTE(option, var, lvar) \
- OPT_PROLOG(option) \
- var = Tcl_GetByteArrayFromObj(objv[idx], &(lvar));\
- OPT_POSTLOG()
-
-#define OPTBAD(type, list) \
- Tcl_AppendResult(interp, "bad ", (type), \
- " \"", opt, "\": must be ", \
- (list), (char *) NULL)
-
-#endif /* _TCL_OPTS_H */
DELETED tcltls.syms.in
Index: tcltls.syms.in
==================================================================
--- tcltls.syms.in
+++ /dev/null
@@ -1,1 +0,0 @@
-@SYMPREFIX@Tls_Init
DELETED tcltls.vers
Index: tcltls.vers
==================================================================
--- tcltls.vers
+++ /dev/null
@@ -1,6 +0,0 @@
-{
- global:
- Tls_Init;
- local:
- *;
-};
DELETED tls.c
Index: tls.c
==================================================================
--- tls.c
+++ /dev/null
@@ -1,2030 +0,0 @@
-/*
- * Copyright (C) 1997-1999 Matt Newman
- * some modifications:
- * Copyright (C) 2000 Ajuba Solutions
- * Copyright (C) 2002 ActiveState Corporation
- * Copyright (C) 2004 Starfish Systems
- *
- * 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
- * OpenSSL 0.9.2B
- *
- * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
- * providing the Tcl_ReplaceChannel mechanism and working closely with me
- * to enhance it to support full fileevent semantics.
- *
- * Also work done by the follow people provided the impetus to do this "right":
- * tclSSL (Colin McCormack, Shared Technology)
- * SSLtcl (Peter Antman)
- *
- */
-
-#include "tlsInt.h"
-#include "tclOpts.h"
-#include
-#include
-#include
-
-/*
- * External functions
- */
-
-/*
- * Forward declarations
- */
-
-#define F2N(key, dsp) \
- (((key) == NULL) ? (char *) NULL : \
- Tcl_TranslateFileName(interp, (key), (dsp)))
-#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);
-
-static int TlsLibInit(int uninitialize);
-
-#define TLS_PROTO_SSL2 0x01
-#define TLS_PROTO_SSL3 0x02
-#define TLS_PROTO_TLS1 0x04
-#define TLS_PROTO_TLS1_1 0x08
-#define TLS_PROTO_TLS1_2 0x10
-#define TLS_PROTO_TLS1_3 0x20
-#define ENABLED(flag, mask) (((flag) & (mask)) == (mask))
-
-#define SSLKEYLOGFILE "SSLKEYLOGFILE"
-
-/*
- * Static data structures
- */
-
-#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
-#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.
- */
-
-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 */
-
-
-/*
- *-------------------------------------------------------------------
- *
- * InfoCallback --
- *
- * monitors SSL connection process
- *
- * Results:
- * None
- *
- * Side effects:
- * Calls callback (if defined)
- *-------------------------------------------------------------------
- */
-static void
-InfoCallback(const SSL *ssl, int where, int ret) {
- State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
- Tcl_Obj *cmdPtr;
- char *major; char *minor;
-
- dprintf("Called");
-
- if (statePtr->callback == (Tcl_Obj*)NULL)
- return;
-
- cmdPtr = Tcl_DuplicateObj(statePtr->callback);
-
-#if 0
- if (where & SSL_CB_ALERT) {
- sev = SSL_alert_type_string_long(ret);
- if (strcmp(sev, "fatal")==0) { /* Map to error */
- Tls_Error(statePtr, SSL_ERROR(ssl, 0));
- return;
- }
- }
-#endif
- if (where & SSL_CB_HANDSHAKE_START) {
- major = "handshake";
- minor = "start";
- } else if (where & SSL_CB_HANDSHAKE_DONE) {
- major = "handshake";
- minor = "done";
- } else {
- if (where & SSL_CB_ALERT) major = "alert";
- else if (where & SSL_ST_CONNECT) major = "connect";
- else if (where & SSL_ST_ACCEPT) major = "accept";
- else major = "unknown";
-
- if (where & SSL_CB_READ) minor = "read";
- else if (where & SSL_CB_WRITE) minor = "write";
- 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_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(major, -1));
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, Tcl_NewStringObj(minor, -1));
-
- if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) {
- Tcl_ListObjAppendElement(statePtr->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));
- } else {
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
- Tcl_NewStringObj(SSL_state_string_long(ssl), -1));
- }
- Tcl_Preserve((ClientData) statePtr->interp);
- Tcl_Preserve((ClientData) statePtr);
-
- Tcl_IncrRefCount(cmdPtr);
- (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount(cmdPtr);
-
- Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * VerifyCallback --
- *
- * Monitors SSL certificate validation process.
- * This is called whenever a certificate is inspected
- * or decided invalid.
- *
- * Results:
- * A callback bound to the socket may return one of:
- * 0 - the certificate is deemed invalid
- * 1 - the certificate is deemed valid
- * empty string - no change to certificate validation
- *
- * Side effects:
- * The err field of the currently operative State is set
- * to a string describing the SSL negotiation failure reason
- *-------------------------------------------------------------------
- */
-static int
-VerifyCallback(int ok, X509_STORE_CTX *ctx) {
- Tcl_Obj *cmdPtr, *result;
- 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);
- int depth = X509_STORE_CTX_get_error_depth(ctx);
- int err = X509_STORE_CTX_get_error(ctx);
- int code;
-
- dprintf("Verify: %d", ok);
-
- if (!ok) {
- errStr = (char*)X509_verify_cert_error_string(err);
- } else {
- errStr = (char *)0;
- }
-
- if (statePtr->callback == (Tcl_Obj*)NULL) {
- if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
- return ok;
- } else {
- 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_Preserve((ClientData) statePtr);
-
- statePtr->flags |= TLS_TCL_CALLBACK;
-
- Tcl_IncrRefCount(cmdPtr);
- code = Tcl_EvalObjEx(statePtr->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);
-#else
- Tcl_BackgroundException(statePtr->interp, code);
-#endif
- ok = 0;
- } else {
- result = Tcl_GetObjResult(statePtr->interp);
- string = Tcl_GetStringFromObj(result, &length);
- /* An empty result leaves verification unchanged. */
- if (string != NULL && length > 0) {
- code = Tcl_GetIntFromObj(statePtr->interp, result, &ok);
- if (code != TCL_OK) {
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->interp, code);
-#endif
- ok = 0;
- }
- }
- }
- Tcl_DecrRefCount(cmdPtr);
-
- statePtr->flags &= ~(TLS_TCL_CALLBACK);
-
- Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
- return(ok); /* By default, leave verification unchanged. */
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_Error --
- *
- * Calls callback with $fd and $msg - so the callback can decide
- * what to do with errors.
- *
- * Side effects:
- * The err field of the currently operative State is set
- * to a string describing the SSL negotiation failure reason
- *-------------------------------------------------------------------
- */
-void
-Tls_Error(State *statePtr, char *msg) {
- Tcl_Obj *cmdPtr;
- int code;
-
- dprintf("Called");
-
- if (msg && *msg) {
- Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL);
- } else {
- msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->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);
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->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_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
-
- Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
- Tcl_NewStringObj(msg, -1));
-
- Tcl_Preserve((ClientData) statePtr->interp);
- Tcl_Preserve((ClientData) statePtr);
-
- Tcl_IncrRefCount(cmdPtr);
- code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
- if (code != TCL_OK) {
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->interp, code);
-#endif
- }
- Tcl_DecrRefCount(cmdPtr);
- Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
-}
-
-void KeyLogCallback(const SSL *ssl, const char *line) {
- char *str = getenv(SSLKEYLOGFILE);
- FILE *fd;
- if (str) {
- fd = fopen(str, "a");
- fprintf(fd, "%s\n",line);
- fclose(fd);
- }
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * PasswordCallback --
- *
- * 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;
- int code;
-
- dprintf("Called");
-
- if (statePtr->password == NULL) {
- if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) == TCL_OK) {
- char *ret = (char *) Tcl_GetStringResult(interp);
- strncpy(buf, ret, (size_t) size);
- return (int)strlen(ret);
- } else {
- return -1;
- }
- }
-
- cmdPtr = Tcl_DuplicateObj(statePtr->password);
-
- 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);
-
- if (code == TCL_OK) {
- char *ret = (char *) Tcl_GetStringResult(interp);
- if (strlen(ret) < size - 1) {
- strncpy(buf, ret, (size_t) size);
- Tcl_Release((ClientData) interp);
- return (int)strlen(ret);
- }
- }
- Tcl_Release((ClientData) interp);
- return -1;
- verify = verify;
-}
-#endif
-
-/*
- *-------------------------------------------------------------------
- *
- * CiphersObjCmd -- list available ciphers
- *
- * This procedure is invoked to process the "tls::ciphers" command
- * to list available ciphers, based upon protocol selected.
- *
- * Results:
- * A standard Tcl result list.
- *
- * Side effects:
- * constructs and destroys SSL context (CTX)
- *
- *-------------------------------------------------------------------
- */
-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];
- int index, verbose = 0;
-
- dprintf("Called");
-
- if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?");
- 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;
- }
- switch ((enum protocol)index) {
- case TLS_SSL2:
-#if OPENSSL_VERSION_NUMBER >= 0x10101000L || 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)
- 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)
- 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)
- 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)
- Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLSv1_2_method()); break;
-#endif
- case TLS_TLS1_3:
-#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
- Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLS_method());
- SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION);
- SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION);
- break;
-#endif
- default:
- break;
- }
- 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));
- }
- } 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';
- } else {
- break;
- }
- }
- Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1));
- }
- }
- SSL_free(ssl);
- SSL_CTX_free(ctx);
-
- Tcl_SetObjResult(interp, objPtr);
- return TCL_OK;
- clientData = clientData;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * HandshakeObjCmd --
- *
- * This command is used to verify whether the handshake is complete
- * or not.
- *
- * Results:
- * A standard Tcl result. 1 means handshake complete, 0 means pending.
- *
- * Side effects:
- * May force SSL negotiation to take place.
- *
- *-------------------------------------------------------------------
- */
-static int HandshakeObjCmd(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 */
- const char *errStr = NULL;
- int ret = 1;
- int err = 0;
-
- dprintf("Called");
-
- 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);
- }
- statePtr = (State *)Tcl_GetChannelInstanceData(chan);
-
- dprintf("Calling Tls_WaitForConnect");
- ret = Tls_WaitForConnect(statePtr, &err, 1);
- dprintf("Tls_WaitForConnect returned: %i", ret);
-
- if (ret < 0 && ((statePtr->flags & TLS_TCL_ASYNC) && (err == EAGAIN))) {
- dprintf("Async set and err = EAGAIN");
- ret = 0;
- } else if (ret < 0) {
- errStr = statePtr->err;
- Tcl_ResetResult(interp);
- Tcl_SetErrno(err);
-
- if (!errStr || (*errStr == 0)) {
- errStr = Tcl_PosixError(interp);
- }
-
- Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL);
- dprintf("Returning TCL_ERROR with handshake failed: %s", errStr);
- return(TCL_ERROR);
- } else {
- if (err != 0) {
- dprintf("Got an error with a completed handshake: err = %i", err);
- }
- ret = 1;
- }
-
- dprintf("Returning TCL_OK with data \"%i\"", ret);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
- return(TCL_OK);
- clientData = clientData;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * ImportObjCmd --
- *
- * This procedure is invoked to process the "ssl" command
- *
- * The ssl command pushes SSL over a (newly connected) tcp socket
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * May modify the behavior of an IO channel.
- *
- *-------------------------------------------------------------------
- */
-static int
-ImportObjCmd(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 */
- SSL_CTX *ctx = NULL;
- Tcl_Obj *script = NULL;
- Tcl_Obj *password = NULL;
- Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar;
- int idx, len;
- int flags = TLS_TCL_INIT;
- int server = 0; /* is connection incoming or outgoing? */
- char *keyfile = NULL;
- char *certfile = NULL;
- unsigned char *key = NULL;
- int key_len = 0;
- unsigned char *cert = NULL;
- int cert_len = 0;
- char *ciphers = 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 */
- 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 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)
- 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)
- ssl3 = 1;
-#endif
-#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
- tls1 = 0;
-#endif
-#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
- tls1_1 = 0;
-#endif
-#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
- tls1_2 = 0;
-#endif
-#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
- tls1_3 = 0;
-#endif
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?");
- 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);
-
- for (idx = 2; idx < objc; idx++) {
- char *opt = Tcl_GetStringFromObj(objv[idx], NULL);
-
- if (opt[0] != '-')
- break;
-
- OPTSTR("-cadir", CAdir);
- OPTSTR("-cafile", CAfile);
- OPTSTR("-certfile", certfile);
- OPTSTR("-cipher", ciphers);
- OPTOBJ("-command", script);
- OPTSTR("-dhparams", DHparams);
- OPTSTR("-keyfile", keyfile);
- OPTSTR("-model", model);
- OPTOBJ("-password", password);
- OPTBOOL("-require", require);
- OPTBOOL("-request", request);
- OPTBOOL("-server", server);
-#ifndef OPENSSL_NO_TLSEXT
- OPTSTR("-servername", servername);
- 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");
-
- return TCL_ERROR;
- }
- if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
- if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
- if (verify == 0) verify = SSL_VERIFY_NONE;
-
- proto |= (ssl2 ? TLS_PROTO_SSL2 : 0);
- proto |= (ssl3 ? TLS_PROTO_SSL3 : 0);
- proto |= (tls1 ? TLS_PROTO_TLS1 : 0);
- proto |= (tls1_1 ? TLS_PROTO_TLS1_1 : 0);
- proto |= (tls1_2 ? TLS_PROTO_TLS1_2 : 0);
- proto |= (tls1_3 ? TLS_PROTO_TLS1_3 : 0);
-
- /* reset to NULL if blank string provided */
- 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 (CAfile && !*CAfile) CAfile = NULL;
- if (CAdir && !*CAdir) CAdir = NULL;
- if (DHparams && !*DHparams) DHparams = NULL;
-
- /* new SSL state */
- statePtr = (State *) ckalloc((unsigned) sizeof(State));
- memset(statePtr, 0, sizeof(State));
-
- statePtr->flags = flags;
- statePtr->interp = interp;
- statePtr->vflags = verify;
- statePtr->err = "";
-
- /* allocate script */
- if (script) {
- (void) Tcl_GetStringFromObj(script, &len);
- if (len) {
- statePtr->callback = script;
- Tcl_IncrRefCount(statePtr->callback);
- }
- }
-
- /* allocate password */
- if (password) {
- (void) Tcl_GetStringFromObj(password, &len);
- if (len) {
- statePtr->password = password;
- Tcl_IncrRefCount(statePtr->password);
- }
- }
-
- if (model != NULL) {
- int mode;
- /* Get the "model" context */
- chan = Tcl_GetChannel(interp, model, &mode);
- if (chan == (Tcl_Channel) NULL) {
- Tls_Free((char *) statePtr);
- 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);
- Tls_Free((char *) statePtr);
- 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) {
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
- }
-
- statePtr->ctx = ctx;
-
- /*
- * We need to make sure that the channel works in binary (for the
- * encryption not to get goofed up).
- * We only want to adjust the buffering in pre-v2 channels, where
- * each channel in the stack maintained its own buffers.
- */
- Tcl_DStringInit(&upperChannelTranslation);
- Tcl_DStringInit(&upperChannelBlocking);
- Tcl_DStringInit(&upperChannelEOFChar);
- Tcl_DStringInit(&upperChannelEncoding);
- Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar);
- Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding);
- Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation);
- Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking);
- Tcl_SetChannelOption(interp, chan, "-translation", "binary");
- Tcl_SetChannelOption(interp, chan, "-blocking", "true");
- dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan));
- statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan);
- dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self));
- if (statePtr->self == (Tcl_Channel) NULL) {
- /*
- * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
- */
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
-
- Tcl_SetChannelOption(interp, statePtr->self, "-translation", Tcl_DStringValue(&upperChannelTranslation));
- Tcl_SetChannelOption(interp, statePtr->self, "-encoding", Tcl_DStringValue(&upperChannelEncoding));
- Tcl_SetChannelOption(interp, statePtr->self, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar));
- Tcl_SetChannelOption(interp, statePtr->self, "-blocking", Tcl_DStringValue(&upperChannelBlocking));
-
- /*
- * SSL Initialization
- */
- statePtr->ssl = SSL_new(statePtr->ctx);
- if (!statePtr->ssl) {
- /* SSL library error */
- Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), (char *) NULL);
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
-
-#ifndef OPENSSL_NO_TLSEXT
- if (servername) {
- 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;
- }
- }
- if (alpn) {
- /* Convert a Tcl list into a protocol-list in wire-format */
- unsigned char *protos, *p;
- unsigned int protoslen = 0;
- int i, len, cnt;
- Tcl_Obj **list;
- if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
- /* Determine the memory required for the protocol-list */
- for (i = 0; i < cnt; i++) {
- Tcl_GetStringFromObj(list[i], &len);
- if (len > 255) {
- Tcl_AppendResult(interp, "alpn protocol name too long", (char *) NULL);
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
- protoslen += 1 + len;
- }
- /* Build the complete protocol-list */
- protos = ckalloc(protoslen);
- /* 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)) {
- 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);
- }
-#endif
-
- /*
- * SSL Callbacks
- */
- SSL_set_app_data(statePtr->ssl, (void *)statePtr); /* point back to us */
- SSL_set_verify(statePtr->ssl, verify, VerifyCallback);
- SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);
-
- /* Create Tcl_Channel BIO Handler */
- statePtr->p_bio = BIO_new_tcl(statePtr, BIO_NOCLOSE);
- statePtr->bio = BIO_new(BIO_f_ssl());
-
- if (server) {
- statePtr->flags |= TLS_TCL_SERVER;
- SSL_set_accept_state(statePtr->ssl);
- } else {
- 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);
-
- /*
- * End of SSL Init
- */
- dprintf("Returning %s", Tcl_GetChannelName(statePtr->self));
- Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), TCL_VOLATILE);
-
- return TCL_OK;
- clientData = clientData;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * UnimportObjCmd --
- *
- * This procedure is invoked to remove the topmost channel filter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * May modify the behavior of an IO channel.
- *
- *-------------------------------------------------------------------
- */
-static int
-UnimportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- Tcl_Channel chan; /* The channel to set a mode on. */
-
- dprintf("Called");
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "channel");
- return TCL_ERROR;
- }
-
- 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
- */
- 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;
- }
-
- if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) {
- return TCL_ERROR;
- }
-
- return TCL_OK;
- clientData = clientData;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * CTX_Init -- construct a SSL_CTX instance
- *
- * Results:
- * A valid SSL_CTX instance or NULL.
- *
- * Side effects:
- * constructs SSL context (CTX)
- *
- *-------------------------------------------------------------------
- */
-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) {
- Tcl_Interp *interp = statePtr->interp;
- SSL_CTX *ctx = NULL;
- Tcl_DString ds;
- Tcl_DString ds1;
- int off = 0;
- int load_private_key;
- const SSL_METHOD *method;
-
- dprintf("Called");
-
- if (!proto) {
- 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 (ENABLED(proto, TLS_PROTO_SSL2)) {
- Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
- if (ENABLED(proto, TLS_PROTO_SSL3)) {
- Tcl_AppendResult(interp, "SSL3 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
- if (ENABLED(proto, TLS_PROTO_TLS1)) {
- Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
- if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
- Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
- if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
- Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
- if (ENABLED(proto, TLS_PROTO_TLS1_3)) {
- Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-
- switch (proto) {
-#if OPENSSL_VERSION_NUMBER < 0x10101000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
- case TLS_PROTO_SSL2:
- method = SSLv2_method();
- break;
-#endif
-#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
- case TLS_PROTO_SSL3:
- method = SSLv3_method();
- break;
-#endif
-#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
- case TLS_PROTO_TLS1:
- method = TLSv1_method();
- break;
-#endif
-#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
- case TLS_PROTO_TLS1_1:
- method = TLSv1_1_method();
- break;
-#endif
-#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
- case TLS_PROTO_TLS1_2:
- method = TLSv1_2_method();
- break;
-#endif
-#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
- case TLS_PROTO_TLS1_3:
- /*
- * The version range is constrained below,
- * after the context is created. Use the
- * generic method here.
- */
- method = TLS_method();
- break;
-#endif
- default:
-#if OPENSSL_VERSION_NUMBER >= 0x10100000L
- /* Negotiate highest available SSL/TLS version */
- method = TLS_method();
-#else
- method = SSLv23_method();
-#endif
-#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
- off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2);
-#endif
-#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
- off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3);
-#endif
-#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
- off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1);
-#endif
-#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
- off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1);
-#endif
-#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
- off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2);
-#endif
-#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3)
- off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3);
-#endif
- break;
- }
-
- ctx = SSL_CTX_new(method);
-
- if (!ctx) {
- return(NULL);
- }
-
- if (getenv(SSLKEYLOGFILE)) {
- SSL_CTX_set_keylog_callback(ctx, KeyLogCallback);
- }
-
-#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
-
- 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 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);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
-#else
- {
- DH* dh;
- if (DHparams != NULL) {
- BIO *bio;
- Tcl_DStringInit(&ds);
- bio = BIO_new_file(F2N(DHparams, &ds), "r");
- if (!bio) {
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp, "Could not find DH parameters file", (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
-
- dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL);
- BIO_free(bio);
- Tcl_DStringFree(&ds);
- if (!dh) {
- Tcl_AppendResult(interp, "Could not read DH parameters from file", (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- } else {
- dh = get_dhParams();
- }
- SSL_CTX_set_tmp_dh(ctx, dh);
- DH_free(dh);
- }
-#endif
-
- /* set our certificate */
- load_private_key = 0;
- if (certfile != NULL) {
- load_private_key = 1;
-
- Tcl_DStringInit(&ds);
-
- if (SSL_CTX_use_certificate_file(ctx, F2N(certfile, &ds), SSL_FILETYPE_PEM) <= 0) {
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp, "unable to set certificate file ", certfile, ": ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- } else if (cert != NULL) {
- load_private_key = 1;
- if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) {
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp, "unable to set certificate: ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- } else {
- certfile = (char*)X509_get_default_cert_file();
-
- if (SSL_CTX_use_certificate_file(ctx, certfile, SSL_FILETYPE_PEM) <= 0) {
-#if 0
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp, "unable to use default certificate file ", certfile, ": ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
-#endif
- }
- }
-
- /* set our private key */
- if (load_private_key) {
- if (keyfile == NULL && key == NULL) {
- keyfile = certfile;
- }
-
- if (keyfile != NULL) {
- /* get the private key associated with this certificate */
- if (keyfile == NULL) {
- keyfile = certfile;
- }
-
- if (SSL_CTX_use_PrivateKey_file(ctx, F2N(keyfile, &ds), SSL_FILETYPE_PEM) <= 0) {
- Tcl_DStringFree(&ds);
- /* flush the passphrase which might be left in the result */
- Tcl_SetResult(interp, NULL, TCL_STATIC);
- Tcl_AppendResult(interp, "unable to set public key file ", keyfile, " ",
- REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- Tcl_DStringFree(&ds);
-
- } else if (key != NULL) {
- if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 0) {
- Tcl_DStringFree(&ds);
- /* flush the passphrase which might be left in the result */
- Tcl_SetResult(interp, NULL, TCL_STATIC);
- Tcl_AppendResult(interp, "unable to set public key: ", REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- }
- /* Now we know that a key and cert have been set against
- * the SSL context */
- if (!SSL_CTX_check_private_key(ctx)) {
- Tcl_AppendResult(interp, "private key does not match the certificate public key",
- (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
- }
- }
-
- /* Set verification CAs */
- Tcl_DStringInit(&ds);
- Tcl_DStringInit(&ds1);
- if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) ||
- !SSL_CTX_set_default_verify_paths(ctx)) {
-#if 0
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&ds1);
- /* Don't currently care if this fails */
- Tcl_AppendResult(interp, "SSL default verify paths: ", REASON(), (char *) NULL);
- SSL_CTX_free(ctx);
- return (SSL_CTX *)0;
-#endif
- }
-
- /* https://sourceforge.net/p/tls/bugs/57/ */
- /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */
- if (CAfile != NULL) {
- STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file(F2N(CAfile, &ds));
- if (certNames != NULL) {
- SSL_CTX_set_client_CA_list(ctx, certNames);
- }
- }
-
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&ds1);
- return ctx;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * StatusObjCmd -- return certificate for connected peer.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-static int
-StatusObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- State *statePtr;
- 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
-
- dprintf("Called");
-
- switch (objc) {
- case 2:
- channelName = Tcl_GetStringFromObj(objv[1], NULL);
- break;
-
- case 3:
- if (!strcmp (Tcl_GetString (objv[1]), "-local")) {
- channelName = Tcl_GetStringFromObj(objv[2], NULL);
- break;
- }
- /* else fall-through ... */
-#if defined(__GNUC__)
- __attribute__((fallthrough));
-#endif
- default:
- Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel");
- return TCL_ERROR;
- }
-
- chan = Tcl_GetChannel(interp, channelName, &mode);
- 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;
- }
- statePtr = (State *) Tcl_GetChannelInstanceData(chan);
- if (objc == 2) {
- peer = SSL_get_peer_certificate(statePtr->ssl);
- } else {
- peer = SSL_get_certificate(statePtr->ssl);
- }
- if (peer) {
- objPtr = Tls_NewX509Obj(interp, peer);
- if (objc == 2) { X509_free(peer); }
- } else {
- objPtr = Tcl_NewListObj(0, NULL);
- }
-
- 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
- /* 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;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * VersionObjCmd -- return version string from OpenSSL.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-static int
-VersionObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- Tcl_Obj *objPtr;
-
- dprintf("Called");
-
- objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1);
- Tcl_SetObjResult(interp, objPtr);
-
- return TCL_OK;
- clientData = clientData;
- objc = objc;
- objv = objv;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * MiscObjCmd -- misc commands
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-static int
-MiscObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- static const char *commands [] = { "req", "strreq", NULL };
- enum command { C_REQ, C_STRREQ, C_DUMMY };
- int cmd, isStr;
- char buffer[16384];
-
- dprintf("Called");
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,&cmd) != TCL_OK) {
- return TCL_ERROR;
- }
-
- isStr = (cmd == C_STRREQ);
- switch ((enum command) cmd) {
- case C_REQ:
- case C_STRREQ: {
- EVP_PKEY *pkey=NULL;
- X509 *cert=NULL;
- X509_NAME *name=NULL;
- Tcl_Obj **listv;
- int listc,i;
-
- BIO *out=NULL;
-
- 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
- BIGNUM *bne = NULL;
- RSA *rsa = NULL;
-#else
- EVP_PKEY_CTX *ctx = NULL;
-#endif
-
- if ((objc<5) || (objc>6)) {
- Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) {
- return TCL_ERROR;
- }
- keyout=Tcl_GetString(objv[3]);
- pemout=Tcl_GetString(objv[4]);
- if (isStr) {
- Tcl_SetVar(interp,keyout,"",0);
- Tcl_SetVar(interp,pemout,"",0);
- }
-
- if (objc>=6) {
- if (Tcl_ListObjGetElements(interp, objv[5],
- &listc, &listv) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if ((listc%2) != 0) {
- Tcl_SetResult(interp,"Information list must have even number of arguments",NULL);
- return TCL_ERROR;
- }
- for (i=0; i 0x10100000L && 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);
- X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, (const unsigned char *) k_ST, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, (const unsigned char *) k_L, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, (const unsigned char *) k_O, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, (const unsigned char *) k_OU, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, (const unsigned char *) k_CN, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, (const unsigned char *) k_Email, -1, -1, 0);
-
- 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
- BN_free(bne);
-#endif
- Tcl_SetResult(interp,"Error signing certificate",NULL);
- return TCL_ERROR;
- }
-
- if (isStr) {
- out=BIO_new(BIO_s_mem());
- PEM_write_bio_X509(out,cert);
- i=BIO_read(out,buffer,sizeof(buffer)-1);
- i=(i<0) ? 0 : i;
- buffer[i]='\0';
- Tcl_SetVar(interp,pemout,buffer,0);
- BIO_flush(out);
- BIO_free(out);
- } else {
- out=BIO_new(BIO_s_file());
- BIO_write_filename(out,pemout);
- PEM_write_bio_X509(out,cert);
- BIO_free_all(out);
- }
-
- X509_free(cert);
- EVP_PKEY_free(pkey);
-#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
- BN_free(bne);
-#endif
- }
- }
- break;
- default:
- break;
- }
- return TCL_OK;
- clientData = clientData;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_Free --
- *
- * This procedure cleans up when a SSL socket based channel
- * is closed and its reference count falls below 1
- *
- * Results:
- * none
- *
- * Side effects:
- * Frees all the state
- *
- *-------------------------------------------------------------------
- */
-void
-Tls_Free(char *blockPtr) {
- State *statePtr = (State *)blockPtr;
-
- dprintf("Called");
-
- Tls_Clean(statePtr);
- ckfree(blockPtr);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_Clean --
- *
- * This procedure cleans up when a SSL socket based channel
- * is closed and its reference count falls below 1. This should
- * be called synchronously by the CloseProc, not in the
- * EventuallyFree callback.
- *
- * Results:
- * none
- *
- * Side effects:
- * Frees all the state
- *
- *-------------------------------------------------------------------
- */
-void Tls_Clean(State *statePtr) {
- dprintf("Called");
-
- /*
- * we're assuming here that we're single-threaded
- */
- if (statePtr->timer != (Tcl_TimerToken) NULL) {
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = 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;
- }
- if (statePtr->ssl) {
- dprintf("SSL_free(%p)", statePtr->ssl);
- SSL_free(statePtr->ssl);
- statePtr->ssl = NULL;
- }
- if (statePtr->ctx) {
- SSL_CTX_free(statePtr->ctx);
- statePtr->ctx = NULL;
- }
- if (statePtr->callback) {
- Tcl_DecrRefCount(statePtr->callback);
- statePtr->callback = NULL;
- }
- if (statePtr->password) {
- Tcl_DecrRefCount(statePtr->password);
- statePtr->password = NULL;
- }
-
- dprintf("Returning");
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_Init --
- *
- * This is a package initialization procedure, which is called
- * by Tcl when this package is to be added to an interpreter.
- *
- * Results: Ssl configured and loaded
- *
- * Side effects:
- * create the ssl command, initialize ssl context
- *
- *-------------------------------------------------------------------
- */
-DLLEXPORT int Tls_Init(Tcl_Interp *interp) {
- const char tlsTclInitScript[] = {
-#include "tls.tcl.h"
- 0x00
- };
-
- dprintf("Called");
-
- /*
- * We only support Tcl 8.4 or newer
- */
- if (
-#ifdef USE_TCL_STUBS
- Tcl_InitStubs(interp, "8.4", 0)
-#else
- Tcl_PkgRequire(interp, "Tcl", "8.4-", 0)
-#endif
- == NULL) {
- return TCL_ERROR;
- }
-
- if (TlsLibInit(0) != TCL_OK) {
- 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::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);
-
- if (interp) {
- Tcl_Eval(interp, tlsTclInitScript);
- }
-
- return(Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION));
-}
-
-/*
- *------------------------------------------------------*
- *
- * Tls_SafeInit --
- *
- * ------------------------------------------------*
- * Standard procedure required by 'load'.
- * Initializes this extension for a safe interpreter.
- * ------------------------------------------------*
- *
- * Side effects:
- * As of 'Tls_Init'
- *
- * Result:
- * A standard Tcl error code.
- *
- *------------------------------------------------------*
- */
-DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp) {
- dprintf("Called");
- return(Tls_Init(interp));
-}
-
-/*
- *------------------------------------------------------*
- *
- * TlsLibInit --
- *
- * ------------------------------------------------*
- * Initializes SSL library once per application
- * ------------------------------------------------*
- *
- * Side effects:
- * initializes SSL library
- *
- * Result:
- * none
- *
- *------------------------------------------------------*
- */
-static int TlsLibInit(int uninitialize) {
- static int initialized = 0;
- int status = TCL_OK;
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- size_t num_locks;
-#endif
-
- if (uninitialize) {
- if (!initialized) {
- dprintf("Asked to uninitialize, but we are not initialized");
-
- return(TCL_OK);
- }
-
- 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;
- }
-#endif
- initialized = 0;
-
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- Tcl_MutexUnlock(&init_mx);
-#endif
-
- return(TCL_OK);
- }
-
- if (initialized) {
- dprintf("Called, but using cached value");
- return(status);
- }
-
- dprintf("Called");
-
-#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
- 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
- /* 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
- OPENSSL_init_crypto(OPENSSL_INIT_LOAD_CRYPTO_STRINGS, NULL);
-#endif
-
- BIO_new_tcl(NULL, 0);
-
-#if 0
- /*
- * XXX:TODO: Remove this code and replace it with a check
- * for enough entropy and do not try to create our own
- * terrible entropy
- */
- /*
- * Seed the random number generator in the SSL library,
- * using the do/while construct because of the bug note in the
- * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1
- *
- * The crux of the problem is that Solaris 7 does not have a
- * /dev/random or /dev/urandom device so it cannot gather enough
- * entropy from the RAND_seed() when TLS initializes and refuses
- * to go further. Earlier versions of OpenSSL carried on regardless.
- */
- srand((unsigned int) time((time_t *) NULL));
- do {
- for (i = 0; i < 16; i++) {
- rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0));
- }
- 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);
-}
DELETED tls.h
Index: tls.h
==================================================================
--- tls.h
+++ /dev/null
@@ -1,30 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Matt Newman
- *
- * TLS (aka SSL) Channel - can be layered on any bi-directional
- * Tcl_Channel (Note: Requires Trf Core Patch)
- *
- * This was built from scratch based upon observation of OpenSSL 0.9.2B
- *
- * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
- * providing the Tcl_ReplaceChannel mechanism and working closely with me
- * to enhance it to support full fileevent semantics.
- *
- * Also work done by the follow people provided the impetus to do this "right":-
- * tclSSL (Colin McCormack, Shared Technology)
- * SSLtcl (Peter Antman)
- *
- */
-
-#ifndef _TLS_H
-#define _TLS_H
-
-#include
-
-/*
- * Initialization routines -- our entire public C API.
- */
-DLLEXPORT int Tls_Init(Tcl_Interp *interp);
-DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp);
-
-#endif /* _TLS_H */
DELETED tls.htm
Index: tls.htm
==================================================================
--- tls.htm
+++ /dev/null
@@ -1,472 +0,0 @@
-
-
-
-
-
-
-
-TLS (SSL) Tcl Commands
-
-
-
-
-
- - NAME
- - tls - binding to OpenSSL
- 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::handshake channel
- - tls::status ?-local? channel
- - tls::import channel ?options?
- - tls::unimport channel
- - tls::ciphers protocol ?verbose?
- - tls::version
-
- - COMMANDS
- - CALLBACK OPTIONS
- - HTTPS EXAMPLE
- - SPECIAL CONSIDERATIONS
- - SEE ALSO
-
-
-
-
-
-
-tls - binding to OpenSSL
-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?
-tls::version
-
-
-
-
-This extension provides a generic binding to OpenSSL, utilizing the
-Tcl_StackChannel
-API for Tcl 8.4 and higher. The sockets behave exactly the same
-as channels created using Tcl's built-in socket
-command with additional options for controlling the SSL session.
-
-
-
-
-Typically one would use the tls::socket command
-which provides compatibility with the native Tcl socket
-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
- 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::socket ?options?
- host port
- - tls::socket ?-server command? ?options? port
- - This is a helper function that utilizes the underlying
- commands (tls::import). It behaves
- exactly the same as the native Tcl socket
- command except that the options can include any of the
- applicable tls:import
- options with one additional option:
-
-
- - -autoservername bool
- - Automatically send the -servername as the host argument
- (default: false)
-
-
- -
- - 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
- 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
- issuer.
- - subject dn
- - The distinguished name (DN) of the certificate
- subject.
- - notBefore date
- - The begin date for the validity of the certificate.
- - notAfter date
- - The expiry date for the certificate.
- - serial n
- - The serial number of the certificate.
- - cipher cipher
- - The current cipher in use between the client and
- server channels.
- - sbits n
- - The number of bits used for the session key.
- - certificate cert
- - The PEM encoded certificate.
- - sha1_hash hash
- - The SHA1 hash of the certificate.
- - sha256_hash hash
- - The SHA256 hash of the certificate.
- - 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
-
-
-
-
- - 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
- - 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)
-
-
-
-
- - 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::version
- - Returns the version string defined by OpenSSL.
-
-
-
-
-
-As indicated above, individual channels can be given their own callbacks
-to handle intermediate processing by the OpenSSL library, using the
--command and -password options passed to either of
-tls::socket or tls::import.
-
-
-
-
-
- - -command callback
- -
- Invokes the specified callback script at
- several points during the OpenSSL handshake.
- Except as indicated below, values returned from the
- callback are ignored.
- Arguments appended to the script upon callback take one of the
- following forms:
-
-
-
-
-
-
-
-
- -
- info channel major minor message
-
- -
- This form of callback is invoked by the OpenSSL function
-
SSL_CTX_set_info_callback().
-
- The major and minor arguments are used to
- represent the state information bitmask.
-
- - Possible values for major are:
- handshake, alert, connect, accept.- Possible values for minor are:
- start, done, read, write, loop, exit.
- The message argument is a descriptive string which may
- be generated either by
- SSL_state_string_long() or by
- SSL_alert_desc_string_long(),
- depending on context.
-
-
-
-
- -
- verify channel depth cert status error
-
- -
- This form of callback is invoked by the OpenSSL function
-
SSL_set_verify().
-
- The depth argument is an integer representing the
- current depth on the certificate chain, with
- 0 as the subject certificate and higher values
- denoting progressively more indirect issuer certificates.
-
- The cert argument is a list of key-value pairs similar
- to those returned by
- tls::status.
-
- The status argument is an integer representing the
- current validity of the certificate.
- A value of 0 means the certificate is deemed invalid.
- A value of 1 means the certificate is deemed valid.
-
- The error argument supplies the message, if any, generated
- by
- X509_STORE_CTX_get_error().
-
-
- The callback may override normal validation processing by explicitly
- returning one of the above status values.
-
-
-
-
-
-
-
- - -password callback
- -
- Invokes the specified callback script when OpenSSL needs to
- obtain a password. The callback should return a string which
- represents the password to be used.
- No arguments are appended to the script upon callback.
-
-
-
-
-
-Reference implementations of these callbacks are provided in the
-distribution as tls::callback and
-tls::password respectively. Note that these are
-sample implementations only. In a more realistic deployment
-you would specify your own callback scripts on each TLS channel
-using the -command and -password options.
-
-
-
-The default behavior when the -command option is not specified is for
-TLS to process the associated library callbacks internally.
-The default behavior when the -password option is not specified is for
-TLS to process the associated library callbacks by attempting to call
-tls::password.
-The difference between these two behaviors is a consequence of maintaining
-compatibility with earlier implementations.
-
-
-
-The tls::debug variable provides some additional
-control over these reference callbacks. Its value is zero by default.
-Higher values produce more diagnostic output, and will also force the
-verify method in tls::callback to accept the
-certificate, even when it is invalid.
-
-
-
-
-The use of the reference callbacks tls::callback and
-tls::password is not recommended. They may be removed
-from future releases.
-
-
-
-
-
-The use of the variable tls::debug is not recommended.
-It may be removed from future releases.
-
-
-
-
-
-TLS key logging can be enabled by setting the environment variable
-SSLKEYLOGFILE to the name of the file to log to. Then whenever TLS
-key material is generated or received it will be logged to the file.
-
-
-
-This example uses a sample server.pem provided with the TLS release,
-courtesy of the OpenSSL project.
-
-
-package require http
-package require tls
-
-http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
-
-set tok [http::geturl https://www.tcl.tk/]
-
-
-
-
-The capabilities of this package can vary enormously based
-upon how your OpenSSL library was configured and built. At the
-most macro-level OpenSSL supports a "no patents" build,
-which disables RSA, IDEA, RC(2,4,5) and SSL2 - if your OpenSSL is
-configured this way then you will need to build TLS with the
--DNO_PATENTS option - and the resultant module will function
-correctly and also support ADH certificate-less encryption,
-however you will be unable to utilize this to speak to normal Web
-Servers, which typically require RSA support. Please see http://www.openssl.org/ for
-more information on the whole issue of patents and US export
-restrictions.
-
-
-
-socket, fileevent, OpenSSL
-
-
-
-
-Copyright © 1999 Matt Newman.
-Copyright © 2004 Starfish Systems.
-
-
-
DELETED tls.tcl
Index: tls.tcl
==================================================================
--- tls.tcl
+++ /dev/null
@@ -1,399 +0,0 @@
-#
-# Copyright (C) 1997-2000 Matt Newman
-#
-namespace eval tls {
- variable logcmd tclLog
- variable debug 0
-
- # Default flags passed to tls::import
- variable defaults {}
-
- # Maps UID to Server Socket
- variable srvmap
- variable srvuid 0
-
- # Over-ride this if you are using a different socket command
- variable socketCmd
- if {![info exists socketCmd]} {
- set socketCmd [info command ::socket]
- }
-
- # This is the possible arguments to tls::socket and tls::init
- # The format of this is a list of lists
- ## Each inner list contains the following elements
- ### Server (matched against "string match" for 0/1)
- ### Option name
- ### Variable to add the option to:
- #### sopts: [socket] option
- #### iopts: [tls::import] option
- ### How many arguments the following the option to consume
- variable socketOptionRules {
- {0 -async sopts 0}
- {* -myaddr sopts 1}
- {0 -myport sopts 1}
- {* -type sopts 1}
- {* -cadir iopts 1}
- {* -cafile iopts 1}
- {* -cert iopts 1}
- {* -certfile iopts 1}
- {* -cipher iopts 1}
- {* -command iopts 1}
- {* -dhparams iopts 1}
- {* -key iopts 1}
- {* -keyfile iopts 1}
- {* -password iopts 1}
- {* -request iopts 1}
- {* -require iopts 1}
- {* -autoservername discardOpts 1}
- {* -servername iopts 1}
- {* -alpn iopts 1}
- {* -ssl2 iopts 1}
- {* -ssl3 iopts 1}
- {* -tls1 iopts 1}
- {* -tls1.1 iopts 1}
- {* -tls1.2 iopts 1}
- {* -tls1.3 iopts 1}
- }
-
- # tls::socket and tls::init options as a humane readable string
- variable socketOptionsNoServer
- variable socketOptionsServer
-
- # Internal [switch] body to validate options
- variable socketOptionsSwitchBody
-}
-
-proc tls::_initsocketoptions {} {
- variable socketOptionRules
- variable socketOptionsNoServer
- variable socketOptionsServer
- variable socketOptionsSwitchBody
-
- # Do not re-run if we have already been initialized
- if {[info exists socketOptionsSwitchBody]} {
- return
- }
-
- # Create several structures from our list of options
- ## 1. options: a text representation of the valid options for the current
- ## server type
- ## 2. argSwitchBody: Switch body for processing arguments
- set options(0) [list]
- set options(1) [list]
- set argSwitchBody [list]
- foreach optionRule $socketOptionRules {
- set ruleServer [lindex $optionRule 0]
- set ruleOption [lindex $optionRule 1]
- set ruleVarToUpdate [lindex $optionRule 2]
- set ruleVarArgsToConsume [lindex $optionRule 3]
-
- foreach server [list 0 1] {
- if {![string match $ruleServer $server]} {
- continue
- }
-
- lappend options($server) $ruleOption
- }
-
- switch -- $ruleVarArgsToConsume {
- 0 {
- set argToExecute {
- lappend @VAR@ $arg
- set argsArray($arg) true
- }
- }
- 1 {
- set argToExecute {
- incr idx
- if {$idx >= [llength $args]} {
- return -code error "\"$arg\" option must be followed by value"
- }
- set argValue [lindex $args $idx]
- lappend @VAR@ $arg $argValue
- set argsArray($arg) $argValue
- }
- }
- default {
- return -code error "Internal argument construction error"
- }
- }
-
- lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
- }
-
- # Add in the final options
- lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
- lappend argSwitchBody default break
-
- # Set the final variables
- set socketOptionsNoServer [join $options(0) {, }]
- set socketOptionsServer [join $options(1) {, }]
- set socketOptionsSwitchBody $argSwitchBody
-}
-
-proc tls::initlib {dir dll} {
- # Package index cd's into the package directory for loading.
- # Irrelevant to unixoids, but for Windows this enables the OS to find
- # the dependent DLL's in the CWD, where they may be.
- set cwd [pwd]
- catch {cd $dir}
- if {[string equal $::tcl_platform(platform) "windows"] &&
- ![string equal [lindex [file system $dir] 0] "native"]} {
- # If it is a wrapped executable running on windows, the openssl
- # dlls must be copied out of the virtual filesystem to the disk
- # where Windows will find them when resolving the dependency in
- # the tls dll. We choose to make them siblings of the executable.
- package require starkit
- set dst [file nativename [file dirname $starkit::topdir]]
- foreach sdll [glob -nocomplain -directory $dir -tails libssl32.dll libcrypto*.dll libssl*.dll libssp*.dll] {
- catch {file delete -force $dst/$sdll}
- catch {file copy -force $dir/$sdll $dst/$sdll}
- }
- }
- set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
- catch {cd $cwd}
- if {$res} {
- namespace eval [namespace parent] {namespace delete tls}
- return -code $res $err
- }
- rename tls::initlib {}
-}
-
-
-#
-# Backwards compatibility, also used to set the default
-# context options
-#
-proc tls::init {args} {
- variable defaults
- variable socketOptionsNoServer
- variable socketOptionsServer
- variable socketOptionsSwitchBody
-
- tls::_initsocketoptions
-
- # Technically a third option should be used here: Options that are valid
- # only a both servers and non-servers
- set server -1
- set options $socketOptionsServer
-
- # Validate arguments passed
- set initialArgs $args
- set argc [llength $args]
-
- array set argsArray [list]
- for {set idx 0} {$idx < $argc} {incr idx} {
- set arg [lindex $args $idx]
- switch -glob -- $server,$arg $socketOptionsSwitchBody
- }
-
- set defaults $initialArgs
-}
-#
-# Helper function - behaves exactly as the native socket command.
-#
-proc tls::socket {args} {
- variable socketCmd
- variable defaults
- variable socketOptionsNoServer
- variable socketOptionsServer
- variable socketOptionsSwitchBody
-
- tls::_initsocketoptions
-
- set idx [lsearch $args -server]
- if {$idx != -1} {
- set server 1
- set callback [lindex $args [expr {$idx+1}]]
- set args [lreplace $args $idx [expr {$idx+1}]]
-
- set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
- set options $socketOptionsServer
- } else {
- set server 0
-
- set usage "wrong # args: should be \"tls::socket ?options? host port\""
- set options $socketOptionsNoServer
- }
-
- # Combine defaults with current options
- set args [concat $defaults $args]
-
- set argc [llength $args]
- set sopts {}
- set iopts [list -server $server]
-
- array set argsArray [list]
- for {set idx 0} {$idx < $argc} {incr idx} {
- set arg [lindex $args $idx]
- switch -glob -- $server,$arg $socketOptionsSwitchBody
- }
-
- if {$server} {
- if {($idx + 1) != $argc} {
- return -code error $usage
- }
- set uid [incr ::tls::srvuid]
-
- set port [lindex $args [expr {$argc-1}]]
- lappend sopts $port
- #set sopts [linsert $sopts 0 -server $callback]
- set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
- #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
- } else {
- if {($idx + 2) != $argc} {
- return -code error $usage
- }
-
- set host [lindex $args [expr {$argc-2}]]
- set port [lindex $args [expr {$argc-1}]]
-
- # If an "-autoservername" option is found, honor it
- if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
- if {![info exists argsArray(-servername)]} {
- set argsArray(-servername) $host
- lappend iopts -servername $host
- }
- }
-
- lappend sopts $host $port
- }
- #
- # Create TCP/IP socket
- #
- set chan [eval $socketCmd $sopts]
- if {!$server && [catch {
- #
- # Push SSL layer onto socket
- #
- eval [list tls::import] $chan $iopts
- } err]} {
- set info ${::errorInfo}
- catch {close $chan}
- return -code error -errorinfo $info $err
- }
- return $chan
-}
-
-# tls::_accept --
-#
-# This is the actual accept that TLS sockets use, which then calls
-# the callback registered by tls::socket.
-#
-# Arguments:
-# iopts tls::import opts
-# callback server callback to invoke
-# chan socket channel to accept/deny
-# ipaddr calling IP address
-# port calling port
-#
-# Results:
-# Returns an error if the callback throws one.
-#
-proc tls::_accept { iopts callback chan ipaddr port } {
- log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]
-
- set chan [eval [list tls::import $chan] $iopts]
-
- lappend callback $chan $ipaddr $port
- if {[catch {
- uplevel #0 $callback
- } err]} {
- log 1 "tls::_accept error: ${::errorInfo}"
- close $chan
- error $err $::errorInfo $::errorCode
- } else {
- log 2 "tls::_accept - called \"$callback\" succeeded"
- }
-}
-#
-# Sample callback for hooking: -
-#
-# error
-# verify
-# info
-#
-proc tls::callback {option args} {
- variable debug
-
- #log 2 [concat $option $args]
-
- switch -- $option {
- "error" {
- foreach {chan msg} $args break
-
- log 0 "TLS/$chan: error: $msg"
- }
- "verify" {
- # poor man's lassign
- foreach {chan depth cert rc err} $args break
-
- array set c $cert
-
- if {$rc != "1"} {
- log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
- } else {
- log 2 "TLS/$chan: verify/$depth: $c(subject)"
- }
- if {$debug > 0} {
- return 1; # FORCE OK
- } else {
- return $rc
- }
- }
- "info" {
- # poor man's lassign
- foreach {chan major minor state msg} $args break
-
- if {$msg != ""} {
- append state ": $msg"
- }
- # For tracing
- upvar #0 tls::$chan cb
- set cb($major) $minor
-
- log 2 "TLS/$chan: $major/$minor: $state"
- }
- default {
- return -code error "bad option \"$option\":\
- must be one of error, info, or verify"
- }
- }
-}
-
-proc tls::xhandshake {chan} {
- upvar #0 tls::$chan cb
-
- if {[info exists cb(handshake)] && \
- $cb(handshake) == "done"} {
- return 1
- }
- while {1} {
- vwait tls::${chan}(handshake)
- if {![info exists cb(handshake)]} {
- return 0
- }
- if {$cb(handshake) == "done"} {
- return 1
- }
- }
-}
-
-proc tls::password {} {
- log 0 "TLS/Password: did you forget to set your passwd!"
- # Return the worlds best kept secret password.
- return "secret"
-}
-
-proc tls::log {level msg} {
- variable debug
- variable logcmd
-
- if {$level > $debug || $logcmd == ""} {
- return
- }
- set cmd $logcmd
- lappend cmd $msg
- uplevel #0 $cmd
-}
-
DELETED tlsBIO.c
Index: tlsBIO.c
==================================================================
--- tlsBIO.c
+++ /dev/null
@@ -1,341 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Matt Newman
- *
- * 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;
-
- chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
-
- dprintf("[chan=%p] BioWrite(%p, , %d)", (void *)chan, (void *) bio, bufLen);
-
- ret = Tcl_WriteRaw(chan, buf, bufLen);
-
- tclEofChan = Tcl_Eof(chan);
- tclErrno = Tcl_GetErrno();
-
- dprintf("[chan=%p] BioWrite(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno());
-
- BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY);
-
- if (tclEofChan && ret <= 0) {
- dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
- Tcl_SetErrno(ECONNRESET);
- ret = 0;
-
- } else if (ret == 0) {
- dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0");
- dprintf("Setting retry read flag");
- BIO_set_retry_read(bio);
-
- } else if (ret < 0) {
- 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);
- }
-
- } else {
- dprintf("Successfully wrote some data");
- }
-
- if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
- if (BIO_should_read(bio)) {
- dprintf("Setting should retry read flag");
-
- BIO_set_retry_read(bio);
- }
- }
- return(ret);
-}
-
-static int BioRead(BIO *bio, char *buf, int bufLen) {
- Tcl_Channel chan;
- int ret = 0;
- int tclEofChan, tclErrno;
-
- chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
-
- dprintf("[chan=%p] BioRead(%p, , %d)", (void *) chan, (void *) bio, bufLen);
-
- if (buf == NULL) {
- return 0;
- }
-
- ret = Tcl_ReadRaw(chan, buf, bufLen);
-
- tclEofChan = Tcl_Eof(chan);
- tclErrno = Tcl_GetErrno();
-
- dprintf("[chan=%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, tclErrno);
-
- BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY);
-
- if (tclEofChan && ret <= 0) {
- dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF");
- Tcl_SetErrno(ECONNRESET);
- ret = 0;
-
- } else if (ret == 0) {
- dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0");
- dprintf("Setting retry read flag");
- BIO_set_retry_read(bio);
-
- } else if (ret < 0) {
- 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);
- }
-
- } else {
- dprintf("Successfully read some data");
- }
-
- if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) {
- if (BIO_should_write(bio)) {
- dprintf("Setting should retry write flag");
-
- BIO_set_retry_write(bio);
- }
- }
-
- dprintf("BioRead(%p, , %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret);
-
- return(ret);
-}
-
-static int BioPuts(BIO *bio, const char *str) {
- dprintf("BioPuts(%p, ) called", bio, str);
-
- return BioWrite(bio, str, (int) strlen(str));
-}
-
-static long BioCtrl(BIO *bio, int cmd, long num, void *ptr) {
- Tcl_Channel chan;
- long ret = 1;
-
- chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
-
- dprintf("BioCtrl(%p, 0x%x, 0x%lx, %p)", (void *) bio, cmd, num, ptr);
-
- switch (cmd) {
- case BIO_CTRL_RESET:
- dprintf("Got BIO_CTRL_RESET");
- num = 0;
- ret = 0;
- break;
- case BIO_C_FILE_SEEK:
- dprintf("Got BIO_C_FILE_SEEK");
- ret = 0;
- break;
- case BIO_C_FILE_TELL:
- dprintf("Got BIO_C_FILE_TELL");
- ret = 0;
- break;
- case BIO_CTRL_INFO:
- dprintf("Got BIO_CTRL_INFO");
- ret = 1;
- break;
- case BIO_C_SET_FD:
- dprintf("Unsupported call: BIO_C_SET_FD");
- ret = -1;
- break;
- case BIO_C_GET_FD:
- dprintf("Unsupported call: BIO_C_GET_FD");
- ret = -1;
- break;
- case BIO_CTRL_GET_CLOSE:
- dprintf("Got BIO_CTRL_CLOSE");
- ret = BIO_get_shutdown(bio);
- break;
- case BIO_CTRL_SET_CLOSE:
- dprintf("Got BIO_SET_CLOSE");
- BIO_set_shutdown(bio, num);
- break;
- case BIO_CTRL_EOF:
- dprintf("Got BIO_CTRL_EOF");
- ret = ((chan) ? Tcl_Eof(chan) : 1);
- break;
- case BIO_CTRL_PENDING:
- dprintf("Got BIO_CTRL_PENDING");
- ret = ((chan) ? ((Tcl_InputBuffered(chan) ? 1 : 0)) : 0);
- dprintf("BIO_CTRL_PENDING(%d)", (int) ret);
- break;
- case BIO_CTRL_WPENDING:
- dprintf("Got BIO_CTRL_WPENDING");
- ret = 0;
- break;
- case BIO_CTRL_DUP:
- dprintf("Got BIO_CTRL_DUP");
- break;
- case BIO_CTRL_FLUSH:
- dprintf("Got BIO_CTRL_FLUSH");
- ret = ((chan) && (Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
- dprintf("BIO_CTRL_FLUSH returning value %li", ret);
- break;
- case BIO_CTRL_PUSH:
- dprintf("Got BIO_CTRL_PUSH");
- ret = 0;
- break;
- case BIO_CTRL_POP:
- dprintf("Got BIO_CTRL_POP");
- ret = 0;
- break;
- case BIO_CTRL_SET:
- dprintf("Got BIO_CTRL_SET");
- ret = 0;
- break;
- case BIO_CTRL_GET :
- dprintf("Got BIO_CTRL_GET ");
- ret = 0;
- break;
-#ifdef BIO_CTRL_GET_KTLS_SEND
- case BIO_CTRL_GET_KTLS_SEND:
- dprintf("Got BIO_CTRL_GET_KTLS_SEND");
- ret = 0;
- break;
-#endif
-#ifdef BIO_CTRL_GET_KTLS_RECV
- case BIO_CTRL_GET_KTLS_RECV:
- dprintf("Got BIO_CTRL_GET_KTLS_RECV");
- ret = 0;
- break;
-#endif
- default:
- dprintf("Got unknown control command (%i)", cmd);
- ret = 0;
- break;
- }
- return(ret);
-}
-
-static int BioNew(BIO *bio) {
- dprintf("BioNew(%p) called", bio);
-
- BIO_set_init(bio, 0);
- BIO_set_data(bio, NULL);
- BIO_clear_flags(bio, -1);
- return(1);
-}
-
-static int BioFree(BIO *bio) {
- if (bio == NULL) {
- return(0);
- }
-
- dprintf("BioFree(%p) called", bio);
-
- if (BIO_get_shutdown(bio)) {
- if (BIO_get_init(bio)) {
- /*shutdown(bio->num, 2) */
- /*closesocket(bio->num) */
- }
-
- BIO_set_init(bio, 0);
- BIO_clear_flags(bio, -1);
- }
- return(1);
-}
-
-BIO *BIO_new_tcl(State *statePtr, int flags) {
- BIO *bio;
- static BIO_METHOD *BioMethods = NULL;
-#ifdef TCLTLS_SSL_USE_FASTPATH
- Tcl_Channel parentChannel;
- const Tcl_ChannelType *parentChannelType;
- void *parentChannelFdIn_p, *parentChannelFdOut_p;
- int parentChannelFdIn, parentChannelFdOut, parentChannelFd;
- int validParentChannelFd;
- int tclGetChannelHandleRet;
-#endif
-
- dprintf("BIO_new_tcl() called");
-
- if (BioMethods == NULL) {
- BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl");
- BIO_meth_set_write(BioMethods, BioWrite);
- BIO_meth_set_read(BioMethods, BioRead);
- BIO_meth_set_puts(BioMethods, BioPuts);
- BIO_meth_set_ctrl(BioMethods, BioCtrl);
- BIO_meth_set_create(BioMethods, BioNew);
- BIO_meth_set_destroy(BioMethods, BioFree);
- }
-
- if (statePtr == NULL) {
- dprintf("Asked to setup a NULL state, just creating the initial configuration");
-
- return(NULL);
- }
-
-#ifdef TCLTLS_SSL_USE_FASTPATH
- /*
- * If the channel can be mapped back to a file descriptor, just use the file descriptor
- * with the SSL library since it will likely be optimized for this.
- */
- parentChannel = Tls_GetParent(statePtr, 0);
- parentChannelType = Tcl_GetChannelType(parentChannel);
-
- validParentChannelFd = 0;
- if (strcmp(parentChannelType->typeName, "tcp") == 0) {
- tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, (ClientData) &parentChannelFdIn_p);
- if (tclGetChannelHandleRet == TCL_OK) {
- tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, (ClientData) &parentChannelFdOut_p);
- if (tclGetChannelHandleRet == TCL_OK) {
- parentChannelFdIn = PTR2INT(parentChannelFdIn_p);
- parentChannelFdOut = PTR2INT(parentChannelFdOut_p);
- if (parentChannelFdIn == parentChannelFdOut) {
- parentChannelFd = parentChannelFdIn;
- validParentChannelFd = 1;
- }
- }
- }
- }
-
- if (validParentChannelFd) {
- dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn);
- bio = BIO_new_socket(parentChannelFd, flags);
- statePtr->flags |= TLS_TCL_FASTPATH;
- return(bio);
- }
-
- dprintf("Falling back to Tcl I/O for this channel");
-#endif
-
- bio = BIO_new(BioMethods);
- BIO_set_data(bio, statePtr);
- BIO_set_shutdown(bio, flags);
- BIO_set_init(bio, 1);
- return(bio);
-}
DELETED tlsIO.c
Index: tlsIO.c
==================================================================
--- tlsIO.c
+++ /dev/null
@@ -1,990 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Matt Newman
- * Copyright (C) 2000 Ajuba Solutions
- *
- * TLS (aka SSL) Channel - can be layered on any bi-directional
- * Tcl_Channel (Note: Requires Trf Core Patch)
- *
- * This was built from scratch based upon observation of OpenSSL 0.9.2B
- *
- * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
- * providing the Tcl_ReplaceChannel mechanism and working closely with me
- * to enhance it to support full fileevent semantics.
- *
- * Also work done by the follow people provided the impetus to do this "right":
- * tclSSL (Colin McCormack, Shared Technology)
- * SSLtcl (Peter Antman)
- *
- */
-
-#include "tlsInt.h"
-
-/*
- * Forward declarations
- */
-static void TlsChannelHandlerTimer(ClientData clientData);
-
-/*
- * TLS Channel Type
- */
-static Tcl_ChannelType *tlsChannelType = NULL;
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsBlockModeProc --
- *
- * This procedure is invoked by the generic IO level
- * to set blocking and nonblocking modes
- * Results:
- * 0 if successful, errno when failed.
- *
- * Side effects:
- * Sets the device into blocking or nonblocking mode.
- *
- *-------------------------------------------------------------------
- */
-static int TlsBlockModeProc(ClientData instanceData, int mode) {
- State *statePtr = (State *) instanceData;
-
- if (mode == TCL_MODE_NONBLOCKING) {
- statePtr->flags |= TLS_TCL_ASYNC;
- } else {
- statePtr->flags &= ~(TLS_TCL_ASYNC);
- }
- return(0);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsCloseProc --
- *
- * This procedure is invoked by the generic IO level to perform
- * channel-type-specific cleanup when a SSL socket based channel
- * is closed.
- *
- * Note: we leave the underlying socket alone, is this right?
- *
- * Results:
- * 0 if successful, the value of Tcl_GetErrno() if failed.
- *
- * Side effects:
- * Closes the socket of the channel.
- *
- *-------------------------------------------------------------------
- */
-static int TlsCloseProc(ClientData instanceData, Tcl_Interp *interp) {
- State *statePtr = (State *) instanceData;
-
- dprintf("TlsCloseProc(%p)", (void *) statePtr);
-
- Tls_Clean(statePtr);
- Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
- return(0);
-
- /* Interp is unused. */
- interp = interp;
-}
-
-static int TlsCloseProc2(ClientData instanceData, Tcl_Interp *interp, int flags) {
- if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
- return TlsCloseProc(instanceData, interp);
- }
- return EINVAL;
-}
-
-/*
- *------------------------------------------------------*
- *
- * Tls_WaitForConnect --
- *
- * Sideeffects:
- * Issues SSL_accept or SSL_connect
- *
- * Result:
- * None.
- *
- *------------------------------------------------------*
- */
-int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) {
- unsigned long backingError;
- int err, rc;
- int bioShouldRetry;
-
- dprintf("WaitForConnect(%p)", (void *) statePtr);
- dprintFlags(statePtr);
-
- if (!(statePtr->flags & TLS_TCL_INIT)) {
- dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success");
- *errorCodePtr = 0;
- return(0);
- }
-
- if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
- /*
- * Different types of operations have different requirements
- * SSL being established
- */
- if (handshakeFailureIsPermanent) {
- dprintf("Asked to wait for a TLS handshake that has already failed. Returning fatal error");
- *errorCodePtr = ECONNABORTED;
- } else {
- dprintf("Asked to wait for a TLS handshake that has already failed. Returning soft error");
- *errorCodePtr = ECONNRESET;
- }
- return(-1);
- }
-
- for (;;) {
- /* Not initialized yet! */
- if (statePtr->flags & TLS_TCL_SERVER) {
- dprintf("Calling SSL_accept()");
- err = SSL_accept(statePtr->ssl);
-
- } else {
- dprintf("Calling SSL_connect()");
- err = SSL_connect(statePtr->ssl);
- }
-
- if (err > 0) {
- dprintf("That seems to have gone okay");
-
- err = BIO_flush(statePtr->bio);
- if (err <= 0) {
- dprintf("Flushing the lower layers failed, this will probably terminate this session");
- }
- }
-
- rc = SSL_get_error(statePtr->ssl, err);
-
- dprintf("Got error: %i (rc = %i)", err, rc);
-
- 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;
- } else if (BIO_should_retry(statePtr->bio)) {
- bioShouldRetry = 1;
- } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) {
- bioShouldRetry = 1;
- }
- } else {
- if (!SSL_is_init_finished(statePtr->ssl)) {
- bioShouldRetry = 1;
- }
- }
-
- if (bioShouldRetry) {
- dprintf("The I/O did not complete -- but we should try it again");
-
- if (statePtr->flags & TLS_TCL_ASYNC) {
- dprintf("Returning EAGAIN so that it can be retried later");
-
- *errorCodePtr = EAGAIN;
- return(-1);
- } else {
- dprintf("Doing so now");
-
- continue;
- }
- }
-
- dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though");
- break;
- }
-
- *errorCodePtr = EINVAL;
-
- switch (rc) {
- case SSL_ERROR_NONE:
- /* The connection is up, we are done here */
- dprintf("The connection is up");
- break;
- case SSL_ERROR_ZERO_RETURN:
- dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...")
- return(-1);
- case SSL_ERROR_SYSCALL:
- backingError = ERR_get_error();
-
- if (backingError == 0 && err == 0) {
- dprintf("EOF reached")
- *errorCodePtr = ECONNRESET;
- } else if (backingError == 0 && err == -1) {
- dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- if (*errorCodePtr == ECONNRESET) {
- *errorCodePtr = ECONNABORTED;
- }
- } else {
- dprintf("I/O error occurred (backingError = %lu)", backingError);
- *errorCodePtr = backingError;
- if (*errorCodePtr == ECONNRESET) {
- *errorCodePtr = ECONNABORTED;
- }
- }
-
- statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
- return(-1);
-
- case SSL_ERROR_SSL:
- dprintf("Got permanent fatal SSL error, aborting immediately");
- Tls_Error(statePtr, (char *)ERR_reason_error_string(ERR_get_error()));
- statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
- *errorCodePtr = ECONNABORTED;
- return(-1);
-
- case SSL_ERROR_WANT_CONNECT:
- case SSL_ERROR_WANT_ACCEPT:
- case SSL_ERROR_WANT_X509_LOOKUP:
- default:
- dprintf("We got a confusing reply: %i", rc);
- *errorCodePtr = Tcl_GetErrno();
- dprintf("ERR(%d, %d) ", rc, *errorCodePtr);
- return(-1);
- }
-
-#if 0
- if (statePtr->flags & TLS_TCL_SERVER) {
- dprintf("This is an TLS server, checking the certificate for the peer");
-
- err = SSL_get_verify_result(statePtr->ssl);
- if (err != X509_V_OK) {
- dprintf("Invalid certificate, returning in failure");
-
- Tls_Error(statePtr, (char *)X509_verify_cert_error_string(err));
- statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
- *errorCodePtr = ECONNABORTED;
- return(-1);
- }
- }
-#endif
-
- dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake");
- statePtr->flags &= ~TLS_TCL_INIT;
-
- dprintf("Returning in success");
- *errorCodePtr = 0;
- return(0);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsInputProc --
- *
- * This procedure is invoked by the generic IO level
- * to read input from a SSL socket based channel.
- *
- * Results:
- * The number of bytes read is returned or -1 on error. An output
- * argument contains the POSIX error code on error, or zero if no
- * error occurred.
- *
- * Side effects:
- * Reads input from the input device of the channel.
- *
- *-------------------------------------------------------------------
- */
-static int TlsInputProc(ClientData instanceData, char *buf, int bufSize, int *errorCodePtr) {
- unsigned long backingError;
- State *statePtr = (State *) instanceData;
- int bytesRead;
- int tlsConnect;
- int err;
-
- *errorCodePtr = 0;
-
- dprintf("BIO_read(%d)", bufSize);
-
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- /* don't process any bytes while verify callback is running */
- dprintf("Callback is running, reading 0 bytes");
- return(0);
- }
-
- dprintf("Calling Tls_WaitForConnect");
- tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 0);
- if (tlsConnect < 0) {
- dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
-
- bytesRead = -1;
- if (*errorCodePtr == ECONNRESET) {
- dprintf("Got connection reset");
- /* Soft EOF */
- *errorCodePtr = 0;
- bytesRead = 0;
- }
- return(bytesRead);
- }
-
- /*
- * We need to clear the SSL error stack now because we sometimes reach
- * this function with leftover errors in the stack. If BIO_read
- * returns -1 and intends EAGAIN, there is a leftover error, it will be
- * misconstrued as an error, not EAGAIN.
- *
- * Alternatively, we may want to handle the <0 return codes from
- * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO
- * functions play with the retry flags though, and this seems to work
- * correctly. Similar fix in TlsOutputProc. - hobbs
- */
- ERR_clear_error();
- bytesRead = BIO_read(statePtr->bio, buf, bufSize);
- dprintf("BIO_read -> %d", bytesRead);
-
- err = SSL_get_error(statePtr->ssl, bytesRead);
-
-#if 0
- if (bytesRead <= 0) {
- if (BIO_should_retry(statePtr->bio)) {
- dprintf("I/O failed, will retry based on EAGAIN");
- *errorCodePtr = EAGAIN;
- }
- }
-#endif
-
- switch (err) {
- case SSL_ERROR_NONE:
- dprintBuffer(buf, bytesRead);
- break;
-
- case SSL_ERROR_SSL:
- dprintf("SSL negotiation error, indicating that the connection has been aborted");
-
- Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, bytesRead));
- *errorCodePtr = ECONNABORTED;
- bytesRead = -1;
- break;
-
- case SSL_ERROR_SYSCALL:
- backingError = ERR_get_error();
-
- if (backingError == 0 && bytesRead == 0) {
- dprintf("EOF reached")
- *errorCodePtr = 0;
- bytesRead = 0;
- } else if (backingError == 0 && bytesRead == -1) {
- dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- bytesRead = -1;
- } else {
- dprintf("I/O error occurred (backingError = %lu)", backingError);
- *errorCodePtr = backingError;
- bytesRead = -1;
- }
- break;
-
- case SSL_ERROR_ZERO_RETURN:
- dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached");
- bytesRead = 0;
- *errorCodePtr = 0;
- break;
-
- case SSL_ERROR_WANT_READ:
- dprintf("Got SSL_ERROR_WANT_READ, mapping this to EAGAIN");
- bytesRead = -1;
- *errorCodePtr = EAGAIN;
- break;
-
- default:
- dprintf("Unknown error (err = %i), mapping to EOF", err);
- *errorCodePtr = 0;
- bytesRead = 0;
- break;
- }
-
- dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
- return(bytesRead);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsOutputProc --
- *
- * This procedure is invoked by the generic IO level
- * to write output to a SSL socket based channel.
- *
- * Results:
- * The number of bytes written is returned. An output argument is
- * set to a POSIX error code if an error occurred, or zero.
- *
- * Side effects:
- * Writes output on the output device of the channel.
- *
- *-------------------------------------------------------------------
- */
-static int TlsOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) {
- unsigned long backingError;
- State *statePtr = (State *) instanceData;
- int written, err;
- int tlsConnect;
-
- *errorCodePtr = 0;
-
- dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite);
- dprintBuffer(buf, toWrite);
-
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- dprintf("Don't process output while callbacks are running");
- written = -1;
- *errorCodePtr = EAGAIN;
- return(-1);
- }
-
- dprintf("Calling Tls_WaitForConnect");
- tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 1);
- if (tlsConnect < 0) {
- dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr);
-
- written = -1;
- if (*errorCodePtr == ECONNRESET) {
- dprintf("Got connection reset");
- /* Soft EOF */
- *errorCodePtr = 0;
- written = 0;
- }
- return(written);
- }
-
- if (toWrite == 0) {
- dprintf("zero-write");
- err = BIO_flush(statePtr->bio);
-
- if (err <= 0) {
- dprintf("Flushing failed");
-
- *errorCodePtr = EIO;
- written = 0;
- return(-1);
- }
-
- written = 0;
- *errorCodePtr = 0;
- return(0);
- }
-
- /*
- * We need to clear the SSL error stack now because we sometimes reach
- * this function with leftover errors in the stack. If BIO_write
- * returns -1 and intends EAGAIN, there is a leftover error, it will be
- * misconstrued as an error, not EAGAIN.
- *
- * Alternatively, we may want to handle the <0 return codes from
- * BIO_write specially (as advised in the RSA docs). TLS's lower level
- * BIO functions play with the retry flags though, and this seems to
- * work correctly. Similar fix in TlsInputProc. - hobbs
- */
- ERR_clear_error();
- written = BIO_write(statePtr->bio, buf, toWrite);
- dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written);
-
- err = SSL_get_error(statePtr->ssl, written);
- switch (err) {
- case SSL_ERROR_NONE:
- if (written < 0) {
- written = 0;
- }
- break;
-
- case SSL_ERROR_WANT_WRITE:
- dprintf("Got SSL_ERROR_WANT_WRITE, mapping it to EAGAIN");
- *errorCodePtr = EAGAIN;
- written = -1;
- break;
-
- case SSL_ERROR_WANT_READ:
- dprintf(" write R BLOCK");
- break;
-
- case SSL_ERROR_WANT_X509_LOOKUP:
- dprintf(" write X BLOCK");
- break;
-
- case SSL_ERROR_ZERO_RETURN:
- dprintf(" closed");
- written = 0;
- *errorCodePtr = 0;
- break;
-
- case SSL_ERROR_SYSCALL:
- backingError = ERR_get_error();
-
- if (backingError == 0 && written == 0) {
- dprintf("EOF reached")
- *errorCodePtr = 0;
- written = 0;
- } else if (backingError == 0 && written == -1) {
- dprintf("I/O error occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- written = -1;
- } else {
- dprintf("I/O error occurred (backingError = %lu)", backingError);
- *errorCodePtr = backingError;
- written = -1;
- }
- break;
-
- case SSL_ERROR_SSL:
- Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written));
- *errorCodePtr = ECONNABORTED;
- written = -1;
- break;
-
- default:
- dprintf(" unknown err: %d", err);
- break;
- }
-
- dprintf("Output(%d) -> %d", toWrite, written);
- return(written);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsSetOptionProc --
- *
- * Computes an option value for a SSL socket based channel, or a
- * list of all options and their values.
- *
- * Results:
- * A standard Tcl result. The value of the specified option or a
- * list of all options and their values is returned in the
- * supplied DString.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-static int
-TlsSetOptionProc(ClientData instanceData, /* Socket state. */
- Tcl_Interp *interp, /* For errors - can be NULL. */
- const char *optionName, /* Name of the option to set the value for, or
- * NULL to get all options and their values. */
- const char *optionValue) /* Value for option. */
-{
- State *statePtr = (State *) instanceData;
-
- Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
- Tcl_DriverSetOptionProc *setOptionProc;
-
- setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
- if (setOptionProc != NULL) {
- return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue);
- } else if (optionName == (char*) NULL) {
- /*
- * Request is query for all options, this is ok.
- */
- return TCL_OK;
- }
- /*
- * Request for a specific option has to fail, we don't have any.
- */
- return TCL_ERROR;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsGetOptionProc --
- *
- * Computes an option value for a SSL socket based channel, or a
- * list of all options and their values.
- *
- * Results:
- * A standard Tcl result. The value of the specified option or a
- * list of all options and their values is returned in the
- * supplied DString.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-static int
-TlsGetOptionProc(ClientData instanceData, /* Socket state. */
- Tcl_Interp *interp, /* For errors - can be NULL. */
- const char *optionName, /* Name of the option to retrieve the value for, or
- * NULL to get all options and their values. */
- Tcl_DString *dsPtr) /* Where to store the computed value initialized by caller. */
-{
- State *statePtr = (State *) instanceData;
-
- Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
- Tcl_DriverGetOptionProc *getOptionProc;
-
- getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
- if (getOptionProc != NULL) {
- return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr);
- } else if (optionName == (char*) NULL) {
- /*
- * Request is query for all options, this is ok.
- */
- return TCL_OK;
- }
- /*
- * Request for a specific option has to fail, we don't have any.
- */
- return TCL_ERROR;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsWatchProc --
- *
- * Initialize the notifier to watch Tcl_Files from this channel.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets up the notifier so that a future event on the channel
- * will be seen by Tcl.
- *
- *-------------------------------------------------------------------
- */
-static void
-TlsWatchProc(ClientData instanceData, /* The socket state. */
- int mask) /* Events of interest; an OR-ed combination of
- * TCL_READABLE, TCL_WRITABLE and TCL_EXCEPTION. */
-{
- Tcl_Channel downChan;
- State *statePtr = (State *) instanceData;
-
- dprintf("TlsWatchProc(0x%x)", mask);
-
- /* Pretend to be dead as long as the verify callback is running.
- * Otherwise that callback could be invoked recursively. */
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- dprintf("Callback is on-going, doing nothing");
- return;
- }
-
- dprintFlags(statePtr);
-
- downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
-
- if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
- dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here");
- dprintf("Unregistering interest in the lower channel");
-
- (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), 0);
- statePtr->watchMask = 0;
- return;
- }
-
- statePtr->watchMask = mask;
-
- /* No channel handlers any more. We will be notified automatically
- * about events on the channel below via a call to our
- * 'TransformNotifyProc'. But we have to pass the interest down now.
- * We are allowed to add additional 'interest' to the mask if we want
- * to. But this transformation has no such interest. It just passes
- * the request down, unchanged.
- */
- dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan);
- (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
-
- /*
- * Management of the internal timer.
- */
- if (statePtr->timer != (Tcl_TimerToken) NULL) {
- dprintf("A timer was found, deleting it");
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = (Tcl_TimerToken) NULL;
- }
-
- if ((mask & TCL_READABLE) &&
- ((Tcl_InputBuffered(statePtr->self) > 0) || (BIO_ctrl_pending(statePtr->bio) > 0))) {
- /*
- * There is interest in readable events and we actually have
- * data waiting, so generate a timer to flush that.
- */
- dprintf("Creating a new timer since data appears to be waiting");
- statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr);
- }
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsGetHandleProc --
- *
- * Called from Tcl_GetChannelFile to retrieve o/s file handler
- * from the SSL socket based channel.
- *
- * Results:
- * The appropriate Tcl_File or NULL if not present.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-static int TlsGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr) {
- State *statePtr = (State *) instanceData;
-
- return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr));
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsNotifyProc --
- *
- * Handler called by Tcl to inform us of activity
- * on the underlying channel.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May process the incoming event by itself.
- *
- *-------------------------------------------------------------------
- */
-static int TlsNotifyProc(ClientData instanceData, int mask) {
- State *statePtr = (State *) instanceData;
- int errorCode;
-
- /*
- * An event occurred in the underlying channel. This
- * transformation doesn't process such events thus returns the
- * incoming mask unchanged.
- */
- if (statePtr->timer != (Tcl_TimerToken) NULL) {
- /*
- * Delete an existing timer. It was not fired, yet we are
- * here, so the channel below generated such an event and we
- * don't have to. The renewal of the interest after the
- * execution of channel handlers will eventually cause us to
- * recreate the timer (in WatchProc).
- */
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = (Tcl_TimerToken) NULL;
- }
-
- if (statePtr->flags & TLS_TCL_CALLBACK) {
- dprintf("Returning 0 due to callback");
- return 0;
- }
-
- dprintf("Calling Tls_WaitForConnect");
- errorCode = 0;
- if (Tls_WaitForConnect(statePtr, &errorCode, 1) < 0) {
- if (errorCode == EAGAIN) {
- dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0");
-
- return 0;
- }
-
- dprintf("Tls_WaitForConnect returned an error");
- }
-
- dprintf("Returning %i", mask);
-
- return(mask);
-}
-
-#if 0
-/*
- *------------------------------------------------------*
- *
- * TlsChannelHandler --
- *
- * ------------------------------------------------*
- * Handler called by Tcl as a result of
- * Tcl_CreateChannelHandler - to inform us of activity
- * on the underlying channel.
- * ------------------------------------------------*
- *
- * Sideeffects:
- * May generate subsequent calls to
- * Tcl_NotifyChannel.
- *
- * Result:
- * None.
- *
- *------------------------------------------------------*
- */
-static void
-TlsChannelHandler (ClientData clientData, int mask) {
- State *statePtr = (State *) clientData;
-
- dprintf("HANDLER(0x%x)", mask);
- Tcl_Preserve((ClientData)statePtr);
-
- if (mask & TCL_READABLE) {
- BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ);
- } else {
- BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ);
- }
-
- if (mask & TCL_WRITABLE) {
- BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
- } else {
- BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
- }
-
- mask = 0;
- if (BIO_wpending(statePtr->bio)) {
- mask |= TCL_WRITABLE;
- }
- if (BIO_pending(statePtr->bio)) {
- mask |= TCL_READABLE;
- }
-
- /*
- * The following NotifyChannel calls seems to be important, but
- * we don't know why. It looks like if the mask is ever non-zero
- * that it will enter an infinite loop.
- *
- * Notify the upper channel of the current BIO state so the event
- * continues to propagate up the chain.
- *
- * stanton: It looks like this could result in an infinite loop if
- * the upper channel doesn't cause ChannelHandler to be removed
- * before Tcl_NotifyChannel calls channel handlers on the lower channel.
- */
- Tcl_NotifyChannel(statePtr->self, mask);
-
- if (statePtr->timer != (Tcl_TimerToken)NULL) {
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = (Tcl_TimerToken)NULL;
- }
- if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
- /*
- * Data is waiting, flush it out in short time
- */
- statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr);
- }
- Tcl_Release((ClientData)statePtr);
-}
-#endif
-
-/*
- *------------------------------------------------------*
- *
- * TlsChannelHandlerTimer --
- *
- * ------------------------------------------------*
- * Called by the notifier (-> timer) to flush out
- * information waiting in channel buffers.
- * ------------------------------------------------*
- *
- * Sideeffects:
- * As of 'TlsChannelHandler'.
- *
- * Result:
- * None.
- *
- *------------------------------------------------------*
- */
-static void TlsChannelHandlerTimer(ClientData clientData) {
- State *statePtr = (State *) clientData;
- int mask = 0;
-
- dprintf("Called");
-
- statePtr->timer = (Tcl_TimerToken) NULL;
-
- if (BIO_wpending(statePtr->bio)) {
- dprintf("[chan=%p] BIO writable", statePtr->self);
-
- mask |= TCL_WRITABLE;
- }
-
- if (BIO_pending(statePtr->bio)) {
- dprintf("[chan=%p] BIO readable", statePtr->self);
-
- mask |= TCL_READABLE;
- }
-
- dprintf("Notifying ourselves");
- Tcl_NotifyChannel(statePtr->self, mask);
-
- dprintf("Returning");
-
- return;
-}
-
-Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) {
- dprintf("Requested to get parent of channel %p", statePtr->self);
-
- if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) {
- dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL");
- return(NULL);
- }
- return(Tcl_GetStackedChannel(statePtr->self));
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_ChannelType --
- *
- * Return the correct TLS channel driver info
- *
- * Results:
- * The correct channel driver for the current version of Tcl.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------
- */
-Tcl_ChannelType *Tls_ChannelType(void) {
- unsigned int size;
-
- /*
- * Initialize the channel type if necessary
- */
- if (tlsChannelType == NULL) {
- /*
- * Allocate new channeltype structure
- */
- size = sizeof(Tcl_ChannelType); /* Base size */
-
- tlsChannelType = (Tcl_ChannelType *) ckalloc(size);
- memset((void *) tlsChannelType, 0, size);
-
- tlsChannelType->typeName = "tls";
-#ifdef TCL_CHANNEL_VERSION_5
- tlsChannelType->version = TCL_CHANNEL_VERSION_5;
- tlsChannelType->closeProc = TlsCloseProc;
- tlsChannelType->inputProc = TlsInputProc;
- tlsChannelType->outputProc = TlsOutputProc;
- tlsChannelType->seekProc = NULL;
- tlsChannelType->setOptionProc = TlsSetOptionProc;
- tlsChannelType->getOptionProc = TlsGetOptionProc;
- tlsChannelType->watchProc = TlsWatchProc;
- tlsChannelType->getHandleProc = TlsGetHandleProc;
- tlsChannelType->close2Proc = TlsCloseProc2;
- tlsChannelType->blockModeProc = TlsBlockModeProc;
- tlsChannelType->flushProc = NULL;
- tlsChannelType->handlerProc = TlsNotifyProc;
- tlsChannelType->wideSeekProc = NULL;
- tlsChannelType->threadActionProc = NULL;
- tlsChannelType->truncateProc = NULL;
-#else
- tlsChannelType->version = TCL_CHANNEL_VERSION_2;
- tlsChannelType->closeProc = TlsCloseProc;
- tlsChannelType->inputProc = TlsInputProc;
- tlsChannelType->outputProc = TlsOutputProc;
- tlsChannelType->seekProc = NULL;
- tlsChannelType->setOptionProc = TlsSetOptionProc;
- tlsChannelType->getOptionProc = TlsGetOptionProc;
- tlsChannelType->watchProc = TlsWatchProc;
- tlsChannelType->getHandleProc = TlsGetHandleProc;
- tlsChannelType->close2Proc = NULL;
- tlsChannelType->blockModeProc = TlsBlockModeProc;
- tlsChannelType->flushProc = NULL;
- tlsChannelType->handlerProc = TlsNotifyProc;
-#endif
- }
- return(tlsChannelType);
-}
DELETED tlsInt.h
Index: tlsInt.h
==================================================================
--- tlsInt.h
+++ /dev/null
@@ -1,178 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Matt Newman
- *
- * TLS (aka SSL) Channel - can be layered on any bi-directional
- * Tcl_Channel (Note: Requires Trf Core Patch)
- *
- * This was built from scratch based upon observation of OpenSSL 0.9.2B
- *
- * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
- * providing the Tcl_ReplaceChannel mechanism and working closely with me
- * to enhance it to support full fileevent semantics.
- *
- * Also work done by the follow people provided the impetus to do this "right":-
- * tclSSL (Colin McCormack, Shared Technology)
- * SSLtcl (Peter Antman)
- *
- */
-#ifndef _TLSINT_H
-#define _TLSINT_H
-
-#include "tls.h"
-#include
-#include
-#include
-
-#ifdef _WIN32
-#define WIN32_LEAN_AND_MEAN
-#include
-#include /* OpenSSL needs this on Windows */
-#endif
-
-/* 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 */
-#endif
-
-#ifdef TCLEXT_TCLTLS_DEBUG
-#include
-#define dprintf(...) { \
- char dprintfBuffer[8192], *dprintfBuffer_p; \
- dprintfBuffer_p = &dprintfBuffer[0]; \
- dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \
- dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \
- fprintf(stderr, "%s\n", dprintfBuffer); \
-}
-#define dprintBuffer(bufferName, bufferLength) { \
- int dprintBufferIdx; \
- unsigned char dprintBufferChar; \
- fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \
- for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \
- dprintBufferChar = bufferName[dprintBufferIdx]; \
- if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \
- fprintf(stderr, "'%c' ", dprintBufferChar); \
- } else { \
- fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \
- }; \
- }; \
- fprintf(stderr, "}\n"); \
-}
-#define dprintFlags(statePtr) { \
- char dprintfBuffer[8192], *dprintfBuffer_p; \
- dprintfBuffer_p = &dprintfBuffer[0]; \
- dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \
- if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \
- if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \
- if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \
- if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \
- if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \
- if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \
- if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \
- fprintf(stderr, "%s\n", dprintfBuffer); \
-}
-#else
-#define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); }
-#define dprintBuffer(bufferName, bufferLength) /**/
-#define dprintFlags(statePtr) /**/
-#endif
-
-#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err))))
-/*
- * OpenSSL BIO Routines
- */
-#define BIO_TYPE_TCL (19|0x0400)
-
-/*
- * Defines for State.flags
- */
-#define TLS_TCL_ASYNC (1<<0) /* non-blocking mode */
-#define TLS_TCL_SERVER (1<<1) /* Server-Side */
-#define TLS_TCL_INIT (1<<2) /* Initializing connection */
-#define TLS_TCL_DEBUG (1<<3) /* Show debug tracing */
-#define TLS_TCL_CALLBACK (1<<4) /* In a callback, prevent update
- * looping problem. [Bug 1652380] */
-#define TLS_TCL_HANDSHAKE_FAILED (1<<5) /* Set on handshake failures and once set, all
- * further I/O will result in ECONNABORTED errors. */
-#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */
-#define TLS_TCL_DELAY (5)
-
-/*
- * This structure describes the per-instance state of an SSL channel.
- *
- * The SSL processing context is maintained here, in the ClientData
- */
-typedef struct State {
- Tcl_Channel self; /* this socket channel */
- Tcl_TimerToken timer;
-
- int flags; /* see State.flags above */
- int watchMask; /* current WatchProc mask */
- int mode; /* current mode of parent channel */
-
- Tcl_Interp *interp; /* interpreter in which this resides */
- Tcl_Obj *callback; /* script called for tracing, verifying and errors */
- Tcl_Obj *password; /* script called for certificate password */
-
- 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 *err;
-} State;
-
-#ifdef USE_TCL_STUBS
-#ifndef Tcl_StackChannel
-#error "Unable to compile on this version of Tcl"
-#endif /* Tcl_GetStackedChannel */
-#endif /* USE_TCL_STUBS */
-
-/*
- * Forward declarations
- */
-Tcl_ChannelType *Tls_ChannelType(void);
-Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags);
-
-Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert);
-void Tls_Error(State *statePtr, char *msg);
-void Tls_Free(char *blockPtr);
-void Tls_Clean(State *statePtr);
-int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent);
-
-BIO *BIO_new_tcl(State* statePtr, int flags);
-
-#define PTR2INT(x) ((int) ((intptr_t) (x)))
-
-#endif /* _TLSINT_H */
DELETED tlsX509.c
Index: tlsX509.c
==================================================================
--- tlsX509.c
+++ /dev/null
@@ -1,213 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Sensus Consulting Ltd.
- * Matt Newman
- */
-#include
-#include
-#include
-#include
-#include
-#include
-#include "tlsInt.h"
-
-/*
- * Ensure these are not macros - known to be defined on Win32
- */
-#ifdef min
-#undef min
-#endif
-
-#ifdef max
-#undef max
-#endif
-
-static int min(int a, int b)
-{
- return (a < b) ? a : b;
-}
-
-static int max(int a, int b)
-{
- return (a > b) ? a : b;
-}
-
-/*
- * ASN1_UTCTIME_tostr --
- */
-static char *
-ASN1_UTCTIME_tostr(ASN1_UTCTIME *tm)
-{
- static char bp[128];
- char *v;
- int gmt=0;
- static char *mon[12]={
- "Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"};
- int i;
- int y=0,M=0,d=0,h=0,m=0,s=0;
-
- i=tm->length;
- v=(char *)tm->data;
-
- if (i < 10) goto err;
- if (v[i-1] == 'Z') gmt=1;
- for (i=0; i<10; i++)
- if ((v[i] > '9') || (v[i] < '0')) goto err;
- y= (v[0]-'0')*10+(v[1]-'0');
- if (y < 70) y+=100;
- M= (v[2]-'0')*10+(v[3]-'0');
- if ((M > 12) || (M < 1)) goto err;
- d= (v[4]-'0')*10+(v[5]-'0');
- h= (v[6]-'0')*10+(v[7]-'0');
- m= (v[8]-'0')*10+(v[9]-'0');
- if ((v[10] >= '0') && (v[10] <= '9') && (v[11] >= '0') && (v[11] <= '9'))
- s= (v[10]-'0')*10+(v[11]-'0');
-
- sprintf(bp,"%s %2d %02d:%02d:%02d %d%s", mon[M-1],d,h,m,s,y+1900,(gmt)?" GMT":"");
- return bp;
- err:
- return "Bad time value";
-}
-
-/*
- *------------------------------------------------------*
- *
- * Tls_NewX509Obj --
- *
- * ------------------------------------------------*
- * Converts a X509 certificate into a Tcl_Obj
- * ------------------------------------------------*
- *
- * Sideeffects:
- * None
- *
- * Result:
- * A Tcl List Object representing the provided
- * X509 certificate.
- *
- *------------------------------------------------------*
- */
-
-#define CERT_STR_SIZE 16384
-
-Tcl_Obj*
-Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert) {
- Tcl_Obj *certPtr = Tcl_NewListObj(0, NULL);
- BIO *bio;
- int n;
- unsigned long flags;
- char subject[BUFSIZ];
- char issuer[BUFSIZ];
- 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";
-
- 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;
- serial[0] = 0;
- } else {
- flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT;
- flags &= ~ASN1_STRFLGS_ESC_MSB;
-
- X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags);
- n = BIO_read(bio, subject, min(BIO_pending(bio), BUFSIZ - 1));
- n = max(n, 0);
- subject[n] = 0;
- (void)BIO_flush(bio);
-
- X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags);
- n = BIO_read(bio, issuer, min(BIO_pending(bio), BUFSIZ - 1));
- n = max(n, 0);
- issuer[n] = 0;
- (void)BIO_flush(bio);
-
- i2a_ASN1_INTEGER(bio, X509_get_serialNumber(cert));
- n = BIO_read(bio, serial, min(BIO_pending(bio), BUFSIZ - 1));
- n = max(n, 0);
- serial[n] = 0;
- (void)BIO_flush(bio);
-
- if (PEM_write_bio_X509(bio, cert)) {
- certStr_p = certStr;
- certStr_len = 0;
- while (1) {
- toRead = min(BIO_pending(bio), CERT_STR_SIZE - certStr_len - 1);
- toRead = min(toRead, BUFSIZ);
- if (toRead == 0) {
- break;
- }
- dprintf("Reading %i bytes from the certificate...", toRead);
- n = BIO_read(bio, certStr_p, toRead);
- if (n <= 0) {
- break;
- }
- certStr_len += n;
- certStr_p += n;
- }
- *certStr_p = '\0';
- (void)BIO_flush(bio);
- }
-
- 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
-
-#ifndef NO_SSL_SHA
- /* SHA1 */
- 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) );
-
- /* SHA256 */
- 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) );
-
- return certPtr;
-}