/*
* Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
* 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 int TlsBlockModeProc _ANSI_ARGS_((ClientData instanceData,
int mode));
static int TlsCloseProc _ANSI_ARGS_ ((ClientData instanceData,
Tcl_Interp *interp));
static int TlsInputProc _ANSI_ARGS_((ClientData instanceData,
char *buf, int bufSize, int *errorCodePtr));
static int TlsOutputProc _ANSI_ARGS_((ClientData instanceData,
CONST char *buf, int toWrite, int *errorCodePtr));
static int TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData,
Tcl_Interp *interp, CONST84 char *optionName,
Tcl_DString *dsPtr));
static void TlsWatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
static int TlsGetHandleProc _ANSI_ARGS_ ((ClientData instanceData,
int direction, ClientData *handlePtr));
static int TlsNotifyProc _ANSI_ARGS_ ((ClientData instanceData,
int mask));
static void TlsChannelHandler _ANSI_ARGS_ ((ClientData clientData,
int mask));
static void TlsChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData));
/*
* This structure describes the channel type structure for TCP socket
* based IO. These are what the structures should look like, but we
* have to build them up at runtime to be correct depending on whether
* we are loaded into an 8.2.0-8.3.1 or 8.3.2+ Tcl interpreter.
*/
#ifdef TLS_STATIC_STRUCTURES_NOT_USED
static Tcl_ChannelType tlsChannelType2 = {
"tls", /* Type name. */
TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2+) */
TlsCloseProc, /* Close proc. */
TlsInputProc, /* Input proc. */
TlsOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
TlsGetOptionProc, /* Get option proc. */
TlsWatchProc, /* Initialize notifier. */
TlsGetHandleProc, /* Get file handle out of channel. */
NULL, /* Close2Proc. */
TlsBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* FlushProc. */
TlsNotifyProc, /* handlerProc. */
};
static Tcl_ChannelType tlsChannelType1 = {
"tls", /* Type name. */
TlsBlockModeProc, /* Set blocking/nonblocking mode.*/
TlsCloseProc, /* Close proc. */
TlsInputProc, /* Input proc. */
TlsOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
TlsGetOptionProc, /* Get option proc. */
TlsWatchProc, /* Initialize notifier. */
TlsGetHandleProc, /* Get file handle out of channel. */
};
#else
static Tcl_ChannelType *tlsChannelType = NULL;
#endif
/*
*-------------------------------------------------------------------
*
* 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()
{
/*
* Initialize the channel type if necessary
*/
if (tlsChannelType == NULL) {
/*
* Allocation of a new channeltype structure is not easy, because of
* the various verson of the core and subsequent changes to the
* structure. The main challenge is to allocate enough memory for
* odern versions even if this extyension is compiled against one
* of the older variant!
*
* (1) Versions before stubs (8.0.x) are simple, because they are
* supported only if the extension is compiled against exactly
* that version of the core.
*
* (2) With stubs we just determine the difference between the older
* and modern variant and overallocate accordingly if compiled
* against an older variant.
*/
unsigned int size = sizeof(Tcl_ChannelType); /* Base size */
/*
* Size of a procedure pointer. We assume that all procedure
* pointers are of the same size, regardless of exact type
* (arguments and return values).
*
* 8.2. First version containing close2proc. Baseline.
* 8.3.2 Three additional vectors. Moved blockMode, new flush- and
* handlerProc's.
*
* => Compilation against earlier version has to overallocate three
* procedure pointers.
*/
#ifdef EMULATE_CHANNEL_VERSION_2
size += 3 * procPtrSize;
#endif
tlsChannelType = (Tcl_ChannelType *) ckalloc(size);
memset((VOID *) tlsChannelType, 0, size);
/*
* Common elements of the structure (no changes in location or name)
* close2Proc, seekProc, setOptionProc stay NULL.
*/
tlsChannelType->typeName = "tls";
tlsChannelType->closeProc = TlsCloseProc;
tlsChannelType->inputProc = TlsInputProc;
tlsChannelType->outputProc = TlsOutputProc;
tlsChannelType->getOptionProc = TlsGetOptionProc;
tlsChannelType->watchProc = TlsWatchProc;
tlsChannelType->getHandleProc = TlsGetHandleProc;
/*
* blockModeProc is a twister. We have to make some runtime-choices,
* depending on the version we compiled against.
*/
#ifdef EMULATE_CHANNEL_VERSION_2
/*
* We are compiling against an 8.3.1- core. We have to create some
* definitions for the new elements as the compiler does not know them
* by name.
*/
if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
/*
* The 'version' element of 8.3.2 is in the the place of the
* blockModeProc. For 8.2.0-8.3.1 we have to set our blockModeProc
* into this place.
*/
tlsChannelType->blockModeProc = TlsBlockModeProc;
} else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ {
/*
* For the 8.3.2 core we present ourselves as a version 2
* driver. This means a special value in version (ex
* blockModeProc), blockModeProc in a different place and of
* course usage of the handlerProc. The last two have to
* referenced with pointer magic because they aren't defined
* otherwise.
*/
tlsChannelType->blockModeProc =
(Tcl_DriverBlockModeProc*) TLS_CHANNEL_VERSION_2;
(*((Tcl_DriverBlockModeProc**)(&(tlsChannelType->close2Proc)+1)))
= TlsBlockModeProc;
(*((TlsDriverHandlerProc**)(&(tlsChannelType->close2Proc)+3)))
= TlsNotifyProc;
}
#else
/*
* Compiled against 8.3.2+. Direct access to all elements possible. Use
* channelTypeVersion information to select the values to use.
*/
if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
/*
* The 'version' element of 8.3.2 is in the the place of the
* blockModeProc. For the original patch in 8.1.x and the firstly
* included (8.2) we have to set our blockModeProc into this
* place.
*/
tlsChannelType->version = (Tcl_ChannelTypeVersion)TlsBlockModeProc;
} else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ {
/*
* For the 8.3.2 core we present ourselves as a version 2
* driver. This means a special value in version (ex
* blockModeProc), blockModeProc in a different place and of
* course usage of the handlerProc.
*/
tlsChannelType->version = TCL_CHANNEL_VERSION_2;
tlsChannelType->blockModeProc = TlsBlockModeProc;
tlsChannelType->handlerProc = TlsNotifyProc;
}
#endif
}
return tlsChannelType;
}
/*
*-------------------------------------------------------------------
*
* 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, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
State *statePtr = (State *) instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
statePtr->flags |= TLS_TCL_ASYNC;
} else {
statePtr->flags &= ~(TLS_TCL_ASYNC);
}
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
return 0;
} else {
return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
"-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1");
}
}
/*
*-------------------------------------------------------------------
*
* 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, /* The socket to close. */
Tcl_Interp *interp) /* For error reporting - unused. */
{
State *statePtr = (State *) instanceData;
dprintf(stderr,"\nTlsCloseProc(0x%x)", (unsigned int) statePtr);
if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
TlsChannelHandler, (ClientData) statePtr);
}
Tls_Clean(statePtr);
Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
return TCL_OK;
}
/*
*-------------------------------------------------------------------
*
* 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, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available
* in the buffer? */
int *errorCodePtr) /* Where to store error code. */
{
State *statePtr = (State *) instanceData;
int bytesRead; /* How many bytes were read? */
*errorCodePtr = 0;
dprintf(stderr,"\nBIO_read(%d)", bufSize);
if (statePtr->flags & TLS_TCL_CALLBACK) {
/* don't process any bytes while verify callback is running */
bytesRead = 0;
goto input;
}
if (!SSL_is_init_finished(statePtr->ssl)) {
bytesRead = Tls_WaitForConnect(statePtr, errorCodePtr);
if (bytesRead <= 0) {
if (*errorCodePtr == ECONNRESET) {
/* Soft EOF */
*errorCodePtr = 0;
bytesRead = 0;
}
goto input;
}
}
if (statePtr->flags & TLS_TCL_INIT) {
statePtr->flags &= ~(TLS_TCL_INIT);
}
/*
* 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(stderr,"\nBIO_read -> %d", bytesRead);
if (bytesRead < 0) {
int err = SSL_get_error(statePtr->ssl, bytesRead);
if (err == SSL_ERROR_SSL) {
Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, bytesRead));
*errorCodePtr = ECONNABORTED;
} else if (BIO_should_retry(statePtr->bio)) {
dprintf(stderr,"RE! ");
*errorCodePtr = EAGAIN;
} else {
*errorCodePtr = Tcl_GetErrno();
if (*errorCodePtr == ECONNRESET) {
/* Soft EOF */
*errorCodePtr = 0;
bytesRead = 0;
}
}
}
input:
dprintf(stderr, "\nInput(%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, /* Socket state. */
CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
State *statePtr = (State *) instanceData;
int written, err;
*errorCodePtr = 0;
dprintf(stderr,"\nBIO_write(0x%x, %d)", (unsigned int) statePtr, toWrite);
if (statePtr->flags & TLS_TCL_CALLBACK) {
/* don't process any bytes while verify callback is running */
written = -1;
*errorCodePtr = EAGAIN;
goto output;
}
if (!SSL_is_init_finished(statePtr->ssl)) {
written = Tls_WaitForConnect(statePtr, errorCodePtr);
if (written <= 0) {
goto output;
}
}
if (statePtr->flags & TLS_TCL_INIT) {
statePtr->flags &= ~(TLS_TCL_INIT);
}
if (toWrite == 0) {
dprintf(stderr, "zero-write\n");
BIO_flush(statePtr->bio);
written = 0;
goto output;
} else {
/*
* 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(stderr,"\nBIO_write(0x%x, %d) -> [%d]",
(unsigned int) statePtr, toWrite, written);
}
if (written <= 0) {
switch ((err = SSL_get_error(statePtr->ssl, written))) {
case SSL_ERROR_NONE:
if (written < 0) {
written = 0;
}
break;
case SSL_ERROR_WANT_WRITE:
dprintf(stderr," write W BLOCK");
break;
case SSL_ERROR_WANT_READ:
dprintf(stderr," write R BLOCK");
break;
case SSL_ERROR_WANT_X509_LOOKUP:
dprintf(stderr," write X BLOCK");
break;
case SSL_ERROR_ZERO_RETURN:
dprintf(stderr," closed\n");
written = 0;
break;
case SSL_ERROR_SYSCALL:
*errorCodePtr = Tcl_GetErrno();
dprintf(stderr," [%d] syscall errr: %d",
written, *errorCodePtr);
written = -1;
break;
case SSL_ERROR_SSL:
Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written));
*errorCodePtr = ECONNABORTED;
written = -1;
break;
default:
dprintf(stderr," unknown err: %d\n", err);
break;
}
}
output:
dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written);
return written;
}
/*
*-------------------------------------------------------------------
*
* 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. */
CONST84 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;
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
Tcl_Channel downChan = Tls_GetParent(statePtr);
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;
} else {
size_t len = 0;
if (optionName != (char *) NULL) {
len = strlen(optionName);
}
#if 0
if ((len == 0) || ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-cipher", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-cipher");
}
Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
if (len) {
return TCL_OK;
}
}
#endif
return TCL_OK;
}
}
/*
*-------------------------------------------------------------------
*
* 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. */
{
State *statePtr = (State *) instanceData;
dprintf(stderr, "TlsWatchProc(0x%x)\n", 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) { return; }
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
Tcl_Channel downChan;
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.
*/
downChan = Tls_GetParent(statePtr);
(Tcl_GetChannelType(downChan))
->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
/*
* Management of the internal timer.
*/
if (statePtr->timer != (Tcl_TimerToken) NULL) {
Tcl_DeleteTimerHandler(statePtr->timer);
statePtr->timer = (Tcl_TimerToken) NULL;
}
if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
/*
* There is interest in readable events and we actually have
* data waiting, so generate a timer to flush that.
*/
statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
TlsChannelHandlerTimer, (ClientData) statePtr);
}
} else {
if (mask == statePtr->watchMask)
return;
if (statePtr->watchMask) {
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
TlsChannelHandler, (ClientData) statePtr);
}
statePtr->watchMask = mask;
if (statePtr->watchMask) {
/*
* Setup active monitor for events on underlying Channel.
*/
Tcl_CreateChannelHandler(Tls_GetParent(statePtr),
statePtr->watchMask, TlsChannelHandler,
(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, /* The socket state. */
int direction, /* Which Tcl_File to retrieve? */
ClientData *handlePtr) /* Where to store the handle. */
{
State *statePtr = (State *) instanceData;
return Tcl_GetChannelHandle(Tls_GetParent(statePtr), 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(instanceData, mask)
ClientData instanceData; /* The state of the notified transformation */
int mask; /* The mask of occuring events */
{
State *statePtr = (State *) instanceData;
/*
* An event occured 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) {
return 0;
}
if (statePtr->flags & TLS_TCL_INIT
&& !SSL_is_init_finished(statePtr->ssl)) {
int errorCode;
if (Tls_WaitForConnect(statePtr, &errorCode) <= 0
&& errorCode == EAGAIN) {
return 0;
}
}
return mask;
}
/*
*------------------------------------------------------*
*
* 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, mask)
ClientData clientData;
int mask;
{
State *statePtr = (State *) clientData;
dprintf(stderr, "HANDLER(0x%x)\n", 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);
}
/*
*------------------------------------------------------*
*
* 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 clientData; /* Transformation to query */
{
State *statePtr = (State *) clientData;
int mask = 0;
statePtr->timer = (Tcl_TimerToken) NULL;
if (BIO_wpending(statePtr->bio)) {
mask |= TCL_WRITABLE;
}
if (BIO_pending(statePtr->bio)) {
mask |= TCL_READABLE;
}
Tcl_NotifyChannel(statePtr->self, mask);
}
/*
*------------------------------------------------------*
*
* Tls_WaitForConnect --
*
* Sideeffects:
* Issues SSL_accept or SSL_connect
*
* Result:
* None.
*
*------------------------------------------------------*
*/
int
Tls_WaitForConnect( statePtr, errorCodePtr)
State *statePtr;
int *errorCodePtr; /* Where to store error code. */
{
int err;
dprintf(stderr,"\nWaitForConnect(0x%x)", (unsigned int) statePtr);
if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
/*
* We choose ECONNRESET over ECONNABORTED here because some server
* side code, on the wiki for example, sets up a read handler that
* does a read and if eof closes the channel. There is no catch/try
* around the reads so exceptions will result in potentially many
* dangling channels hanging around that should have been closed.
* (Backgroun: ECONNABORTED maps to a Tcl exception and
* ECONNRESET maps to graceful EOF).
*/
*errorCodePtr = ECONNRESET;
return -1;
}
for (;;) {
/* Not initialized yet! */
if (statePtr->flags & TLS_TCL_SERVER) {
err = SSL_accept(statePtr->ssl);
} else {
err = SSL_connect(statePtr->ssl);
}
/*SSL_write(statePtr->ssl, (char*)&err, 0); HACK!!! */
if (err > 0) {
BIO_flush(statePtr->bio);
}
if (err <= 0) {
int rc = SSL_get_error(statePtr->ssl, err);
if (rc == SSL_ERROR_SSL) {
Tls_Error(statePtr,
(char *)ERR_reason_error_string(ERR_get_error()));
statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
*errorCodePtr = ECONNABORTED;
return -1;
} else if (BIO_should_retry(statePtr->bio)) {
if (statePtr->flags & TLS_TCL_ASYNC) {
dprintf(stderr,"E! ");
*errorCodePtr = EAGAIN;
return -1;
} else {
continue;
}
} else if (err == 0) {
if (Tcl_Eof(statePtr->self)) {
return 0;
}
dprintf(stderr,"CR! ");
*errorCodePtr = ECONNRESET;
return -1;
}
if (statePtr->flags & TLS_TCL_SERVER) {
err = SSL_get_verify_result(statePtr->ssl);
if (err != X509_V_OK) {
Tls_Error(statePtr,
(char *)X509_verify_cert_error_string(err));
statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
*errorCodePtr = ECONNABORTED;
return -1;
}
}
*errorCodePtr = Tcl_GetErrno();
dprintf(stderr,"ERR(%d, %d) ", rc, *errorCodePtr);
return -1;
}
dprintf(stderr,"R0! ");
return 1;
}
}
Tcl_Channel
Tls_GetParent( statePtr )
State *statePtr;
{
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
return Tcl_GetStackedChannel(statePtr->self);
} else {
/* The reason for the existence of this procedure is
* the fact that stacking a transform over another
* transform will leave our internal pointer unchanged,
* and thus pointing to the new transform, and not the
* Channel structure containing the saved state of this
* transform. This is the price to pay for leaving
* Tcl_Channel references intact. The only other solution
* is an extension of Tcl_ChannelType with another driver
* procedure to notify a Channel about the (un)stacking.
*
* It walks the chain of Channel structures until it
* finds the one pointing having 'ctrl' as instanceData
* and then returns the superceding channel to that. (AK)
*/
Tcl_Channel self = statePtr->self;
Tcl_Channel next;
while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) {
next = Tcl_GetStackedChannel (self);
if (next == (Tcl_Channel) NULL) {
/* 09/24/1999 Unstacking bug,
* found by Matt Newman <matt@sensus.org>.
*
* We were unable to find the channel structure for this
* transformation in the chain of stacked channel. This
* means that we are currently in the process of unstacking
* it *and* there were some bytes waiting which are now
* flushed. In this situation the pointer to the channel
* itself already refers to the parent channel we have to
* write the bytes into, so we return that.
*/
return statePtr->self;
}
self = next;
}
return Tcl_GetStackedChannel (self);
}
}
Documentation