2003-05-15  Dan Razzell	<research@starfishsystems.ca>

	* tls.tcl:
	* tlsInt.h:
	* tls.c: add support for binding a password callback to the socket.
	Now each socket can have its own command and password callbacks instead
	of being forced to have all password management pass through a common
	procedure.  The common password procedure is retained for compatibility
	but its use should be DEPRECATED.
	Add version command to return OpenSSL version string.
	Remove unstable workarounds needed for verify in obsolete versions of
	OpenSSL.
	Fix memory leak. [Request #640660]
	More casts to eliminate compiler warnings.

	* tls.htm: document password callback.
	Correct technical and typographic errors.

	* README.txt: identify versions of OpenSSL which fix known problems.
	General warning of security problems in older versions of OpenSSL.

2002-02-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* tls.htm:
	* tls.c: added support for local certificate status check, as well
	as returning the # of bits in the session key. [Patch #505698] (rose)

	* tls.c:

Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
TLS 1.4.1 Copyright (C) 2000 Ajuba Solutions

$Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/README.txt,v 1.4 2003/05/15 20:44:46 razzell Exp $

TLS (aka SSL) Channel - can be layered on any bi-directional Tcl_Channel.

Both client and server-side sockets are possible, and this code should work
on any platform as it uses a generic mechanism for layering on SSL and Tcl.

The TLS 1.4 release requires Tcl 8.2.0+, with 8.3.2+ preferred.  The
stacked channel implementation in Tcl was originally introduced in 8.2.0
(previously the Trf patch) and rewritten for 8.3.2+ due to inherent
limitations in the earlier implementation.  TLS 1.4 should compile with
any stubs-capable Tcl interpreter, but will require 8.2+ when loaded.
There are known limitations in the 8.2.0-8.3.1 stacked channel
implementation, so it is encouraged that people use TLS 1.4+ with an
8.3.2+ Tcl interpreter.  These modifications are by Jeff Hobbs
<jeff@hobbs.org>.

Full filevent sematics should also be intact - see tests directory for
blocking and non-blocking examples.

This was built (almost) from scratch based upon observation of OpenSSL 0.9.2b.
For correct functioning, use OpenSSL 0.9.6g or later.  This release contains
important fixes to memory management, as well as incorporating the verify
callback correction which appeared in OpenSSL 0.9.6c.  For best security, use
the latest official release of OpenSSL.

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)

/*
 * Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com>
 * some modifications:
 *	Copyright (C) 2000 Ajuba Solutions
 *	Copyright (C) 2002 ActiveState Corporation
 *	Copyright (C) 2003 Starfish Systems
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.15 2003/05/15 20:44:46 razzell Exp $
 *
 * 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
 *

			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	ImportObjCmd _ANSI_ARGS_ ((ClientData clientData,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	StatusObjCmd _ANSI_ARGS_ ((ClientData clientData,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	VersionObjCmd _ANSI_ARGS_ ((ClientData clientData,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static SSL_CTX *CTX_Init _ANSI_ARGS_((State *statePtr, int proto, char *key,
			char *cert, char *CAdir, char *CAfile, char *ciphers));

#define TLS_PROTO_SSL2	0x01
#define TLS_PROTO_SSL3	0x02
#define TLS_PROTO_TLS1	0x04
#define ENABLED(flag, mask)	(((flag) & (mask)) == (mask))

	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) {
	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) );
    }

}

/*
 *-------------------------------------------------------------------
 *
 * 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;
}
#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 result;

    if (statePtr->password == NULL) {
	if (Tcl_Eval(interp, "tls::password") == TCL_OK) {
	    char *ret = (char *) Tcl_GetStringResult(interp);
            strncpy(buf, ret, size);
	    return strlen(ret);
	} else {
	    return -1;
	}
    }

    cmdPtr = Tcl_DuplicateObj(statePtr->password);

    Tcl_Preserve((ClientData) statePtr->interp);
    Tcl_Preserve((ClientData) statePtr);

    Tcl_IncrRefCount(cmdPtr);
    result = Tcl_GlobalEvalObj(interp, cmdPtr);
    if (result != TCL_OK) {
	Tcl_BackgroundError(statePtr->interp);
    }
    Tcl_DecrRefCount(cmdPtr);

    Tcl_Release((ClientData) statePtr);
    Tcl_Release((ClientData) statePtr->interp);

    if (result == TCL_OK) {
	char *ret = (char *) Tcl_GetStringResult(interp);
        strncpy(buf, ret, size);
	return strlen(ret);
    } else {
	return -1;
    }
}
#endif

    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;
    int idx;
    int flags		= TLS_TCL_INIT;
    int server		= 0;	/* is connection incoming or outgoing? */
    char *key		= NULL;
    char *cert		= NULL;
    char *ciphers	= NULL;
    char *CAfile	= NULL;

    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", cert);
	OPTSTR( "-cipher", ciphers);
	OPTOBJ( "-command", script);
	OPTSTR( "-keyfile", key);
	OPTSTR( "-model", model);
	OPTOBJ( "-password", password);
	OPTBOOL( "-require", require);
	OPTBOOL( "-request", request);
	OPTBOOL( "-server", server);

	OPTBOOL( "-ssl2", ssl2);
	OPTBOOL( "-ssl3", ssl3);
	OPTBOOL( "-tls1", tls1);

	OPTBAD( "option", "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -model, -password, -require, -request, -server, -ssl2, -ssl3, or -tls1");

	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);

    /* reset to NULL if blank string provided */
    if (cert && !*cert)		cert	= NULL;
    if (key && !*key)		key	= NULL;
    if (ciphers && !*ciphers)	ciphers	= NULL;
    if (CAfile && !*CAfile)	CAfile	= NULL;
    if (CAdir && !*CAdir)	CAdir	= NULL;




























    /* new SSL state */
    statePtr		= (State *) Tcl_Alloc((unsigned) sizeof(State));
    statePtr->self	= (Tcl_Channel)NULL;
    statePtr->timer	= (Tcl_TimerToken)NULL;

    statePtr->flags	= flags;
    statePtr->watchMask	= 0;
    statePtr->mode	= 0;

    statePtr->interp	= interp;
    statePtr->callback	= (Tcl_Obj *)0;
    statePtr->password	= (Tcl_Obj *)0;

    statePtr->vflags	= verify;
    statePtr->ssl	= (SSL*)0;
    statePtr->ctx	= (SSL_CTX*)0;
    statePtr->bio	= (BIO*)0;
    statePtr->p_bio	= (BIO*)0;

    statePtr->err	= "";

    /* allocate script */
    if (script) {
	char *tmp = Tcl_GetStringFromObj(script, NULL);
	if (tmp && *tmp) {
	    statePtr->callback = Tcl_DuplicateObj(script);
	    Tcl_IncrRefCount(statePtr->callback);
	}
    }

    /* allocate password */
    if (password) {
	char *tmp = Tcl_GetStringFromObj(password, NULL);
	if (tmp && *tmp) {
	    statePtr->password = Tcl_DuplicateObj(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;
	}
	if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
	    /*
	     * 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, proto, key, cert, CAdir, CAfile, ciphers))
	    == (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.
     */

	/*
	 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
	 */
	Tls_Free((char *) statePtr);
        return TCL_ERROR;
    }















    /*
     * 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;
    }

    /*
     * 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_CLOSE);
    statePtr->bio	= BIO_new(BIO_f_ssl());

 * Side effects:
 *	constructs SSL context (CTX)
 *
 *-------------------------------------------------------------------
 */

static SSL_CTX *
CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers)
    State *statePtr;
    int proto;
    char *key;
    char *cert;
    char *CAdir;
    char *CAfile;
    char *ciphers;
{
    Tcl_Interp *interp = statePtr->interp;
    SSL_CTX *ctx = NULL;
    Tcl_DString ds;
    Tcl_DString ds1;
    int off = 0;

    /* create SSL context */
#if !defined(NO_SSL2) && !defined(NO_SSL3)

    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

#ifndef NO_DH
    {
	DH* dh = get_dh512();
	SSL_CTX_set_tmp_dh(ctx, dh);
	DH_free(dh);

        /* get the private key associated with this certificate */
        if (key == NULL) key=cert;

        if (SSL_CTX_use_PrivateKey_file(ctx, F2N( key, &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 ", key, " ",
                             REASON(), (char *) NULL);
            SSL_CTX_free(ctx);
            return (SSL_CTX *)0;
        }
	Tcl_DStringFree(&ds);

	peer	= SSL_get_certificate(statePtr->ssl);
    if (peer) {
	objPtr = Tls_NewX509Obj(interp, 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));
    }
    Tcl_SetObjResult( interp, objPtr);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * VersionObjCmd -- return version string from OpenSSL.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------
 */
static int
VersionObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj	*CONST objv[];
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1);

    Tcl_SetObjResult(interp, objPtr);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * Tls_Free --
 *
 *	This procedure cleans up when a SSL socket based channel

	statePtr->timer = NULL;
    }

    if (statePtr->ssl) {
	SSL_shutdown(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;
    }
}

/*
 *-------------------------------------------------------------------
 *
 * Tls_Init --

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd,
	    (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);

    return Tcl_PkgProvide(interp, PACKAGE, VERSION);
}

/*
 *------------------------------------------------------*
 *

<!doctype html public "-//W3C//DTD HTML 4.0 Transitional//EN">

<html>

<head>
<meta http-equiv="Content-Type"
content="text/html; charset=iso-8859-1">
<meta name="Author"
content="Matt Newman &lt;matt@novadigm.com&gt;">
<meta name="Copyright" content="1999 Matt Newman.">

<title>TLS (SSL) Tcl Commands</title>
</head>

<body bgcolor="#FFFFFF">

<dl>
    <dd><a href="#NAME">NAME</a> <dl>

            <dd><b>tls::socket </b><em>?options? host port</em></dd>
            <dd><b>tls::socket</b><em> ?-server command?
                ?options? port</em></dd>
            <dd><b>tls::handshake</b><em> channel</em></dd>
            <dd><b>tls::status </b><em>?-local? channel</em></dd>
            <dd><b>tls::import</b><em> channel ?options?</em></dd>
            <dd><b>tls::ciphers </b><em>protocol ?verbose?</em></dd>
            <dd><b>tls::version</b></dd>
        </dl>
    </dd>
    <dd><a href="#COMMANDS">COMMANDS</a></dd>
    <dd><a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a></dd>
    <dd><a href="#HTTPS EXAMPLE">HTTPS EXAMPLE</a></dd>
    <dd><a href="#SEE ALSO">SPECIAL CONSIDERATIONS</a></dd>
    <dd><a href="#SEE ALSO">SEE ALSO</a></dd>
</dl>

<hr>

port</em><br>
<b>tls::socket</b><em> ?-server command? ?options? port</em><br>
</a><a href="#tls::status"><b>tls::status </b><em>?-local? channel</em><br>
</a><a href="#tls::handshake"><b>tls::handshake</b><em> channel</em></a><br>
<br>
<a href="#tls::import"><b>tls::import </b><i>channel ?options?</i></a><br>
<a href="#tls::ciphers protocol ?verbose?"><strong>tls::ciphers</strong>
<em>protocol ?verbose?</em></a><br>
<a href="#tls::version"><b>tls::version</b></a>
</p>

<h3><a name="DESCRIPTION">DESCRIPTION</a></h3>

<p>This extension provides a generic binding to <a
href="http://www.openssl.org/">OpenSSL</a>, utilizing the
<strong>Tcl_StackChannel</strong>
API for Tcl 8.2 and higher. The sockets behave exactly the same

    <dd>SSL-enable a regular Tcl channel - it need not be a
        socket, but must provide bi-directional flow. Also
        setting session parameters for SSL handshake.</dd>
</dl>

<blockquote>
    <dl>


        <dt>-<strong>cadir</strong> <em>dir</em></dt>
        <dd>Provide the directory containing the CA certificates.</dd>
        <dt><strong>-cafile </strong><em>filename</em></dt>
        <dd>Provide the CA file.</dd>
        <dt><strong>-certfile</strong> <em>filename</em></dt>
        <dd>Provide the certificate to use.</dd>
        <dt><strong>-cipher </strong><em>string</em></dt>
        <dd>Provide the cipher suites to use. Syntax is as per
            OpenSSL.</dd>
        <dt><strong>-command</strong><em> callback</em></dt>
        <dd>If specified, this callback will be invoked at several points
            during the OpenSSL handshake.  It can pass errors and tracing
            information, and it can allow Tcl scripts to perform
            their own validation of the certificate in place of the
            default validation provided by OpenSSL.
            The callback should return an integer whose interpretation
            depends on context.
            <br>
            See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a> for
            further discussion.</dd>
        <dt><strong>-keyfile</strong> <em>filename</em></dt>
        <dd>Provide the private key file. (<strong>default</strong>:
            value of -certfile)</dd>
        <dt><strong>-model</strong> <em>channel</em></dt>
        <dd>This will force this channel to share the same <em><strong>SSL_CTX</strong></em>
            structure as the specified <em>channel</em>, and
            therefore share callbacks etc.</dd>
        <dt><strong>-password</strong><em> callback</em></dt>
        <dd>If supplied, this callback will be invoked when OpenSSL needs
            to obtain a password, typically for a certificate.
            The callback should return a string which represents the
            password to be used.
            <br>
            See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a> for
            further discussion.</dd>
        <dt><strong>-request </strong><em>bool</em></dt>
        <dd>Request a certificate from peer during SSL handshake.
            (<strong>default</strong>: <em>true</em>)</dd>
        <dt><strong>-require</strong> <em>bool</em></dt>
        <dd>Require a valid certificate from peer during SSL
            handshake. If this is set to true then <strong>-request</strong>
            must also be set to true. (<strong>default</strong>: <em>false</em>)</dd>
        <dt><strong>-server</strong> <em>bool</em></dt>
        <dd>Handshake as server if true, else handshake as
            client.(<strong>default</strong>: <em>false</em>)</dd>

        <dt><strong>-ssl2</strong> <em>bool</em></dt>
        <dd>Enable use of SSL v2. (<strong>default</strong>: <em>true</em>
            unless -DNO_PATENTS was specified in build)</dd>
        <dt><strong>-ssl3 </strong><em>bool</em></dt>
        <dd>Enable use of SSL v3. (<strong>default</strong>: <em>true</em>)</dd>
        <dt>-<strong>tls1</strong> <em>bool</em></dt>
        <dd>Enable use of TLS v1. (<strong>default</strong>: <em>false</em>)</dd>

        you supply, which must be one of <em>ssl2, ssl3, or tls1</em>.
        If <em>verbose</em> is specified as true then a verbose,
        semi-human readable list is returned providing additional
        information on the nature of the cipher support. In each
        case the result is a Tcl list.</dd>
</dl>

<dl>
    <dt><a name="tls::version"><strong>tls::version</strong></a></dt>
    <dd>Returns the version string defined by OpenSSL.</dd>
</dl>

<h3><a name="CALLBACK OPTIONS">CALLBACK OPTIONS</a></h3>


<p>
As indicated above, individual channels can be given their own callbacks
to handle intermediate processing by the OpenSSL library, using the
<em>-command</em> and <em>-password</em> options passed to either of

<strong>tls::socket</strong> or <strong>tls::import</strong>.
</p>

<p>
Reference implementations of these callbacks are provided in the distribution
as <strong>tls::callback</strong> and <strong>tls::password</strong>.
Note that these are <em>sample</em> implementations only.  In a more realistic
deployment you would substitute your own callbacks, typically by configuring
the <em>-command</em> and <em>-password</em> options on each channel with
scripts to be executed when the callbacks are invoked.
</p>

<p>
The default behavior when the <em>-command</em> option is not specified is for
TLS to process the associated library callbacks internally.
The default behavior when the <em>-password</em> option is not specified is for
TLS to process the associated library callbacks by attempting to call
<strong>tls::password</strong>.
The difference between these two behaviors is a consequence of maintaining
compatibility with earlier implementations.  The use of implied callbacks
is not recommended.
</p>

<p>
The <strong>tls::debug</strong> variable provides some additional control
over the default commands.  Its value is zero by default.  Higher values
produce more diagnostic output.  Setting this value greater than zero
will also force the default verify method in <strong>tls::callback</strong>

to accept the certificate, even if it is invalid.
</p>

<h3><a name="HTTPS EXAMPLE">HTTPS EXAMPLE</a></h3>

<p>This example requires a patch to the <strong>http</strong>
module that ships with Tcl - this patch has been submitted for
inclusion in Tcl 8.2.1, but is also provided in the tls directory
if needed. A sample server.pem is provided with the TLS release,

<p><strong>socket</strong>, <strong>fileevent, </strong><a
href="http://www.openssl.org/"><strong>OpenSSL</strong></a></p>

<hr>

<pre>
Copyright &copy; 1999 Matt Newman.
</pre>
</body>
</html>

#
# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
#
# $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.tcl,v 1.4 2003/05/15 20:44:46 razzell Exp $
#
namespace eval tls {
    variable logcmd tclLog
    variable debug 0
 
    # Default flags passed to tls::import
    variable defaults {}

    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 "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
	set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    }
    set argc [llength $args]
    set sopts {}
    set iopts [concat [list -server $server] ${tls::defaults}]	;# Import options

    for {set idx 0} {$idx < $argc} {incr idx} {
	set arg [lindex $args $idx]
	switch -glob -- $server,$arg {
	    0,-async	{lappend sopts $arg}
	    0,-myaddr	-
	    *,-myport	{lappend sopts $arg [lindex $args [incr idx]]}


	    *,-cadir	-
	    *,-cafile	-
	    *,-certfile	-
	    *,-cipher	-
	    *,-command	-
	    *,-keyfile	-
	    *,-password	-
	    *,-request	-
	    *,-require	-
	    *,-ssl2	-
	    *,-ssl3	-
	    *,-tls1	{lappend iopts $arg [lindex $args [incr idx]]}
	    -*		{return -code error "bad option \"$arg\": must be one of $options"}
	    default	{break}

	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 {

	    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
}

/*
 * Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsInt.h,v 1.9 2003/05/15 20:44:46 razzell Exp $
 *
 * 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

    int flags;		/* currently only CHANNEL_ASYNC */
    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) */