1/* 2 * Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> 3 * Copyright (C) 2000 Ajuba Solutions 4 * 5 * $Header: /cvsroot/tls/tls/tlsIO.c,v 1.16 2007/06/22 21:20:38 hobbs2 Exp $ 6 * 7 * TLS (aka SSL) Channel - can be layered on any bi-directional 8 * Tcl_Channel (Note: Requires Trf Core Patch) 9 * 10 * This was built from scratch based upon observation of OpenSSL 0.9.2B 11 * 12 * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for 13 * providing the Tcl_ReplaceChannel mechanism and working closely with me 14 * to enhance it to support full fileevent semantics. 15 * 16 * Also work done by the follow people provided the impetus to do this "right": 17 * tclSSL (Colin McCormack, Shared Technology) 18 * SSLtcl (Peter Antman) 19 * 20 */ 21 22#include "tlsInt.h" 23 24/* 25 * Forward declarations 26 */ 27 28static int TlsBlockModeProc _ANSI_ARGS_((ClientData instanceData, 29 int mode)); 30static int TlsCloseProc _ANSI_ARGS_ ((ClientData instanceData, 31 Tcl_Interp *interp)); 32static int TlsInputProc _ANSI_ARGS_((ClientData instanceData, 33 char *buf, int bufSize, int *errorCodePtr)); 34static int TlsOutputProc _ANSI_ARGS_((ClientData instanceData, 35 CONST char *buf, int toWrite, int *errorCodePtr)); 36static int TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData, 37 Tcl_Interp *interp, CONST84 char *optionName, 38 Tcl_DString *dsPtr)); 39static void TlsWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); 40static int TlsGetHandleProc _ANSI_ARGS_ ((ClientData instanceData, 41 int direction, ClientData *handlePtr)); 42static int TlsNotifyProc _ANSI_ARGS_ ((ClientData instanceData, 43 int mask)); 44static void TlsChannelHandler _ANSI_ARGS_ ((ClientData clientData, 45 int mask)); 46static void TlsChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData)); 47 48/* 49 * This structure describes the channel type structure for TCP socket 50 * based IO. These are what the structures should look like, but we 51 * have to build them up at runtime to be correct depending on whether 52 * we are loaded into an 8.2.0-8.3.1 or 8.3.2+ Tcl interpreter. 53 */ 54#ifdef TLS_STATIC_STRUCTURES_NOT_USED 55static Tcl_ChannelType tlsChannelType2 = { 56 "tls", /* Type name. */ 57 TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2+) */ 58 TlsCloseProc, /* Close proc. */ 59 TlsInputProc, /* Input proc. */ 60 TlsOutputProc, /* Output proc. */ 61 NULL, /* Seek proc. */ 62 NULL, /* Set option proc. */ 63 TlsGetOptionProc, /* Get option proc. */ 64 TlsWatchProc, /* Initialize notifier. */ 65 TlsGetHandleProc, /* Get file handle out of channel. */ 66 NULL, /* Close2Proc. */ 67 TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ 68 NULL, /* FlushProc. */ 69 TlsNotifyProc, /* handlerProc. */ 70}; 71 72static Tcl_ChannelType tlsChannelType1 = { 73 "tls", /* Type name. */ 74 TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ 75 TlsCloseProc, /* Close proc. */ 76 TlsInputProc, /* Input proc. */ 77 TlsOutputProc, /* Output proc. */ 78 NULL, /* Seek proc. */ 79 NULL, /* Set option proc. */ 80 TlsGetOptionProc, /* Get option proc. */ 81 TlsWatchProc, /* Initialize notifier. */ 82 TlsGetHandleProc, /* Get file handle out of channel. */ 83}; 84#else 85static Tcl_ChannelType *tlsChannelType = NULL; 86#endif 87 88/* 89 *------------------------------------------------------------------- 90 * 91 * Tls_ChannelType -- 92 * 93 * Return the correct TLS channel driver info 94 * 95 * Results: 96 * The correct channel driver for the current version of Tcl. 97 * 98 * Side effects: 99 * None. 100 * 101 *------------------------------------------------------------------- 102 */ 103Tcl_ChannelType *Tls_ChannelType() 104{ 105 /* 106 * Initialize the channel type if necessary 107 */ 108 if (tlsChannelType == NULL) { 109 /* 110 * Allocation of a new channeltype structure is not easy, because of 111 * the various verson of the core and subsequent changes to the 112 * structure. The main challenge is to allocate enough memory for 113 * odern versions even if this extyension is compiled against one 114 * of the older variant! 115 * 116 * (1) Versions before stubs (8.0.x) are simple, because they are 117 * supported only if the extension is compiled against exactly 118 * that version of the core. 119 * 120 * (2) With stubs we just determine the difference between the older 121 * and modern variant and overallocate accordingly if compiled 122 * against an older variant. 123 */ 124 125 unsigned int size = sizeof(Tcl_ChannelType); /* Base size */ 126 127 /* 128 * Size of a procedure pointer. We assume that all procedure 129 * pointers are of the same size, regardless of exact type 130 * (arguments and return values). 131 * 132 * 8.2. First version containing close2proc. Baseline. 133 * 8.3.2 Three additional vectors. Moved blockMode, new flush- and 134 * handlerProc's. 135 * 136 * => Compilation against earlier version has to overallocate three 137 * procedure pointers. 138 */ 139 140#ifdef EMULATE_CHANNEL_VERSION_2 141 size += 3 * procPtrSize; 142#endif 143 144 tlsChannelType = (Tcl_ChannelType *) ckalloc(size); 145 memset((VOID *) tlsChannelType, 0, size); 146 147 /* 148 * Common elements of the structure (no changes in location or name) 149 * close2Proc, seekProc, setOptionProc stay NULL. 150 */ 151 152 tlsChannelType->typeName = "tls"; 153 tlsChannelType->closeProc = TlsCloseProc; 154 tlsChannelType->inputProc = TlsInputProc; 155 tlsChannelType->outputProc = TlsOutputProc; 156 tlsChannelType->getOptionProc = TlsGetOptionProc; 157 tlsChannelType->watchProc = TlsWatchProc; 158 tlsChannelType->getHandleProc = TlsGetHandleProc; 159 160 /* 161 * blockModeProc is a twister. We have to make some runtime-choices, 162 * depending on the version we compiled against. 163 */ 164 165#ifdef EMULATE_CHANNEL_VERSION_2 166 /* 167 * We are compiling against an 8.3.1- core. We have to create some 168 * definitions for the new elements as the compiler does not know them 169 * by name. 170 */ 171 172 if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { 173 /* 174 * The 'version' element of 8.3.2 is in the the place of the 175 * blockModeProc. For 8.2.0-8.3.1 we have to set our blockModeProc 176 * into this place. 177 */ 178 tlsChannelType->blockModeProc = TlsBlockModeProc; 179 } else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ { 180 /* 181 * For the 8.3.2 core we present ourselves as a version 2 182 * driver. This means a special value in version (ex 183 * blockModeProc), blockModeProc in a different place and of 184 * course usage of the handlerProc. The last two have to 185 * referenced with pointer magic because they aren't defined 186 * otherwise. 187 */ 188 189 tlsChannelType->blockModeProc = 190 (Tcl_DriverBlockModeProc*) TLS_CHANNEL_VERSION_2; 191 (*((Tcl_DriverBlockModeProc**)(&(tlsChannelType->close2Proc)+1))) 192 = TlsBlockModeProc; 193 (*((TlsDriverHandlerProc**)(&(tlsChannelType->close2Proc)+3))) 194 = TlsNotifyProc; 195 } 196#else 197 /* 198 * Compiled against 8.3.2+. Direct access to all elements possible. Use 199 * channelTypeVersion information to select the values to use. 200 */ 201 202 if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { 203 /* 204 * The 'version' element of 8.3.2 is in the the place of the 205 * blockModeProc. For the original patch in 8.1.x and the firstly 206 * included (8.2) we have to set our blockModeProc into this 207 * place. 208 */ 209 tlsChannelType->version = (Tcl_ChannelTypeVersion)TlsBlockModeProc; 210 } else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ { 211 /* 212 * For the 8.3.2 core we present ourselves as a version 2 213 * driver. This means a special value in version (ex 214 * blockModeProc), blockModeProc in a different place and of 215 * course usage of the handlerProc. 216 */ 217 218 tlsChannelType->version = TCL_CHANNEL_VERSION_2; 219 tlsChannelType->blockModeProc = TlsBlockModeProc; 220 tlsChannelType->handlerProc = TlsNotifyProc; 221 } 222#endif 223 } 224 return tlsChannelType; 225} 226 227/* 228 *------------------------------------------------------------------- 229 * 230 * TlsBlockModeProc -- 231 * 232 * This procedure is invoked by the generic IO level 233 * to set blocking and nonblocking modes 234 * Results: 235 * 0 if successful, errno when failed. 236 * 237 * Side effects: 238 * Sets the device into blocking or nonblocking mode. 239 * 240 *------------------------------------------------------------------- 241 */ 242 243static int 244TlsBlockModeProc(ClientData instanceData, /* Socket state. */ 245 int mode) /* The mode to set. Can be one of 246 * TCL_MODE_BLOCKING or 247 * TCL_MODE_NONBLOCKING. */ 248{ 249 State *statePtr = (State *) instanceData; 250 251 if (mode == TCL_MODE_NONBLOCKING) { 252 statePtr->flags |= TLS_TCL_ASYNC; 253 } else { 254 statePtr->flags &= ~(TLS_TCL_ASYNC); 255 } 256 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 257 return 0; 258 } else { 259 return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr), 260 "-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1"); 261 } 262} 263 264/* 265 *------------------------------------------------------------------- 266 * 267 * TlsCloseProc -- 268 * 269 * This procedure is invoked by the generic IO level to perform 270 * channel-type-specific cleanup when a SSL socket based channel 271 * is closed. 272 * 273 * Note: we leave the underlying socket alone, is this right? 274 * 275 * Results: 276 * 0 if successful, the value of Tcl_GetErrno() if failed. 277 * 278 * Side effects: 279 * Closes the socket of the channel. 280 * 281 *------------------------------------------------------------------- 282 */ 283static int 284TlsCloseProc(ClientData instanceData, /* The socket to close. */ 285 Tcl_Interp *interp) /* For error reporting - unused. */ 286{ 287 State *statePtr = (State *) instanceData; 288 289 dprintf(stderr,"\nTlsCloseProc(0x%x)", (unsigned int) statePtr); 290 291 if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { 292 /* 293 * Remove event handler to underlying channel, this could 294 * be because we are closing for real, or being "unstacked". 295 */ 296 297 Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), 298 TlsChannelHandler, (ClientData) statePtr); 299 } 300 301 Tls_Clean(statePtr); 302 Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); 303 return TCL_OK; 304} 305 306/* 307 *------------------------------------------------------------------- 308 * 309 * TlsInputProc -- 310 * 311 * This procedure is invoked by the generic IO level 312 * to read input from a SSL socket based channel. 313 * 314 * Results: 315 * The number of bytes read is returned or -1 on error. An output 316 * argument contains the POSIX error code on error, or zero if no 317 * error occurred. 318 * 319 * Side effects: 320 * Reads input from the input device of the channel. 321 * 322 *------------------------------------------------------------------- 323 */ 324 325static int 326TlsInputProc(ClientData instanceData, /* Socket state. */ 327 char *buf, /* Where to store data read. */ 328 int bufSize, /* How much space is available 329 * in the buffer? */ 330 int *errorCodePtr) /* Where to store error code. */ 331{ 332 State *statePtr = (State *) instanceData; 333 int bytesRead; /* How many bytes were read? */ 334 335 *errorCodePtr = 0; 336 337 dprintf(stderr,"\nBIO_read(%d)", bufSize); 338 339 if (statePtr->flags & TLS_TCL_CALLBACK) { 340 /* don't process any bytes while verify callback is running */ 341 bytesRead = 0; 342 goto input; 343 } 344 345 if (!SSL_is_init_finished(statePtr->ssl)) { 346 bytesRead = Tls_WaitForConnect(statePtr, errorCodePtr); 347 if (bytesRead <= 0) { 348 goto input; 349 } 350 } 351 if (statePtr->flags & TLS_TCL_INIT) { 352 statePtr->flags &= ~(TLS_TCL_INIT); 353 } 354 /* 355 * We need to clear the SSL error stack now because we sometimes reach 356 * this function with leftover errors in the stack. If BIO_read 357 * returns -1 and intends EAGAIN, there is a leftover error, it will be 358 * misconstrued as an error, not EAGAIN. 359 * 360 * Alternatively, we may want to handle the <0 return codes from 361 * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO 362 * functions play with the retry flags though, and this seems to work 363 * correctly. Similar fix in TlsOutputProc. - hobbs 364 */ 365 ERR_clear_error(); 366 bytesRead = BIO_read(statePtr->bio, buf, bufSize); 367 dprintf(stderr,"\nBIO_read -> %d", bytesRead); 368 369 if (bytesRead < 0) { 370 int err = SSL_get_error(statePtr->ssl, bytesRead); 371 372 if (err == SSL_ERROR_SSL) { 373 Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, bytesRead)); 374 *errorCodePtr = ECONNABORTED; 375 } else if (BIO_should_retry(statePtr->bio)) { 376 dprintf(stderr,"RE! "); 377 *errorCodePtr = EAGAIN; 378 } else { 379 *errorCodePtr = Tcl_GetErrno(); 380 if (*errorCodePtr == ECONNRESET) { 381 /* Soft EOF */ 382 *errorCodePtr = 0; 383 bytesRead = 0; 384 } 385 } 386 } 387 input: 388 dprintf(stderr, "\nInput(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr); 389 return bytesRead; 390} 391 392/* 393 *------------------------------------------------------------------- 394 * 395 * TlsOutputProc -- 396 * 397 * This procedure is invoked by the generic IO level 398 * to write output to a SSL socket based channel. 399 * 400 * Results: 401 * The number of bytes written is returned. An output argument is 402 * set to a POSIX error code if an error occurred, or zero. 403 * 404 * Side effects: 405 * Writes output on the output device of the channel. 406 * 407 *------------------------------------------------------------------- 408 */ 409 410static int 411TlsOutputProc(ClientData instanceData, /* Socket state. */ 412 CONST char *buf, /* The data buffer. */ 413 int toWrite, /* How many bytes to write? */ 414 int *errorCodePtr) /* Where to store error code. */ 415{ 416 State *statePtr = (State *) instanceData; 417 int written, err; 418 419 *errorCodePtr = 0; 420 421 dprintf(stderr,"\nBIO_write(0x%x, %d)", (unsigned int) statePtr, toWrite); 422 423 if (statePtr->flags & TLS_TCL_CALLBACK) { 424 /* don't process any bytes while verify callback is running */ 425 written = -1; 426 *errorCodePtr = EAGAIN; 427 goto output; 428 } 429 430 if (!SSL_is_init_finished(statePtr->ssl)) { 431 written = Tls_WaitForConnect(statePtr, errorCodePtr); 432 if (written <= 0) { 433 goto output; 434 } 435 } 436 if (statePtr->flags & TLS_TCL_INIT) { 437 statePtr->flags &= ~(TLS_TCL_INIT); 438 } 439 if (toWrite == 0) { 440 dprintf(stderr, "zero-write\n"); 441 BIO_flush(statePtr->bio); 442 written = 0; 443 goto output; 444 } else { 445 /* 446 * We need to clear the SSL error stack now because we sometimes reach 447 * this function with leftover errors in the stack. If BIO_write 448 * returns -1 and intends EAGAIN, there is a leftover error, it will be 449 * misconstrued as an error, not EAGAIN. 450 * 451 * Alternatively, we may want to handle the <0 return codes from 452 * BIO_write specially (as advised in the RSA docs). TLS's lower level 453 * BIO functions play with the retry flags though, and this seems to 454 * work correctly. Similar fix in TlsInputProc. - hobbs 455 */ 456 ERR_clear_error(); 457 written = BIO_write(statePtr->bio, buf, toWrite); 458 dprintf(stderr,"\nBIO_write(0x%x, %d) -> [%d]", 459 (unsigned int) statePtr, toWrite, written); 460 } 461 if (written <= 0) { 462 switch ((err = SSL_get_error(statePtr->ssl, written))) { 463 case SSL_ERROR_NONE: 464 if (written < 0) { 465 written = 0; 466 } 467 break; 468 case SSL_ERROR_WANT_WRITE: 469 dprintf(stderr," write W BLOCK"); 470 break; 471 case SSL_ERROR_WANT_READ: 472 dprintf(stderr," write R BLOCK"); 473 break; 474 case SSL_ERROR_WANT_X509_LOOKUP: 475 dprintf(stderr," write X BLOCK"); 476 break; 477 case SSL_ERROR_ZERO_RETURN: 478 dprintf(stderr," closed\n"); 479 written = 0; 480 break; 481 case SSL_ERROR_SYSCALL: 482 *errorCodePtr = Tcl_GetErrno(); 483 dprintf(stderr," [%d] syscall errr: %d", 484 written, *errorCodePtr); 485 written = -1; 486 break; 487 case SSL_ERROR_SSL: 488 Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written)); 489 *errorCodePtr = ECONNABORTED; 490 written = -1; 491 break; 492 default: 493 dprintf(stderr," unknown err: %d\n", err); 494 break; 495 } 496 } 497 output: 498 dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written); 499 return written; 500} 501 502/* 503 *------------------------------------------------------------------- 504 * 505 * TlsGetOptionProc -- 506 * 507 * Computes an option value for a SSL socket based channel, or a 508 * list of all options and their values. 509 * 510 * Results: 511 * A standard Tcl result. The value of the specified option or a 512 * list of all options and their values is returned in the 513 * supplied DString. 514 * 515 * Side effects: 516 * None. 517 * 518 *------------------------------------------------------------------- 519 */ 520static int 521TlsGetOptionProc(ClientData instanceData, /* Socket state. */ 522 Tcl_Interp *interp, /* For errors - can be NULL. */ 523 CONST84 char *optionName, /* Name of the option to 524 * retrieve the value for, or 525 * NULL to get all options and 526 * their values. */ 527 Tcl_DString *dsPtr) /* Where to store the computed value 528 * initialized by caller. */ 529{ 530 State *statePtr = (State *) instanceData; 531 532 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 533 Tcl_Channel downChan = Tls_GetParent(statePtr); 534 Tcl_DriverGetOptionProc *getOptionProc; 535 536 getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); 537 if (getOptionProc != NULL) { 538 return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), 539 interp, optionName, dsPtr); 540 } else if (optionName == (char*) NULL) { 541 /* 542 * Request is query for all options, this is ok. 543 */ 544 return TCL_OK; 545 } 546 /* 547 * Request for a specific option has to fail, we don't have any. 548 */ 549 return TCL_ERROR; 550 } else { 551 size_t len = 0; 552 553 if (optionName != (char *) NULL) { 554 len = strlen(optionName); 555 } 556#if 0 557 if ((len == 0) || ((len > 1) && (optionName[1] == 'c') && 558 (strncmp(optionName, "-cipher", len) == 0))) { 559 if (len == 0) { 560 Tcl_DStringAppendElement(dsPtr, "-cipher"); 561 } 562 Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl)); 563 if (len) { 564 return TCL_OK; 565 } 566 } 567#endif 568 return TCL_OK; 569 } 570} 571 572/* 573 *------------------------------------------------------------------- 574 * 575 * TlsWatchProc -- 576 * 577 * Initialize the notifier to watch Tcl_Files from this channel. 578 * 579 * Results: 580 * None. 581 * 582 * Side effects: 583 * Sets up the notifier so that a future event on the channel 584 * will be seen by Tcl. 585 * 586 *------------------------------------------------------------------- 587 */ 588 589static void 590TlsWatchProc(ClientData instanceData, /* The socket state. */ 591 int mask) /* Events of interest; an OR-ed 592 * combination of TCL_READABLE, 593 * TCL_WRITABLE and TCL_EXCEPTION. */ 594{ 595 State *statePtr = (State *) instanceData; 596 597 dprintf(stderr, "TlsWatchProc(0x%x)\n", mask); 598 599 /* Pretend to be dead as long as the verify callback is running. 600 * Otherwise that callback could be invoked recursively. */ 601 if (statePtr->flags & TLS_TCL_CALLBACK) { return; } 602 603 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 604 Tcl_Channel downChan; 605 606 statePtr->watchMask = mask; 607 608 /* No channel handlers any more. We will be notified automatically 609 * about events on the channel below via a call to our 610 * 'TransformNotifyProc'. But we have to pass the interest down now. 611 * We are allowed to add additional 'interest' to the mask if we want 612 * to. But this transformation has no such interest. It just passes 613 * the request down, unchanged. 614 */ 615 616 downChan = Tls_GetParent(statePtr); 617 618 (Tcl_GetChannelType(downChan)) 619 ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); 620 621 /* 622 * Management of the internal timer. 623 */ 624 625 if (statePtr->timer != (Tcl_TimerToken) NULL) { 626 Tcl_DeleteTimerHandler(statePtr->timer); 627 statePtr->timer = (Tcl_TimerToken) NULL; 628 } 629 if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { 630 /* 631 * There is interest in readable events and we actually have 632 * data waiting, so generate a timer to flush that. 633 */ 634 statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, 635 TlsChannelHandlerTimer, (ClientData) statePtr); 636 } 637 } else { 638 if (mask == statePtr->watchMask) 639 return; 640 641 if (statePtr->watchMask) { 642 /* 643 * Remove event handler to underlying channel, this could 644 * be because we are closing for real, or being "unstacked". 645 */ 646 647 Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), 648 TlsChannelHandler, (ClientData) statePtr); 649 } 650 statePtr->watchMask = mask; 651 if (statePtr->watchMask) { 652 /* 653 * Setup active monitor for events on underlying Channel. 654 */ 655 656 Tcl_CreateChannelHandler(Tls_GetParent(statePtr), 657 statePtr->watchMask, TlsChannelHandler, 658 (ClientData) statePtr); 659 } 660 } 661} 662 663/* 664 *------------------------------------------------------------------- 665 * 666 * TlsGetHandleProc -- 667 * 668 * Called from Tcl_GetChannelFile to retrieve o/s file handler 669 * from the SSL socket based channel. 670 * 671 * Results: 672 * The appropriate Tcl_File or NULL if not present. 673 * 674 * Side effects: 675 * None. 676 * 677 *------------------------------------------------------------------- 678 */ 679static int 680TlsGetHandleProc(ClientData instanceData, /* The socket state. */ 681 int direction, /* Which Tcl_File to retrieve? */ 682 ClientData *handlePtr) /* Where to store the handle. */ 683{ 684 State *statePtr = (State *) instanceData; 685 686 return Tcl_GetChannelHandle(Tls_GetParent(statePtr), direction, handlePtr); 687} 688 689/* 690 *------------------------------------------------------------------- 691 * 692 * TlsNotifyProc -- 693 * 694 * Handler called by Tcl to inform us of activity 695 * on the underlying channel. 696 * 697 * Results: 698 * None. 699 * 700 * Side effects: 701 * May process the incoming event by itself. 702 * 703 *------------------------------------------------------------------- 704 */ 705 706static int 707TlsNotifyProc(instanceData, mask) 708 ClientData instanceData; /* The state of the notified transformation */ 709 int mask; /* The mask of occuring events */ 710{ 711 State *statePtr = (State *) instanceData; 712 713 /* 714 * An event occured in the underlying channel. This 715 * transformation doesn't process such events thus returns the 716 * incoming mask unchanged. 717 */ 718 719 if (statePtr->timer != (Tcl_TimerToken) NULL) { 720 /* 721 * Delete an existing timer. It was not fired, yet we are 722 * here, so the channel below generated such an event and we 723 * don't have to. The renewal of the interest after the 724 * execution of channel handlers will eventually cause us to 725 * recreate the timer (in WatchProc). 726 */ 727 728 Tcl_DeleteTimerHandler(statePtr->timer); 729 statePtr->timer = (Tcl_TimerToken) NULL; 730 } 731 732 return mask; 733} 734 735/* 736 *------------------------------------------------------* 737 * 738 * TlsChannelHandler -- 739 * 740 * ------------------------------------------------* 741 * Handler called by Tcl as a result of 742 * Tcl_CreateChannelHandler - to inform us of activity 743 * on the underlying channel. 744 * ------------------------------------------------* 745 * 746 * Sideeffects: 747 * May generate subsequent calls to 748 * Tcl_NotifyChannel. 749 * 750 * Result: 751 * None. 752 * 753 *------------------------------------------------------* 754 */ 755 756static void 757TlsChannelHandler (clientData, mask) 758 ClientData clientData; 759 int mask; 760{ 761 State *statePtr = (State *) clientData; 762 763dprintf(stderr, "HANDLER(0x%x)\n", mask); 764 Tcl_Preserve( (ClientData)statePtr); 765 766 if (mask & TCL_READABLE) { 767 BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ); 768 } else { 769 BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ); 770 } 771 772 if (mask & TCL_WRITABLE) { 773 BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE); 774 } else { 775 BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE); 776 } 777 778 mask = 0; 779 if (BIO_wpending(statePtr->bio)) { 780 mask |= TCL_WRITABLE; 781 } 782 if (BIO_pending(statePtr->bio)) { 783 mask |= TCL_READABLE; 784 } 785 786 /* 787 * The following NotifyChannel calls seems to be important, but 788 * we don't know why. It looks like if the mask is ever non-zero 789 * that it will enter an infinite loop. 790 * 791 * Notify the upper channel of the current BIO state so the event 792 * continues to propagate up the chain. 793 * 794 * stanton: It looks like this could result in an infinite loop if 795 * the upper channel doesn't cause ChannelHandler to be removed 796 * before Tcl_NotifyChannel calls channel handlers on the lower channel. 797 */ 798 799 Tcl_NotifyChannel(statePtr->self, mask); 800 801 if (statePtr->timer != (Tcl_TimerToken)NULL) { 802 Tcl_DeleteTimerHandler(statePtr->timer); 803 statePtr->timer = (Tcl_TimerToken)NULL; 804 } 805 if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { 806 /* 807 * Data is waiting, flush it out in short time 808 */ 809 statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, 810 TlsChannelHandlerTimer, (ClientData) statePtr); 811 } 812 Tcl_Release( (ClientData)statePtr); 813} 814 815/* 816 *------------------------------------------------------* 817 * 818 * TlsChannelHandlerTimer -- 819 * 820 * ------------------------------------------------* 821 * Called by the notifier (-> timer) to flush out 822 * information waiting in channel buffers. 823 * ------------------------------------------------* 824 * 825 * Sideeffects: 826 * As of 'TlsChannelHandler'. 827 * 828 * Result: 829 * None. 830 * 831 *------------------------------------------------------* 832 */ 833 834static void 835TlsChannelHandlerTimer (clientData) 836ClientData clientData; /* Transformation to query */ 837{ 838 State *statePtr = (State *) clientData; 839 int mask = 0; 840 841 statePtr->timer = (Tcl_TimerToken) NULL; 842 843 if (BIO_wpending(statePtr->bio)) { 844 mask |= TCL_WRITABLE; 845 } 846 if (BIO_pending(statePtr->bio)) { 847 mask |= TCL_READABLE; 848 } 849 Tcl_NotifyChannel(statePtr->self, mask); 850} 851 852/* 853 *------------------------------------------------------* 854 * 855 * Tls_WaitForConnect -- 856 * 857 * Sideeffects: 858 * Issues SSL_accept or SSL_connect 859 * 860 * Result: 861 * None. 862 * 863 *------------------------------------------------------* 864 */ 865int 866Tls_WaitForConnect( statePtr, errorCodePtr) 867 State *statePtr; 868 int *errorCodePtr; /* Where to store error code. */ 869{ 870 int err; 871 872 dprintf(stderr,"\nWaitForConnect(0x%x)", (unsigned int) statePtr); 873 874 for (;;) { 875 /* Not initialized yet! */ 876 if (statePtr->flags & TLS_TCL_SERVER) { 877 err = SSL_accept(statePtr->ssl); 878 } else { 879 err = SSL_connect(statePtr->ssl); 880 } 881 /*SSL_write(statePtr->ssl, (char*)&err, 0); HACK!!! */ 882 if (err > 0) { 883 BIO_flush(statePtr->bio); 884 } 885 886 if (err <= 0) { 887 int rc = SSL_get_error(statePtr->ssl, err); 888 889 if (rc == SSL_ERROR_SSL) { 890 Tls_Error(statePtr, 891 (char *)ERR_reason_error_string(ERR_get_error())); 892 *errorCodePtr = ECONNABORTED; 893 return -1; 894 } else if (BIO_should_retry(statePtr->bio)) { 895 if (statePtr->flags & TLS_TCL_ASYNC) { 896 dprintf(stderr,"E! "); 897 *errorCodePtr = EAGAIN; 898 return -1; 899 } else { 900 continue; 901 } 902 } else if (err == 0) { 903 dprintf(stderr,"CR! "); 904 *errorCodePtr = ECONNRESET; 905 return -1; 906 } 907 if (statePtr->flags & TLS_TCL_SERVER) { 908 err = SSL_get_verify_result(statePtr->ssl); 909 if (err != X509_V_OK) { 910 Tls_Error(statePtr, 911 (char *)X509_verify_cert_error_string(err)); 912 *errorCodePtr = ECONNABORTED; 913 return -1; 914 } 915 } 916 *errorCodePtr = Tcl_GetErrno(); 917 dprintf(stderr,"ERR(%d, %d) ", rc, *errorCodePtr); 918 return -1; 919 } 920 dprintf(stderr,"R0! "); 921 return 1; 922 } 923} 924 925Tcl_Channel 926Tls_GetParent( statePtr ) 927 State *statePtr; 928{ 929 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 930 return Tcl_GetStackedChannel(statePtr->self); 931 } else { 932 /* The reason for the existence of this procedure is 933 * the fact that stacking a transform over another 934 * transform will leave our internal pointer unchanged, 935 * and thus pointing to the new transform, and not the 936 * Channel structure containing the saved state of this 937 * transform. This is the price to pay for leaving 938 * Tcl_Channel references intact. The only other solution 939 * is an extension of Tcl_ChannelType with another driver 940 * procedure to notify a Channel about the (un)stacking. 941 * 942 * It walks the chain of Channel structures until it 943 * finds the one pointing having 'ctrl' as instanceData 944 * and then returns the superceding channel to that. (AK) 945 */ 946 947 Tcl_Channel self = statePtr->self; 948 Tcl_Channel next; 949 950 while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { 951 next = Tcl_GetStackedChannel (self); 952 if (next == (Tcl_Channel) NULL) { 953 /* 09/24/1999 Unstacking bug, 954 * found by Matt Newman <matt@sensus.org>. 955 * 956 * We were unable to find the channel structure for this 957 * transformation in the chain of stacked channel. This 958 * means that we are currently in the process of unstacking 959 * it *and* there were some bytes waiting which are now 960 * flushed. In this situation the pointer to the channel 961 * itself already refers to the parent channel we have to 962 * write the bytes into, so we return that. 963 */ 964 return statePtr->self; 965 } 966 self = next; 967 } 968 969 return Tcl_GetStackedChannel (self); 970 } 971} 972