Index: generic/tls.c ================================================================== --- generic/tls.c +++ generic/tls.c @@ -1439,24 +1439,25 @@ } } statePtr->ctx = ctx; - /* - * We need to make sure that the channel works in binary (for the - * encryption not to get goofed up). - */ + /* Preserve channel config */ 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); + + /* Ensure the channel works in binary mode (for the encryption not to get goofed up). */ Tcl_SetChannelOption(interp, chan, "-translation", "binary"); Tcl_SetChannelOption(interp, chan, "-blocking", "true"); + + /* Create stacked channel */ 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) { @@ -1469,10 +1470,11 @@ Tcl_DStringFree(&upperChannelEOFChar); Tcl_DStringFree(&upperChannelBlocking); return TCL_ERROR; } + /* Restore channel config */ 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)); Tcl_DStringFree(&upperChannelTranslation); @@ -1645,10 +1647,12 @@ } /* Set client mode */ SSL_set_connect_state(statePtr->ssl); } + + /* Set BIO for read and write operations on SSL object */ SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio); BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE); /* * End of SSL Init @@ -1674,11 +1678,11 @@ * *------------------------------------------------------------------- */ static int UnimportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Tcl_Channel chan, child; /* The stacked and underlying channels */ + Tcl_Channel chan, parent; /* The stacked and underlying channels */ Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar; int res = TCL_OK; (void) clientData; dprintf("Called"); @@ -1694,14 +1698,14 @@ return TCL_ERROR; } /* Make sure to operate on the topmost channel */ chan = Tcl_GetTopChannel(chan); - child = Tcl_GetStackedChannel(chan); + parent = Tcl_GetStackedChannel(chan); /* Verify is a stacked channel */ - if (child == NULL) { + if (parent == NULL) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a stacked channel", (char *) NULL); Tcl_SetErrorCode(interp, "TLS", "UNIMPORT", "CHANNEL", "INVALID", (char *) NULL); return TCL_ERROR; } @@ -1709,31 +1713,33 @@ /* Flush any pending data */ if (Tcl_Flush(chan) != TCL_OK) { return TCL_ERROR; } + /* Init storage */ Tcl_DStringInit(&upperChannelTranslation); Tcl_DStringInit(&upperChannelBlocking); Tcl_DStringInit(&upperChannelEOFChar); Tcl_DStringInit(&upperChannelEncoding); - /* Get current config - EOL translation, encoding and buffering options are shared between all channels in the stack */ + /* Preserve current channel config */ Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking); Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding); Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar); Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation); - /* Unstack the channel and restore underlying channel config */ - if (Tcl_UnstackChannel(interp, chan) == TCL_OK) { - Tcl_SetChannelOption(interp, child, "-encoding", Tcl_DStringValue(&upperChannelEncoding)); - Tcl_SetChannelOption(interp, child, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar)); - Tcl_SetChannelOption(interp, child, "-translation", Tcl_DStringValue(&upperChannelTranslation)); - Tcl_SetChannelOption(interp, child, "-blocking", Tcl_DStringValue(&upperChannelBlocking)); - } else { + /* Unstack the channel */ + if (Tcl_UnstackChannel(interp, chan) != TCL_OK) { res = TCL_ERROR; } + /* Restore channel config */ + Tcl_SetChannelOption(interp, parent, "-encoding", Tcl_DStringValue(&upperChannelEncoding)); + Tcl_SetChannelOption(interp, parent, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar)); + Tcl_SetChannelOption(interp, parent, "-translation", Tcl_DStringValue(&upperChannelTranslation)); + Tcl_SetChannelOption(interp, parent, "-blocking", Tcl_DStringValue(&upperChannelBlocking)); + /* Clean-up */ Tcl_DStringFree(&upperChannelTranslation); Tcl_DStringFree(&upperChannelEncoding); Tcl_DStringFree(&upperChannelEOFChar); Tcl_DStringFree(&upperChannelBlocking); Index: generic/tlsBIO.c ================================================================== --- generic/tlsBIO.c +++ generic/tlsBIO.c @@ -1,14 +1,40 @@ /* + * Provides Custom BIO layer to interface OpenSSL with TCL. These + * functions directly interface between the IO channel and BIO buffers. + * * Copyright (C) 1997-2000 Matt Newman + * Copyright (C) 2024 Brian O'Hagan * - * Provides BIO layer to interface OpenSSL to TCL. */ #include "tlsInt.h" +#include + +/* Define BIO methods structure */ +static BIO_METHOD *BioMethods = NULL; + -/* Called by SSL_write() */ +/* + *----------------------------------------------------------------------------- + * + * BioWrite -- + * + * This function is used to read encrypted data from the BIO and write it + * into the socket. This function will be called in response to the + * application calling BIO_write_ex() or BIO_write(). + * + * Results: + * Returns the number of bytes written to channel, 0 for EOF, or + * -1 for error. + * + * Side effects: + * Writes BIO data to channel. + * + *----------------------------------------------------------------------------- + */ + static int BioWrite(BIO *bio, const char *buf, int bufLen) { Tcl_Channel chan; Tcl_Size ret; int tclEofChan, tclErrno; @@ -57,11 +83,29 @@ } } return (int) ret; } -/* Called by SSL_read()*/ +/* + *----------------------------------------------------------------------------- + * + * BioRead -- + * + * This function is used to read encrypted data from the socket + * and write it into the BIO. This function will be called in response to + * the application calling BIO_read_ex() or BIO_read(). + * + * Results: + * Returns the number of bytes read from channel, 0 for EOF, or -1 for + * error. + * + * Side effects: + * Reads channel data into BIO. + * + *----------------------------------------------------------------------------- + */ + static int BioRead(BIO *bio, char *buf, int bufLen) { Tcl_Channel chan; Tcl_Size ret = 0; int tclEofChan, tclErrno; @@ -118,16 +162,51 @@ bufLen, (void *) chan, ret); return (int) ret; } +/* + *----------------------------------------------------------------------------- + * + * BioPuts -- + * + * This function is used to read a NULL terminated string from the BIO and + * write it to the channel. This function will be called in response to + * the application calling BIO_puts(). + * + * Results: + * Returns the number of bytes written to channel or 0 for error. + * + * Side effects: + * Writes data to channel. + * + *----------------------------------------------------------------------------- + */ + static int BioPuts(BIO *bio, const char *str) { dprintf("BioPuts(%p, ) called", bio, str); return BioWrite(bio, str, (int) strlen(str)); } +/* + *----------------------------------------------------------------------------- + * + * BioCtrl -- + * + * This function is used to process control messages in the BIO. This + * function will be called in response to the application calling BIO_ctrl(). + * + * Results: + * Function dependent + * + * Side effects: + * Function dependent + * + *----------------------------------------------------------------------------- + */ + 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); @@ -222,19 +301,53 @@ break; } return ret; } +/* + *----------------------------------------------------------------------------- + * + * BioNew -- + * + * This function is used to create a new instance of the BIO. This + * function will be called in response to the application calling BIO_new(). + * + * Results: + * Returns boolean success result (1=success, 0=failure) + * + * Side effects: + * Initializes BIO structure. + * + *----------------------------------------------------------------------------- + */ + 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; } +/* + *----------------------------------------------------------------------------- + * + * BioFree -- + * + * This function is used to destroy an instance of a BIO. This function + * will be called in response to the application calling BIO_free(). + * + * Results: + * Returns boolean success result + * + * Side effects: + * Initializes BIO structure. + * + *----------------------------------------------------------------------------- + */ + static int BioFree(BIO *bio) { if (bio == NULL) { return 0; } @@ -250,13 +363,28 @@ BIO_clear_flags(bio, -1); } return 1; } +/* + *----------------------------------------------------------------------------- + * + * BIO_new_tcl -- + * + * This function is used to initialize the BIO method handlers. + * + * Results: + * Returns pointer to BIO or NULL for failure + * + * Side effects: + * Initializes BIO Methods. + * + *----------------------------------------------------------------------------- + */ + 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; @@ -320,5 +448,32 @@ BIO_set_data(bio, statePtr); BIO_set_shutdown(bio, flags); BIO_set_init(bio, 1); return bio; } + +/* + *----------------------------------------------------------------------------- + * + * BIO_cleanup -- + * + * This function is used to destroy a BIO_METHOD structure and free up any + * memory associated with it. + * + * Results: + * Standard TCL result + * + * Side effects: + * Destroys BIO Methods. + * + *----------------------------------------------------------------------------- + */ + +int BIO_cleanup () { + dprintf("BIO_cleanup() called"); + + if (BioMethods != NULL) { + BIO_meth_free(BioMethods); + BioMethods = NULL; + } + return TCL_OK; +} Index: generic/tlsIO.c ================================================================== --- generic/tlsIO.c +++ generic/tlsIO.c @@ -1,8 +1,12 @@ /* + * Provides IO functions to interface between the BIO buffers and TCL + * applications when using stacked channels. + * * Copyright (C) 1997-2000 Matt Newman * Copyright (C) 2000 Ajuba Solutions + * Copyright (C) 2024 Brian O'Hagan * * 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 @@ -19,24 +23,25 @@ #include "tlsInt.h" #include /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsBlockModeProc -- * - * This procedure is invoked by the generic IO level - * to set channel to blocking or nonblocking mode. + * This procedure is invoked by the generic IO level to set channel to + * blocking or nonblocking mode. Called by the generic I/O layer whenever + * the Tcl_SetChannelOption() function is used with option -blocking. * * Results: * 0 if successful or POSIX error code if 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) { @@ -46,47 +51,46 @@ } 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? + * This procedure is invoked by the generic IO level to perform channel + * type specific cleanup when a SSL socket based channel is closed. * * Results: * 0 if successful or POSIX error code 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); + + /* Flush any pending data */ Tls_Clean(statePtr); Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); return 0; } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsClose2Proc -- * - * Similar to TlsCloseProc, but allows for separate close read and - * write side of channel. + * Similar to TlsCloseProc, but allows for separate close read and write + * side of channel. * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static int TlsClose2Proc(ClientData instanceData, /* The socket state. */ Tcl_Interp *interp, /* For errors - can be NULL. */ int flags) /* Flags to close read and/or write side of channel */ { @@ -99,23 +103,24 @@ } return EINVAL; } /* - *------------------------------------------------------* + *----------------------------------------------------------------------------- * * Tls_WaitForConnect -- * - * Perform connect (client) or accept (server) + * Perform connect (client) or accept (server) function. Also performs + * equivalent of handshake function. * * Result: * 0 if successful, -1 if failed. * * Side effects: * Issues SSL_accept or SSL_connect * - *------------------------------------------------------* + *----------------------------------------------------------------------------- */ int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) { unsigned long backingError; int err, rc = 0; int bioShouldRetry; @@ -122,10 +127,11 @@ *errorCodePtr = 0; dprintf("WaitForConnect(%p)", (void *) statePtr); dprintFlags(statePtr); + /* Can also check SSL_is_init_finished(ssl) */ if (!(statePtr->flags & TLS_TCL_INIT)) { dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success"); return 0; } @@ -146,11 +152,11 @@ } for (;;) { ERR_clear_error(); - /* Not initialized yet! Also calls SSL_do_handshake. */ + /* Not initialized yet! Also calls SSL_do_handshake(). */ if (statePtr->flags & TLS_TCL_SERVER) { dprintf("Calling SSL_accept()"); err = SSL_accept(statePtr->ssl); } else { @@ -298,33 +304,35 @@ *errorCodePtr = 0; return 0; } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsInputProc -- * - * This procedure is invoked by the generic IO level - * to read input from a SSL socket based channel. + * This procedure is invoked by the generic IO level to read data from the + * BIo. Equivalent to SSL_read. + * Called by the generic I/O layer whenever the Tcl_Read(), Tcl_ReadChars, + * Tcl_Gets, and Tcl_GetsObj functions are used. * * Results: - * Returns the number of bytes read or -1 on error. Sets errorCodePtr - * to a POSIX error code if an error occurred, or 0 if none. + * Returns the number of bytes read or -1 on error. Sets errorCodePtr to + * a POSIX error code if an error occurred, or 0 if none. * * 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, err; *errorCodePtr = 0; - dprintf("BIO_read(%d)", bufSize); + dprintf("Read(%d)", bufSize); /* Skip if user verify callback is still running */ if (statePtr->flags & TLS_TCL_CALLBACK) { dprintf("Callback is running, reading 0 bytes"); return 0; @@ -366,10 +374,11 @@ ERR_clear_error(); /* BIO_read, where 0 means EOF and -1 means error */ bytesRead = BIO_read(statePtr->bio, buf, bufSize); dprintf("BIO_read -> %d", bytesRead); + /* Get error is more comprehensive than SSL_want */ err = SSL_get_error(statePtr->ssl, bytesRead); backingError = ERR_get_error(); if (bytesRead <= 0) { if (BIO_should_retry(statePtr->bio)) { @@ -474,11 +483,11 @@ Tls_Error(statePtr, ERR_reason_error_string(backingError)); } break; case SSL_ERROR_ZERO_RETURN: - /* Peer has closed the connection for writing by sending the close_notify alert. No more data can be read. */ + /* Peer has closed the connection by sending the close_notify alert. Can't read, but can write. */ dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached"); bytesRead = 0; *errorCodePtr = 0; Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert"); break; @@ -502,33 +511,35 @@ 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. + * This procedure is invoked by the generic IO level to write data to + * the BIO. Equivalent to SSL_write. Called by the + * generic I/O layer whenever the Tcl_Write(), Tcl_WriteChars, + * TTcl_WriteObj functions are used. * * Results: * Returns the number of bytes written or -1 on error. Sets errorCodePtr * to a POSIX error code if an error occurred, or 0 if none. * * 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; *errorCodePtr = 0; - dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite); + dprintf("Write(%p, %d)", (void *) statePtr, toWrite); dprintBuffer(buf, toWrite); /* Skip if user verify callback is still running */ if (statePtr->flags & TLS_TCL_CALLBACK) { dprintf("Don't process output while callbacks are running"); @@ -591,10 +602,11 @@ ERR_clear_error(); /* SSL_write will return 1 for success or 0 for failure */ written = BIO_write(statePtr->bio, buf, toWrite); dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written); + /* Get error is more comprehensive than SSL_want */ err = SSL_get_error(statePtr->ssl, written); backingError = ERR_get_error(); if (written <= 0) { if (BIO_should_retry(statePtr->bio)) { @@ -692,12 +704,12 @@ Tls_Error(statePtr, ERR_reason_error_string(backingError)); } break; case SSL_ERROR_ZERO_RETURN: - /* Peer has closed the connection for writing by sending the close_notify alert. No more data can be read. */ - dprintf(" closed"); + /* Peer has closed the connection by sending the close_notify alert. Can't read, but can write. */ + dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached"); written = 0; *errorCodePtr = 0; Tls_Error(statePtr, "Peer has closed the connection for writing by sending the close_notify alert"); break; @@ -718,20 +730,20 @@ dprintf("Output(%d) -> %d", toWrite, written); return written; } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * Tls_GetParent -- * * Get parent channel for a stacked channel. * * Results: * Tcl_Channel or NULL if none. * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ 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) { @@ -740,40 +752,41 @@ } return Tcl_GetStackedChannel(statePtr->self); } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsSetOptionProc -- * - * Sets an option value for a SSL socket based channel. + * Sets an option to value for a SSL socket based channel. Called by the + * generic I/O layer whenever the Tcl_SetChannelOption() function is used. * * Results: * TCL_OK if successful or TCL_ERROR if failed. * * Side effects: * Updates channel option to new value. * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ 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_Channel parent = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); Tcl_DriverSetOptionProc *setOptionProc; dprintf("Called"); - setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan)); + setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(parent)); if (setOptionProc != NULL) { - return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue); + return (*setOptionProc)(Tcl_GetChannelInstanceData(parent), interp, optionName, optionValue); } /* * Request for a specific option has to fail, we don't have any. */ return Tcl_BadChannelOption(interp, optionName, ""); @@ -782,17 +795,18 @@ /* *------------------------------------------------------------------- * * TlsGetOptionProc -- * - * Gets an option value for a SSL socket based channel, or a - * list of all options and their values. + * Get a option's value for a SSL socket based channel, or a list of all + * options and their values. Called by the generic I/O layer whenever the + * Tcl_GetChannelOption() function is used. + * * * 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. + * 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. * *------------------------------------------------------------------- @@ -803,18 +817,18 @@ const char *optionName, /* Name of the option to retrieve the value for, or * NULL to get all options and their values. */ Tcl_DString *optionValue) /* Where to store the computed value initialized by caller. */ { State *statePtr = (State *) instanceData; - Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + Tcl_Channel parent = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); Tcl_DriverGetOptionProc *getOptionProc; dprintf("Called"); - getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); + getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(parent)); if (getOptionProc != NULL) { - return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue); + return (*getOptionProc)(Tcl_GetChannelInstanceData(parent), interp, optionName, optionValue); } else if (optionName == (char*) NULL) { /* * Request is query for all options, this is ok. */ return TCL_OK; @@ -824,47 +838,49 @@ */ return Tcl_BadChannelOption(interp, optionName, ""); } /* - *------------------------------------------------------* + *----------------------------------------------------------------------------- * * TlsChannelHandlerTimer -- * - * ------------------------------------------------* - * Called by the notifier (-> timer) to flush out - * information waiting in channel buffers. - * ------------------------------------------------* - * - * Side effects: - * As of 'TlsChannelHandler'. - * - * Result: + * Called by the notifier via a timer, to flush out data waiting in + * channel buffers. called by the generic I/O layer whenever the + * Tcl_GetChannelHandle() function is used. + * + * Results: * None. * - *------------------------------------------------------* + * Side effects: + * Creates notification event. + * + *----------------------------------------------------------------------------- */ static void TlsChannelHandlerTimer(ClientData clientData) { State *statePtr = (State *) clientData; int mask = statePtr->want; /* Init to SSL_ERROR_WANT_READ and SSL_ERROR_WANT_WRITE */ dprintf("Called"); statePtr->timer = (Tcl_TimerToken) NULL; + /* Check for amount of data pending in BIO write buffer */ if (BIO_wpending(statePtr->bio)) { dprintf("[chan=%p] BIO writable", statePtr->self); mask |= TCL_WRITABLE; } + /* Check for amount of data pending in BIO read buffer */ if (BIO_pending(statePtr->bio)) { dprintf("[chan=%p] BIO readable", statePtr->self); mask |= TCL_READABLE; } + /* Notify event subsystem that the channel is readable or writeable */ dprintf("Notifying ourselves"); Tcl_NotifyChannel(statePtr->self, mask); statePtr->want = 0; dprintf("Returning"); @@ -871,32 +887,34 @@ return; } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsWatchProc -- * - * Initialize the event notifier to watch for events of interest - * from this channel. + * Set up the event notifier to watch for events of interest from this + * channel. Called by the generic I/O layer whenever the user (or the + * system) announces its (dis)interest in events on the channel. This is + * called repeatedly. * * Results: * None. * * Side effects: - * Sets up the notifier so that a future event on the channel - * will be seen by Tcl. + * Sets up the time-based notifier so that future events 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; + Tcl_Channel parent; State *statePtr = (State *) instanceData; Tcl_DriverWatchProc *watchProc; dprintf("TlsWatchProc(0x%x)", mask); dprintFlags(statePtr); @@ -906,18 +924,18 @@ if (statePtr->flags & TLS_TCL_CALLBACK) { dprintf("Callback is on-going, doing nothing"); return; } - downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + parent = 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"); - watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(downChan)); - watchProc(Tcl_GetChannelInstanceData(downChan), 0); + watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(parent)); + watchProc(Tcl_GetChannelInstanceData(parent), 0); statePtr->watchMask = 0; return; } statePtr->watchMask = mask; @@ -927,13 +945,13 @@ * '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); - watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(downChan)); - watchProc(Tcl_GetChannelInstanceData(downChan), mask); + dprintf("Registering our interest in the lower channel (chan=%p)", (void *) parent); + watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(parent)); + watchProc(Tcl_GetChannelInstanceData(parent), mask); /* * Management of the internal timer. */ @@ -953,24 +971,24 @@ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); } } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsGetHandleProc -- * - * This procedure is invoked by the generic IO level to retrieve a - * device-specific handle from the SSL socket based channel. + * This procedure is invoked by the generic IO level to retrieve an OS + * specific handle associated with the channel. Not used for transforms. * * Results: * The appropriate Tcl_File handle or NULL if none. * * Side effects: * None. * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static int TlsGetHandleProc(ClientData instanceData, /* Socket state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Handle associated with the channel */ { @@ -978,26 +996,26 @@ return Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr); } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * TlsNotifyProc -- * - * This procedure is invoked by the generic IO level to notify the - * channel that an event occurred. It is used by stacked channel - * drivers that wish to be notified of events that occur on the - * underlying (stacked) channel. + * This procedure is invoked by the generic IO level to notify the channel + * that an event has occurred on the underlying channel. It is used by stacked channel drivers that + * wish to be notified of events that occur on the underlying (stacked) + * channel. * * Results: * Type of event or 0 if failed * * Side effects: * May process the incoming event by itself. * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static int TlsNotifyProc(ClientData instanceData, /* Socket state. */ int mask) /* type of event that occurred: * OR-ed combination of TCL_READABLE or TCL_WRITABLE */ { @@ -1005,22 +1023,17 @@ int errorCode = 0; dprintf("Called"); /* - * An event occurred in the underlying channel. This - * transformation doesn't process such events thus returns the - * incoming mask unchanged. + * 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). */ 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; } /* Skip if user verify callback is still running */ @@ -1044,27 +1057,32 @@ } } dprintf("Returning %i", mask); + /* + * An event occurred in the underlying channel. This + * transformation doesn't process such events thus returns the + * incoming mask unchanged. + */ return mask; } /* - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * Tls_ChannelType -- * - * Return the correct TLS channel driver info + * Defines the correct TLS channel driver handlers for this channel type. * * Results: - * The correct channel driver for the current version of Tcl. + * Tcl_ChannelType structure. * * Side effects: * None. * - *------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static const Tcl_ChannelType tlsChannelType = { "tls", /* Type name */ TCL_CHANNEL_VERSION_5, /* v5 channel */ TlsCloseProc, /* Close proc */ Index: generic/tlsInt.h ================================================================== --- generic/tlsInt.h +++ generic/tlsInt.h @@ -187,12 +187,12 @@ 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) */ - unsigned char *protos; /* List of supported protocols in protocol format */ unsigned int protos_len; /* Length of protos */ + unsigned char *protos; /* List of supported protocols in protocol format */ const char *err; } State; #ifdef USE_TCL_STUBS @@ -219,9 +219,10 @@ void Tls_Free(tls_free_type *blockPtr); void Tls_Clean(State *statePtr); int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent); BIO *BIO_new_tcl(State* statePtr, int flags); +int BIO_cleanup(); #define PTR2INT(x) ((int) ((intptr_t) (x))) #endif /* _TLSINT_H */ Index: generic/tlsX509.c ================================================================== --- generic/tlsX509.c +++ generic/tlsX509.c @@ -18,19 +18,23 @@ /* Define maximum certificate size. Max PEM size 100kB and DER size is 24kB. */ #define CERT_STR_SIZE 24576 /* + *----------------------------------------------------------------------------- + * * String_to_Hex -- + * * Format contents of a binary string as a hex string * * Results: * TCL byte array object with x509 identifier as a hex string * * Side Effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *String_to_Hex(unsigned char* input, int ilen) { unsigned char *iptr = input; Tcl_Obj *resultObj = Tcl_NewByteArrayObj(NULL, 0); unsigned char *data = Tcl_SetByteArrayLength(resultObj, ilen*2); @@ -47,19 +51,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * BIO_to_Buffer -- + * * Output contents of a BIO to a buffer * * Results: * Returns length of string in buffer * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Size BIO_to_Buffer(int result, BIO *bio, void *output, int olen) { Tcl_Size len = 0; int pending = BIO_pending(bio); @@ -72,19 +80,23 @@ } return len; } /* + *----------------------------------------------------------------------------- + * * Tls_x509Extensions -- + * * Get list of X.509 Certificate Extensions * * Results: * TCL list of extensions and boolean critical status * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509Extensions(Tcl_Interp *interp, X509 *cert) { const STACK_OF(X509_EXTENSION) *exts; Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); @@ -103,19 +115,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509Identifier -- + * * Get X.509 certificate Authority or Subject Key Identifiers * * Results: * TCL byte array object with x509 identifier as a hex string * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509Identifier(const ASN1_OCTET_STRING *astring) { Tcl_Obj *resultObj = NULL; if (astring != NULL) { @@ -124,19 +140,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509KeyUsage -- + * * Get X.509 certificate key usage types * * Results: * Tcl list of types * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509KeyUsage(Tcl_Interp *interp, X509 *cert, uint32_t xflags) { uint32_t usage = X509_get_key_usage(cert); Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); @@ -177,19 +197,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509Purpose -- + * * Get X.509 certificate purpose * * Results: * Purpose string * * Side effects: * None * + *----------------------------------------------------------------------------- */ char *Tls_x509Purpose(X509 *cert) { char *purpose = NULL; if (X509_check_purpose(cert, X509_PURPOSE_SSL_CLIENT, 0) > 0) { @@ -215,19 +239,23 @@ } return purpose; } /* + *----------------------------------------------------------------------------- + * * Tls_x509Purposes -- + * * Get X.509 certificate purpose types * * Results: * Tcl list of each purpose and whether it is CA or non-CA * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509Purposes(Tcl_Interp *interp, X509 *cert) { Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); X509_PURPOSE *ptmp; @@ -248,19 +276,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509Names -- + * * Get a list of Subject Alternate Names (SAN) or Issuer Alternate Names * * Results: * Tcl list of alternate names * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509Names(Tcl_Interp *interp, X509 *cert, int nid, BIO *bio) { STACK_OF(GENERAL_NAME) *names; Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); Tcl_Size len; @@ -281,19 +313,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509ExtKeyUsage -- + * * Get a list of Extended Key Usages * * Returns: * Tcl list of usages * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509ExtKeyUsage(Tcl_Interp *interp, X509 *cert, uint32_t xflags) { uint32_t usage = X509_get_key_usage(cert); Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); @@ -336,19 +372,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509CrlDp -- + * * Get list of CRL Distribution Points * * Returns: * Tcl list of URIs and relative-names * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509CrlDp(Tcl_Interp *interp, X509 *cert) { STACK_OF(DIST_POINT) *crl; Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); @@ -385,19 +425,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509Oscp + * * Get list of On-line Certificate Status Protocol (OSCP) URIs * * Results: * Tcl list of URIs * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509Oscp(Tcl_Interp *interp, X509 *cert) { STACK_OF(OPENSSL_STRING) *ocsp; Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); @@ -413,19 +457,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_x509CaIssuers -- + * * Get list of Certificate Authority (CA) Issuer URIs * * Results: * Tcl list of CA issuer URIs * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_x509CaIssuers(Tcl_Interp *interp, X509 *cert) { STACK_OF(ACCESS_DESCRIPTION) *ads; ACCESS_DESCRIPTION *ad; Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); @@ -452,19 +500,23 @@ } return resultObj; } /* + *----------------------------------------------------------------------------- + * * Tls_NewX509Obj -- + * * Parses a X509 certificate and returns contents as a key-value Tcl list. * * Result: * A Tcl List with the X509 certificate info as a key-value list * * Side effects: * None * + *----------------------------------------------------------------------------- */ Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert, int all) { Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); BIO *bio = BIO_new(BIO_s_mem()); int mdnid, pknid, bits;