1/* 2 * Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com> 3 * some modifications: 4 * Copyright (C) 2000 Ajuba Solutions 5 * Copyright (C) 2002 ActiveState Corporation 6 * Copyright (C) 2004 Starfish Systems 7 * 8 * $Header: /cvsroot/tls/tls/tls.c,v 1.31 2010/08/11 19:50:50 hobbs2 Exp $ 9 * 10 * TLS (aka SSL) Channel - can be layered on any bi-directional 11 * Tcl_Channel (Note: Requires Trf Core Patch) 12 * 13 * This was built (almost) from scratch based upon observation of 14 * OpenSSL 0.9.2B 15 * 16 * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for 17 * providing the Tcl_ReplaceChannel mechanism and working closely with me 18 * to enhance it to support full fileevent semantics. 19 * 20 * Also work done by the follow people provided the impetus to do this "right": 21 * tclSSL (Colin McCormack, Shared Technology) 22 * SSLtcl (Peter Antman) 23 * 24 */ 25 26#include "tlsInt.h" 27#include "tclOpts.h" 28#include <stdlib.h> 29 30/* 31 * External functions 32 */ 33 34/* 35 * Forward declarations 36 */ 37 38#define F2N( key, dsp) \ 39 (((key) == NULL) ? (char *) NULL : \ 40 Tcl_TranslateFileName(interp, (key), (dsp))) 41#define REASON() ERR_reason_error_string(ERR_get_error()) 42 43static void InfoCallback _ANSI_ARGS_ ((CONST SSL *ssl, int where, int ret)); 44 45static int CiphersObjCmd _ANSI_ARGS_ ((ClientData clientData, 46 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 47 48static int HandshakeObjCmd _ANSI_ARGS_ ((ClientData clientData, 49 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 50 51static int ImportObjCmd _ANSI_ARGS_ ((ClientData clientData, 52 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 53 54static int StatusObjCmd _ANSI_ARGS_ ((ClientData clientData, 55 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 56 57static int VersionObjCmd _ANSI_ARGS_ ((ClientData clientData, 58 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 59 60static int MiscObjCmd _ANSI_ARGS_ ((ClientData clientData, 61 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 62 63static int UnimportObjCmd _ANSI_ARGS_ ((ClientData clientData, 64 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 65 66static SSL_CTX *CTX_Init _ANSI_ARGS_((State *statePtr, int proto, char *key, 67 char *cert, char *CAdir, char *CAfile, char *ciphers)); 68 69#define TLS_PROTO_SSL2 0x01 70#define TLS_PROTO_SSL3 0x02 71#define TLS_PROTO_TLS1 0x04 72#define ENABLED(flag, mask) (((flag) & (mask)) == (mask)) 73 74/* 75 * Static data structures 76 */ 77 78#ifndef NO_DH 79/* from openssl/apps/s_server.c */ 80 81static unsigned char dh512_p[]={ 82 0xDA,0x58,0x3C,0x16,0xD9,0x85,0x22,0x89,0xD0,0xE4,0xAF,0x75, 83 0x6F,0x4C,0xCA,0x92,0xDD,0x4B,0xE5,0x33,0xB8,0x04,0xFB,0x0F, 84 0xED,0x94,0xEF,0x9C,0x8A,0x44,0x03,0xED,0x57,0x46,0x50,0xD3, 85 0x69,0x99,0xDB,0x29,0xD7,0x76,0x27,0x6B,0xA2,0xD3,0xD4,0x12, 86 0xE2,0x18,0xF4,0xDD,0x1E,0x08,0x4C,0xF6,0xD8,0x00,0x3E,0x7C, 87 0x47,0x74,0xE8,0x33, 88 }; 89static unsigned char dh512_g[]={ 90 0x02, 91}; 92 93static DH *get_dh512() 94{ 95 DH *dh=NULL; 96 97 if ((dh=DH_new()) == NULL) return(NULL); 98 99 dh->p=BN_bin2bn(dh512_p,sizeof(dh512_p),NULL); 100 dh->g=BN_bin2bn(dh512_g,sizeof(dh512_g),NULL); 101 102 if ((dh->p == NULL) || (dh->g == NULL)) 103 return(NULL); 104 return(dh); 105} 106#endif 107 108/* 109 * Defined in Tls_Init to determine what kind of channels we are using 110 * (old-style 8.2.0-8.3.1 or new-style 8.3.2+). 111 */ 112int channelTypeVersion; 113 114/* 115 * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2 116 * libraries instead of the current OpenSSL libraries. 117 */ 118 119#ifdef BSAFE 120#define PRE_OPENSSL_0_9_4 1 121#endif 122 123/* 124 * Pre OpenSSL 0.9.4 Compat 125 */ 126 127#ifndef STACK_OF 128#define STACK_OF(x) STACK 129#define sk_SSL_CIPHER_num(sk) sk_num((sk)) 130#define sk_SSL_CIPHER_value( sk, index) (SSL_CIPHER*)sk_value((sk), (index)) 131#endif 132 133 134/* 135 *------------------------------------------------------------------- 136 * 137 * InfoCallback -- 138 * 139 * monitors SSL connection process 140 * 141 * Results: 142 * None 143 * 144 * Side effects: 145 * Calls callback (if defined) 146 *------------------------------------------------------------------- 147 */ 148static void 149InfoCallback(CONST SSL *ssl, int where, int ret) 150{ 151 State *statePtr = (State*)SSL_get_app_data((SSL *)ssl); 152 Tcl_Obj *cmdPtr; 153 char *major; char *minor; 154 155 if (statePtr->callback == (Tcl_Obj*)NULL) 156 return; 157 158 cmdPtr = Tcl_DuplicateObj(statePtr->callback); 159 160#if 0 161 if (where & SSL_CB_ALERT) { 162 sev = SSL_alert_type_string_long(ret); 163 if (strcmp( sev, "fatal")==0) { /* Map to error */ 164 Tls_Error(statePtr, SSL_ERROR(ssl, 0)); 165 return; 166 } 167 } 168#endif 169 if (where & SSL_CB_HANDSHAKE_START) { 170 major = "handshake"; 171 minor = "start"; 172 } else if (where & SSL_CB_HANDSHAKE_DONE) { 173 major = "handshake"; 174 minor = "done"; 175 } else { 176 if (where & SSL_CB_ALERT) major = "alert"; 177 else if (where & SSL_ST_CONNECT) major = "connect"; 178 else if (where & SSL_ST_ACCEPT) major = "accept"; 179 else major = "unknown"; 180 181 if (where & SSL_CB_READ) minor = "read"; 182 else if (where & SSL_CB_WRITE) minor = "write"; 183 else if (where & SSL_CB_LOOP) minor = "loop"; 184 else if (where & SSL_CB_EXIT) minor = "exit"; 185 else minor = "unknown"; 186 } 187 188 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 189 Tcl_NewStringObj( "info", -1)); 190 191 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 192 Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); 193 194 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 195 Tcl_NewStringObj( major, -1) ); 196 197 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 198 Tcl_NewStringObj( minor, -1) ); 199 200 if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) { 201 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 202 Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); 203 } else if (where & SSL_CB_ALERT) { 204 CONST char *cp = (char *) SSL_alert_desc_string_long(ret); 205 206 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 207 Tcl_NewStringObj( cp, -1) ); 208 } else { 209 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 210 Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); 211 } 212 Tcl_Preserve( (ClientData) statePtr->interp); 213 Tcl_Preserve( (ClientData) statePtr); 214 215 Tcl_IncrRefCount( cmdPtr); 216 (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL); 217 Tcl_DecrRefCount( cmdPtr); 218 219 Tcl_Release( (ClientData) statePtr); 220 Tcl_Release( (ClientData) statePtr->interp); 221 222} 223 224/* 225 *------------------------------------------------------------------- 226 * 227 * VerifyCallback -- 228 * 229 * Monitors SSL certificate validation process. 230 * This is called whenever a certificate is inspected 231 * or decided invalid. 232 * 233 * Results: 234 * A callback bound to the socket may return one of: 235 * 0 - the certificate is deemed invalid 236 * 1 - the certificate is deemed valid 237 * empty string - no change to certificate validation 238 * 239 * Side effects: 240 * The err field of the currently operative State is set 241 * to a string describing the SSL negotiation failure reason 242 *------------------------------------------------------------------- 243 */ 244static int 245VerifyCallback(int ok, X509_STORE_CTX *ctx) 246{ 247 Tcl_Obj *cmdPtr, *result; 248 char *errStr, *string; 249 int length; 250 SSL *ssl = (SSL*)X509_STORE_CTX_get_app_data(ctx); 251 X509 *cert = X509_STORE_CTX_get_current_cert(ctx); 252 State *statePtr = (State*)SSL_get_app_data(ssl); 253 int depth = X509_STORE_CTX_get_error_depth(ctx); 254 int err = X509_STORE_CTX_get_error(ctx); 255 256 dprintf(stderr, "Verify: %d\n", ok); 257 258 if (!ok) { 259 errStr = (char*)X509_verify_cert_error_string(err); 260 } else { 261 errStr = (char *)0; 262 } 263 264 if (statePtr->callback == (Tcl_Obj*)NULL) { 265 if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) { 266 return ok; 267 } else { 268 return 1; 269 } 270 } 271 cmdPtr = Tcl_DuplicateObj(statePtr->callback); 272 273 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 274 Tcl_NewStringObj( "verify", -1)); 275 276 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 277 Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); 278 279 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 280 Tcl_NewIntObj( depth) ); 281 282 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 283 Tls_NewX509Obj( statePtr->interp, cert) ); 284 285 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 286 Tcl_NewIntObj( ok) ); 287 288 Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 289 Tcl_NewStringObj( errStr ? errStr : "", -1) ); 290 291 Tcl_Preserve( (ClientData) statePtr->interp); 292 Tcl_Preserve( (ClientData) statePtr); 293 294 statePtr->flags |= TLS_TCL_CALLBACK; 295 296 Tcl_IncrRefCount( cmdPtr); 297 if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { 298 /* It got an error - reject the certificate. */ 299 Tcl_BackgroundError( statePtr->interp); 300 ok = 0; 301 } else { 302 result = Tcl_GetObjResult(statePtr->interp); 303 string = Tcl_GetStringFromObj(result, &length); 304 /* An empty result leaves verification unchanged. */ 305 if (length > 0) { 306 if (Tcl_GetIntFromObj(statePtr->interp, result, &ok) != TCL_OK) { 307 Tcl_BackgroundError(statePtr->interp); 308 ok = 0; 309 } 310 } 311 } 312 Tcl_DecrRefCount( cmdPtr); 313 314 statePtr->flags &= ~(TLS_TCL_CALLBACK); 315 316 Tcl_Release( (ClientData) statePtr); 317 Tcl_Release( (ClientData) statePtr->interp); 318 319 return(ok); /* By default, leave verification unchanged. */ 320} 321 322/* 323 *------------------------------------------------------------------- 324 * 325 * Tls_Error -- 326 * 327 * Calls callback with $fd and $msg - so the callback can decide 328 * what to do with errors. 329 * 330 * Side effects: 331 * The err field of the currently operative State is set 332 * to a string describing the SSL negotiation failure reason 333 *------------------------------------------------------------------- 334 */ 335void 336Tls_Error(State *statePtr, char *msg) 337{ 338 Tcl_Obj *cmdPtr; 339 340 if (msg && *msg) { 341 Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL); 342 } else { 343 msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL); 344 } 345 statePtr->err = msg; 346 347 if (statePtr->callback == (Tcl_Obj*)NULL) { 348 char buf[BUFSIZ]; 349 sprintf(buf, "SSL channel \"%s\": error: %s", 350 Tcl_GetChannelName(statePtr->self), msg); 351 Tcl_SetResult( statePtr->interp, buf, TCL_VOLATILE); 352 Tcl_BackgroundError( statePtr->interp); 353 return; 354 } 355 cmdPtr = Tcl_DuplicateObj(statePtr->callback); 356 357 Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 358 Tcl_NewStringObj("error", -1)); 359 360 Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 361 Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1)); 362 363 Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 364 Tcl_NewStringObj(msg, -1)); 365 366 Tcl_Preserve((ClientData) statePtr->interp); 367 Tcl_Preserve((ClientData) statePtr); 368 369 Tcl_IncrRefCount(cmdPtr); 370 if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { 371 Tcl_BackgroundError(statePtr->interp); 372 } 373 Tcl_DecrRefCount(cmdPtr); 374 375 Tcl_Release((ClientData) statePtr); 376 Tcl_Release((ClientData) statePtr->interp); 377} 378 379/* 380 *------------------------------------------------------------------- 381 * 382 * PasswordCallback -- 383 * 384 * Called when a password is needed to unpack RSA and PEM keys. 385 * Evals any bound password script and returns the result as 386 * the password string. 387 *------------------------------------------------------------------- 388 */ 389#ifdef PRE_OPENSSL_0_9_4 390/* 391 * No way to handle user-data therefore no way without a global 392 * variable to access the Tcl interpreter. 393*/ 394static int 395PasswordCallback(char *buf, int size, int verify) 396{ 397 return -1; 398} 399#else 400static int 401PasswordCallback(char *buf, int size, int verify, void *udata) 402{ 403 State *statePtr = (State *) udata; 404 Tcl_Interp *interp = statePtr->interp; 405 Tcl_Obj *cmdPtr; 406 int result; 407 408 if (statePtr->password == NULL) { 409 if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) 410 == TCL_OK) { 411 char *ret = (char *) Tcl_GetStringResult(interp); 412 strncpy(buf, ret, (size_t) size); 413 return (int)strlen(ret); 414 } else { 415 return -1; 416 } 417 } 418 419 cmdPtr = Tcl_DuplicateObj(statePtr->password); 420 421 Tcl_Preserve((ClientData) statePtr->interp); 422 Tcl_Preserve((ClientData) statePtr); 423 424 Tcl_IncrRefCount(cmdPtr); 425 result = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); 426 if (result != TCL_OK) { 427 Tcl_BackgroundError(statePtr->interp); 428 } 429 Tcl_DecrRefCount(cmdPtr); 430 431 Tcl_Release((ClientData) statePtr); 432 Tcl_Release((ClientData) statePtr->interp); 433 434 if (result == TCL_OK) { 435 char *ret = (char *) Tcl_GetStringResult(interp); 436 strncpy(buf, ret, (size_t) size); 437 return (int)strlen(ret); 438 } else { 439 return -1; 440 } 441} 442#endif 443 444/* 445 *------------------------------------------------------------------- 446 * 447 * CiphersObjCmd -- list available ciphers 448 * 449 * This procedure is invoked to process the "tls::ciphers" command 450 * to list available ciphers, based upon protocol selected. 451 * 452 * Results: 453 * A standard Tcl result list. 454 * 455 * Side effects: 456 * constructs and destroys SSL context (CTX) 457 * 458 *------------------------------------------------------------------- 459 */ 460static int 461CiphersObjCmd(clientData, interp, objc, objv) 462 ClientData clientData; /* Not used. */ 463 Tcl_Interp *interp; 464 int objc; 465 Tcl_Obj *CONST objv[]; 466{ 467 static CONST84 char *protocols[] = { 468 "ssl2", "ssl3", "tls1", NULL 469 }; 470 enum protocol { 471 TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_NONE 472 }; 473 Tcl_Obj *objPtr; 474 SSL_CTX *ctx = NULL; 475 SSL *ssl = NULL; 476 STACK_OF(SSL_CIPHER) *sk; 477 char *cp, buf[BUFSIZ]; 478 int index, verbose = 0; 479 480 if (objc < 2 || objc > 3) { 481 Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?"); 482 return TCL_ERROR; 483 } 484 if (Tcl_GetIndexFromObj( interp, objv[1], protocols, "protocol", 0, 485 &index) != TCL_OK) { 486 return TCL_ERROR; 487 } 488 if (objc > 2 && Tcl_GetBooleanFromObj( interp, objv[2], 489 &verbose) != TCL_OK) { 490 return TCL_ERROR; 491 } 492 switch ((enum protocol)index) { 493 case TLS_SSL2: 494#if defined(NO_SSL2) 495 Tcl_AppendResult(interp, "protocol not supported", NULL); 496 return TCL_ERROR; 497#else 498 ctx = SSL_CTX_new(SSLv2_method()); break; 499#endif 500 case TLS_SSL3: 501#if defined(NO_SSL3) 502 Tcl_AppendResult(interp, "protocol not supported", NULL); 503 return TCL_ERROR; 504#else 505 ctx = SSL_CTX_new(SSLv3_method()); break; 506#endif 507 case TLS_TLS1: 508#if defined(NO_TLS1) 509 Tcl_AppendResult(interp, "protocol not supported", NULL); 510 return TCL_ERROR; 511#else 512 ctx = SSL_CTX_new(TLSv1_method()); break; 513#endif 514 default: 515 break; 516 } 517 if (ctx == NULL) { 518 Tcl_AppendResult(interp, REASON(), (char *) NULL); 519 return TCL_ERROR; 520 } 521 ssl = SSL_new(ctx); 522 if (ssl == NULL) { 523 Tcl_AppendResult(interp, REASON(), (char *) NULL); 524 SSL_CTX_free(ctx); 525 return TCL_ERROR; 526 } 527 objPtr = Tcl_NewListObj( 0, NULL); 528 529 if (!verbose) { 530 for (index = 0; ; index++) { 531 cp = (char*)SSL_get_cipher_list( ssl, index); 532 if (cp == NULL) break; 533 Tcl_ListObjAppendElement( interp, objPtr, 534 Tcl_NewStringObj( cp, -1) ); 535 } 536 } else { 537 sk = SSL_get_ciphers(ssl); 538 539 for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) { 540 register size_t i; 541 SSL_CIPHER_description( sk_SSL_CIPHER_value( sk, index), 542 buf, sizeof(buf)); 543 for (i = strlen(buf) - 1; i ; i--) { 544 if (buf[i] == ' ' || buf[i] == '\n' || 545 buf[i] == '\r' || buf[i] == '\t') { 546 buf[i] = '\0'; 547 } else { 548 break; 549 } 550 } 551 Tcl_ListObjAppendElement( interp, objPtr, 552 Tcl_NewStringObj( buf, -1) ); 553 } 554 } 555 SSL_free(ssl); 556 SSL_CTX_free(ctx); 557 558 Tcl_SetObjResult( interp, objPtr); 559 return TCL_OK; 560} 561 562/* 563 *------------------------------------------------------------------- 564 * 565 * HandshakeObjCmd -- 566 * 567 * This command is used to verify whether the handshake is complete 568 * or not. 569 * 570 * Results: 571 * A standard Tcl result. 1 means handshake complete, 0 means pending. 572 * 573 * Side effects: 574 * May force SSL negotiation to take place. 575 * 576 *------------------------------------------------------------------- 577 */ 578 579static int 580HandshakeObjCmd(clientData, interp, objc, objv) 581 ClientData clientData; /* Not used. */ 582 Tcl_Interp *interp; 583 int objc; 584 Tcl_Obj *CONST objv[]; 585{ 586 Tcl_Channel chan; /* The channel to set a mode on. */ 587 State *statePtr; /* client state for ssl socket */ 588 int ret = 1; 589 590 if (objc != 2) { 591 Tcl_WrongNumArgs(interp, 1, objv, "channel"); 592 return TCL_ERROR; 593 } 594 595 chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); 596 if (chan == (Tcl_Channel) NULL) { 597 return TCL_ERROR; 598 } 599 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 600 /* 601 * Make sure to operate on the topmost channel 602 */ 603 chan = Tcl_GetTopChannel(chan); 604 } 605 if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { 606 Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), 607 "\": not a TLS channel", NULL); 608 return TCL_ERROR; 609 } 610 statePtr = (State *)Tcl_GetChannelInstanceData(chan); 611 612 if (!SSL_is_init_finished(statePtr->ssl)) { 613 int err; 614 ret = Tls_WaitForConnect(statePtr, &err); 615 if ((statePtr->flags & TLS_TCL_ASYNC) && err == EAGAIN) { 616 ret = 0; 617 } 618 if (ret < 0) { 619 CONST char *errStr = statePtr->err; 620 Tcl_ResetResult(interp); 621 Tcl_SetErrno(err); 622 623 if (!errStr || *errStr == 0) { 624 errStr = Tcl_PosixError(interp); 625 } 626 627 Tcl_AppendResult(interp, "handshake failed: ", errStr, 628 (char *) NULL); 629 return TCL_ERROR; 630 } 631 } 632 633 Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); 634 return TCL_OK; 635} 636 637/* 638 *------------------------------------------------------------------- 639 * 640 * ImportObjCmd -- 641 * 642 * This procedure is invoked to process the "ssl" command 643 * 644 * The ssl command pushes SSL over a (newly connected) tcp socket 645 * 646 * Results: 647 * A standard Tcl result. 648 * 649 * Side effects: 650 * May modify the behavior of an IO channel. 651 * 652 *------------------------------------------------------------------- 653 */ 654 655static int 656ImportObjCmd(clientData, interp, objc, objv) 657 ClientData clientData; /* Not used. */ 658 Tcl_Interp *interp; 659 int objc; 660 Tcl_Obj *CONST objv[]; 661{ 662 Tcl_Channel chan; /* The channel to set a mode on. */ 663 State *statePtr; /* client state for ssl socket */ 664 SSL_CTX *ctx = NULL; 665 Tcl_Obj *script = NULL; 666 Tcl_Obj *password = NULL; 667 int idx, len; 668 int flags = TLS_TCL_INIT; 669 int server = 0; /* is connection incoming or outgoing? */ 670 char *key = NULL; 671 char *cert = NULL; 672 char *ciphers = NULL; 673 char *CAfile = NULL; 674 char *CAdir = NULL; 675 char *model = NULL; 676#if defined(NO_SSL2) 677 int ssl2 = 0; 678#else 679 int ssl2 = 1; 680#endif 681#if defined(NO_SSL3) 682 int ssl3 = 0; 683#else 684 int ssl3 = 1; 685#endif 686#if defined(NO_SSL2) && defined(NO_SSL3) 687 int tls1 = 1; 688#else 689 int tls1 = 0; 690#endif 691 int proto = 0; 692 int verify = 0, require = 0, request = 1; 693 694 if (objc < 2) { 695 Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?"); 696 return TCL_ERROR; 697 } 698 699 chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); 700 if (chan == (Tcl_Channel) NULL) { 701 return TCL_ERROR; 702 } 703 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 704 /* 705 * Make sure to operate on the topmost channel 706 */ 707 chan = Tcl_GetTopChannel(chan); 708 } 709 710 for (idx = 2; idx < objc; idx++) { 711 char *opt = Tcl_GetStringFromObj(objv[idx], NULL); 712 713 if (opt[0] != '-') 714 break; 715 716 OPTSTR( "-cadir", CAdir); 717 OPTSTR( "-cafile", CAfile); 718 OPTSTR( "-certfile", cert); 719 OPTSTR( "-cipher", ciphers); 720 OPTOBJ( "-command", script); 721 OPTSTR( "-keyfile", key); 722 OPTSTR( "-model", model); 723 OPTOBJ( "-password", password); 724 OPTBOOL( "-require", require); 725 OPTBOOL( "-request", request); 726 OPTBOOL( "-server", server); 727 728 OPTBOOL( "-ssl2", ssl2); 729 OPTBOOL( "-ssl3", ssl3); 730 OPTBOOL( "-tls1", tls1); 731 732 OPTBAD( "option", "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -model, -password, -require, -request, -server, -ssl2, -ssl3, or -tls1"); 733 734 return TCL_ERROR; 735 } 736 if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; 737 if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; 738 if (verify == 0) verify = SSL_VERIFY_NONE; 739 740 proto |= (ssl2 ? TLS_PROTO_SSL2 : 0); 741 proto |= (ssl3 ? TLS_PROTO_SSL3 : 0); 742 proto |= (tls1 ? TLS_PROTO_TLS1 : 0); 743 744 /* reset to NULL if blank string provided */ 745 if (cert && !*cert) cert = NULL; 746 if (key && !*key) key = NULL; 747 if (ciphers && !*ciphers) ciphers = NULL; 748 if (CAfile && !*CAfile) CAfile = NULL; 749 if (CAdir && !*CAdir) CAdir = NULL; 750 751 /* new SSL state */ 752 statePtr = (State *) ckalloc((unsigned) sizeof(State)); 753 memset(statePtr, 0, sizeof(State)); 754 755 statePtr->flags = flags; 756 statePtr->interp = interp; 757 statePtr->vflags = verify; 758 statePtr->err = ""; 759 760 /* allocate script */ 761 if (script) { 762 (void) Tcl_GetStringFromObj(script, &len); 763 if (len) { 764 statePtr->callback = script; 765 Tcl_IncrRefCount(statePtr->callback); 766 } 767 } 768 769 /* allocate password */ 770 if (password) { 771 (void) Tcl_GetStringFromObj(password, &len); 772 if (len) { 773 statePtr->password = password; 774 Tcl_IncrRefCount(statePtr->password); 775 } 776 } 777 778 if (model != NULL) { 779 int mode; 780 /* Get the "model" context */ 781 chan = Tcl_GetChannel(interp, model, &mode); 782 if (chan == (Tcl_Channel) NULL) { 783 Tls_Free((char *) statePtr); 784 return TCL_ERROR; 785 } 786 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 787 /* 788 * Make sure to operate on the topmost channel 789 */ 790 chan = Tcl_GetTopChannel(chan); 791 } 792 if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { 793 Tcl_AppendResult(interp, "bad channel \"", 794 Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); 795 Tls_Free((char *) statePtr); 796 return TCL_ERROR; 797 } 798 ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx; 799 } else { 800 if ((ctx = CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers)) 801 == (SSL_CTX*)0) { 802 Tls_Free((char *) statePtr); 803 return TCL_ERROR; 804 } 805 } 806 807 statePtr->ctx = ctx; 808 809 /* 810 * We need to make sure that the channel works in binary (for the 811 * encryption not to get goofed up). 812 * We only want to adjust the buffering in pre-v2 channels, where 813 * each channel in the stack maintained its own buffers. 814 */ 815 Tcl_SetChannelOption(interp, chan, "-translation", "binary"); 816 if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { 817 Tcl_SetChannelOption(interp, chan, "-buffering", "none"); 818 } 819 820 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 821 statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), 822 (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); 823 } else { 824 statePtr->self = chan; 825 Tcl_StackChannel(interp, Tls_ChannelType(), 826 (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); 827 } 828 if (statePtr->self == (Tcl_Channel) NULL) { 829 /* 830 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. 831 */ 832 Tls_Free((char *) statePtr); 833 return TCL_ERROR; 834 } 835 836 /* 837 * SSL Initialization 838 */ 839 840 statePtr->ssl = SSL_new(statePtr->ctx); 841 if (!statePtr->ssl) { 842 /* SSL library error */ 843 Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), 844 (char *) NULL); 845 Tls_Free((char *) statePtr); 846 return TCL_ERROR; 847 } 848 849 /* 850 * SSL Callbacks 851 */ 852 853 SSL_set_app_data(statePtr->ssl, (VOID *)statePtr); /* point back to us */ 854 855 SSL_set_verify(statePtr->ssl, verify, VerifyCallback); 856 857 SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback); 858 859 /* Create Tcl_Channel BIO Handler */ 860 statePtr->p_bio = BIO_new_tcl(statePtr, BIO_CLOSE); 861 statePtr->bio = BIO_new(BIO_f_ssl()); 862 863 if (server) { 864 statePtr->flags |= TLS_TCL_SERVER; 865 SSL_set_accept_state(statePtr->ssl); 866 } else { 867 SSL_set_connect_state(statePtr->ssl); 868 } 869 SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio); 870 BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE); 871 872 /* 873 * End of SSL Init 874 */ 875 Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), 876 TCL_VOLATILE); 877 return TCL_OK; 878} 879 880/* 881 *------------------------------------------------------------------- 882 * 883 * UnimportObjCmd -- 884 * 885 * This procedure is invoked to remove the topmost channel filter. 886 * 887 * Results: 888 * A standard Tcl result. 889 * 890 * Side effects: 891 * May modify the behavior of an IO channel. 892 * 893 *------------------------------------------------------------------- 894 */ 895 896static int 897UnimportObjCmd(clientData, interp, objc, objv) 898 ClientData clientData; /* Not used. */ 899 Tcl_Interp *interp; 900 int objc; 901 Tcl_Obj *CONST objv[]; 902{ 903 Tcl_Channel chan; /* The channel to set a mode on. */ 904 905 if (objc != 2) { 906 Tcl_WrongNumArgs(interp, 1, objv, "channel"); 907 return TCL_ERROR; 908 } 909 910 chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); 911 if (chan == (Tcl_Channel) NULL) { 912 return TCL_ERROR; 913 } 914 915 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 916 /* 917 * Make sure to operate on the topmost channel 918 */ 919 chan = Tcl_GetTopChannel(chan); 920 } 921 922 if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { 923 Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), 924 "\": not a TLS channel", NULL); 925 return TCL_ERROR; 926 } 927 928 if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) { 929 return TCL_ERROR; 930 } 931 932 return TCL_OK; 933} 934 935/* 936 *------------------------------------------------------------------- 937 * 938 * CTX_Init -- construct a SSL_CTX instance 939 * 940 * Results: 941 * A valid SSL_CTX instance or NULL. 942 * 943 * Side effects: 944 * constructs SSL context (CTX) 945 * 946 *------------------------------------------------------------------- 947 */ 948 949static SSL_CTX * 950CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers) 951 State *statePtr; 952 int proto; 953 char *key; 954 char *cert; 955 char *CAdir; 956 char *CAfile; 957 char *ciphers; 958{ 959 Tcl_Interp *interp = statePtr->interp; 960 SSL_CTX *ctx = NULL; 961 Tcl_DString ds; 962 Tcl_DString ds1; 963 int off = 0; 964 965 /* create SSL context */ 966#if !defined(NO_SSL2) && !defined(NO_SSL3) 967 if (ENABLED(proto, TLS_PROTO_SSL2) && 968 ENABLED(proto, TLS_PROTO_SSL3)) { 969 ctx = SSL_CTX_new(SSLv23_method()); 970 } else 971#endif 972 if (ENABLED(proto, TLS_PROTO_SSL2)) { 973#if defined(NO_SSL2) 974 Tcl_AppendResult(interp, "protocol not supported", NULL); 975 return (SSL_CTX *)0; 976#else 977 ctx = SSL_CTX_new(SSLv2_method()); 978#endif 979 } else if (ENABLED(proto, TLS_PROTO_TLS1)) { 980 ctx = SSL_CTX_new(TLSv1_method()); 981 } else if (ENABLED(proto, TLS_PROTO_SSL3)) { 982#if defined(NO_SSL3) 983 Tcl_AppendResult(interp, "protocol not supported", NULL); 984 return (SSL_CTX *)0; 985#else 986 ctx = SSL_CTX_new(SSLv3_method()); 987#endif 988 } else { 989 Tcl_AppendResult(interp, "no valid protocol selected", NULL); 990 return (SSL_CTX *)0; 991 } 992 off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1); 993 off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2); 994 off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3); 995 996 SSL_CTX_set_app_data( ctx, (VOID*)interp); /* remember the interpreter */ 997 SSL_CTX_set_options( ctx, SSL_OP_ALL); /* all SSL bug workarounds */ 998 SSL_CTX_set_options( ctx, off); /* all SSL bug workarounds */ 999 SSL_CTX_sess_set_cache_size( ctx, 128); 1000 1001 if (ciphers != NULL) 1002 SSL_CTX_set_cipher_list(ctx, ciphers); 1003 1004 /* set some callbacks */ 1005 SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback); 1006 1007#ifndef BSAFE 1008 SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr); 1009#endif 1010 1011#ifndef NO_DH 1012 { 1013 DH* dh = get_dh512(); 1014 SSL_CTX_set_tmp_dh(ctx, dh); 1015 DH_free(dh); 1016 } 1017#endif 1018 1019 /* set our certificate */ 1020 if (cert != NULL) { 1021 Tcl_DStringInit(&ds); 1022 1023 if (SSL_CTX_use_certificate_file(ctx, F2N( cert, &ds), 1024 SSL_FILETYPE_PEM) <= 0) { 1025 Tcl_DStringFree(&ds); 1026 Tcl_AppendResult(interp, 1027 "unable to set certificate file ", cert, ": ", 1028 REASON(), (char *) NULL); 1029 SSL_CTX_free(ctx); 1030 return (SSL_CTX *)0; 1031 } 1032 1033 /* get the private key associated with this certificate */ 1034 if (key == NULL) key=cert; 1035 1036 if (SSL_CTX_use_PrivateKey_file(ctx, F2N( key, &ds), 1037 SSL_FILETYPE_PEM) <= 0) { 1038 Tcl_DStringFree(&ds); 1039 /* flush the passphrase which might be left in the result */ 1040 Tcl_SetResult(interp, NULL, TCL_STATIC); 1041 Tcl_AppendResult(interp, 1042 "unable to set public key file ", key, " ", 1043 REASON(), (char *) NULL); 1044 SSL_CTX_free(ctx); 1045 return (SSL_CTX *)0; 1046 } 1047 Tcl_DStringFree(&ds); 1048 /* Now we know that a key and cert have been set against 1049 * the SSL context */ 1050 if (!SSL_CTX_check_private_key(ctx)) { 1051 Tcl_AppendResult(interp, 1052 "private key does not match the certificate public key", 1053 (char *) NULL); 1054 SSL_CTX_free(ctx); 1055 return (SSL_CTX *)0; 1056 } 1057 } else { 1058 cert = (char*)X509_get_default_cert_file(); 1059 1060 if (SSL_CTX_use_certificate_file(ctx, cert, 1061 SSL_FILETYPE_PEM) <= 0) { 1062#if 0 1063 Tcl_DStringFree(&ds); 1064 Tcl_AppendResult(interp, 1065 "unable to use default certificate file ", cert, ": ", 1066 REASON(), (char *) NULL); 1067 SSL_CTX_free(ctx); 1068 return (SSL_CTX *)0; 1069#endif 1070 } 1071 } 1072 1073 Tcl_DStringInit(&ds); 1074 Tcl_DStringInit(&ds1); 1075 if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) || 1076 !SSL_CTX_set_default_verify_paths(ctx)) { 1077#if 0 1078 Tcl_DStringFree(&ds); 1079 Tcl_DStringFree(&ds1); 1080 /* Don't currently care if this fails */ 1081 Tcl_AppendResult(interp, "SSL default verify paths: ", 1082 REASON(), (char *) NULL); 1083 SSL_CTX_free(ctx); 1084 return (SSL_CTX *)0; 1085#endif 1086 } 1087 SSL_CTX_set_client_CA_list(ctx, SSL_load_client_CA_file( F2N(CAfile, &ds) )); 1088 1089 Tcl_DStringFree(&ds); 1090 Tcl_DStringFree(&ds1); 1091 return ctx; 1092} 1093 1094/* 1095 *------------------------------------------------------------------- 1096 * 1097 * StatusObjCmd -- return certificate for connected peer. 1098 * 1099 * Results: 1100 * A standard Tcl result. 1101 * 1102 * Side effects: 1103 * None. 1104 * 1105 *------------------------------------------------------------------- 1106 */ 1107static int 1108StatusObjCmd(clientData, interp, objc, objv) 1109 ClientData clientData; /* Not used. */ 1110 Tcl_Interp *interp; 1111 int objc; 1112 Tcl_Obj *CONST objv[]; 1113{ 1114 State *statePtr; 1115 X509 *peer; 1116 Tcl_Obj *objPtr; 1117 Tcl_Channel chan; 1118 char *channelName, *ciphers; 1119 int mode; 1120 1121 switch (objc) { 1122 case 2: 1123 channelName = Tcl_GetStringFromObj(objv[1], NULL); 1124 break; 1125 1126 case 3: 1127 if (!strcmp (Tcl_GetString (objv[1]), "-local")) { 1128 channelName = Tcl_GetStringFromObj(objv[2], NULL); 1129 break; 1130 } 1131 /* else fall... */ 1132 default: 1133 Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel"); 1134 return TCL_ERROR; 1135 } 1136 1137 chan = Tcl_GetChannel(interp, channelName, &mode); 1138 if (chan == (Tcl_Channel) NULL) { 1139 return TCL_ERROR; 1140 } 1141 if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { 1142 /* 1143 * Make sure to operate on the topmost channel 1144 */ 1145 chan = Tcl_GetTopChannel(chan); 1146 } 1147 if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { 1148 Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), 1149 "\": not a TLS channel", NULL); 1150 return TCL_ERROR; 1151 } 1152 statePtr = (State *) Tcl_GetChannelInstanceData(chan); 1153 if (objc == 2) { 1154 peer = SSL_get_peer_certificate(statePtr->ssl); 1155 } else { 1156 peer = SSL_get_certificate(statePtr->ssl); 1157 } 1158 if (peer) { 1159 objPtr = Tls_NewX509Obj(interp, peer); 1160 if (objc == 2) { X509_free(peer); } 1161 } else { 1162 objPtr = Tcl_NewListObj(0, NULL); 1163 } 1164 1165 Tcl_ListObjAppendElement (interp, objPtr, 1166 Tcl_NewStringObj ("sbits", -1)); 1167 Tcl_ListObjAppendElement (interp, objPtr, 1168 Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, NULL))); 1169 1170 ciphers = (char*)SSL_get_cipher(statePtr->ssl); 1171 if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) { 1172 Tcl_ListObjAppendElement(interp, objPtr, 1173 Tcl_NewStringObj("cipher", -1)); 1174 Tcl_ListObjAppendElement(interp, objPtr, 1175 Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1)); 1176 } 1177 Tcl_SetObjResult( interp, objPtr); 1178 return TCL_OK; 1179} 1180 1181/* 1182 *------------------------------------------------------------------- 1183 * 1184 * VersionObjCmd -- return version string from OpenSSL. 1185 * 1186 * Results: 1187 * A standard Tcl result. 1188 * 1189 * Side effects: 1190 * None. 1191 * 1192 *------------------------------------------------------------------- 1193 */ 1194static int 1195VersionObjCmd(clientData, interp, objc, objv) 1196 ClientData clientData; /* Not used. */ 1197 Tcl_Interp *interp; 1198 int objc; 1199 Tcl_Obj *CONST objv[]; 1200{ 1201 Tcl_Obj *objPtr; 1202 1203 objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1); 1204 1205 Tcl_SetObjResult(interp, objPtr); 1206 return TCL_OK; 1207} 1208 1209/* 1210 *------------------------------------------------------------------- 1211 * 1212 * MiscObjCmd -- misc commands 1213 * 1214 * Results: 1215 * A standard Tcl result. 1216 * 1217 * Side effects: 1218 * None. 1219 * 1220 *------------------------------------------------------------------- 1221 */ 1222static int 1223MiscObjCmd(clientData, interp, objc, objv) 1224 ClientData clientData; /* Not used. */ 1225 Tcl_Interp *interp; 1226 int objc; 1227 Tcl_Obj *CONST objv[]; 1228{ 1229 CONST84 char *commands [] = { "req", NULL }; 1230 enum command { C_REQ, C_DUMMY }; 1231 int cmd; 1232 1233 if (objc < 2) { 1234 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); 1235 return TCL_ERROR; 1236 } 1237 if (Tcl_GetIndexFromObj(interp, objv[1], commands, 1238 "command", 0,&cmd) != TCL_OK) { 1239 return TCL_ERROR; 1240 } 1241 1242 switch ((enum command) cmd) { 1243 case C_REQ: { 1244 EVP_PKEY *pkey=NULL; 1245 X509 *cert=NULL; 1246 X509_NAME *name=NULL; 1247 Tcl_Obj **listv; 1248 int listc,i; 1249 1250 BIO *out=NULL; 1251 1252 char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email=""; 1253 char *keyout,*pemout,*str; 1254 int keysize,serial=0,days=365; 1255 1256 if ((objc<5) || (objc>6)) { 1257 Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?"); 1258 return TCL_ERROR; 1259 } 1260 1261 if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) { 1262 return TCL_ERROR; 1263 } 1264 keyout=Tcl_GetString(objv[3]); 1265 pemout=Tcl_GetString(objv[4]); 1266 1267 if (objc>=6) { 1268 if (Tcl_ListObjGetElements(interp, objv[5], 1269 &listc, &listv) != TCL_OK) { 1270 return TCL_ERROR; 1271 } 1272 1273 if ((listc%2) != 0) { 1274 Tcl_SetResult(interp,"Information list must have even number of arguments",NULL); 1275 return TCL_ERROR; 1276 } 1277 for (i=0; i<listc; i+=2) { 1278 str=Tcl_GetString(listv[i]); 1279 if (strcmp(str,"days")==0) { 1280 if (Tcl_GetIntFromObj(interp,listv[i+1],&days)!=TCL_OK) 1281 return TCL_ERROR; 1282 } else if (strcmp(str,"serial")==0) { 1283 if (Tcl_GetIntFromObj(interp,listv[i+1],&serial)!=TCL_OK) 1284 return TCL_ERROR; 1285 } else if (strcmp(str,"serial")==0) { 1286 if (Tcl_GetIntFromObj(interp,listv[i+1],&serial)!=TCL_OK) 1287 return TCL_ERROR; 1288 } else if (strcmp(str,"C")==0) { 1289 k_C=Tcl_GetString(listv[i+1]); 1290 } else if (strcmp(str,"ST")==0) { 1291 k_ST=Tcl_GetString(listv[i+1]); 1292 } else if (strcmp(str,"L")==0) { 1293 k_L=Tcl_GetString(listv[i+1]); 1294 } else if (strcmp(str,"O")==0) { 1295 k_O=Tcl_GetString(listv[i+1]); 1296 } else if (strcmp(str,"OU")==0) { 1297 k_OU=Tcl_GetString(listv[i+1]); 1298 } else if (strcmp(str,"CN")==0) { 1299 k_CN=Tcl_GetString(listv[i+1]); 1300 } else if (strcmp(str,"Email")==0) { 1301 k_Email=Tcl_GetString(listv[i+1]); 1302 } else { 1303 Tcl_SetResult(interp,"Unknown parameter",NULL); 1304 return TCL_ERROR; 1305 } 1306 } 1307 } 1308 if ((pkey = EVP_PKEY_new()) != NULL) { 1309 if (!EVP_PKEY_assign_RSA(pkey, 1310 RSA_generate_key(keysize, 0x10001, NULL, NULL))) { 1311 Tcl_SetResult(interp,"Error generating private key",NULL); 1312 EVP_PKEY_free(pkey); 1313 return TCL_ERROR; 1314 } 1315 out=BIO_new(BIO_s_file()); 1316 BIO_write_filename(out,keyout); 1317 PEM_write_bio_PrivateKey(out,pkey,NULL,NULL,0,NULL,NULL); 1318 BIO_free_all(out); 1319 1320 if ((cert=X509_new())==NULL) { 1321 Tcl_SetResult(interp,"Error generating certificate request",NULL); 1322 EVP_PKEY_free(pkey); 1323 return(TCL_ERROR); 1324 } 1325 1326 X509_set_version(cert,2); 1327 ASN1_INTEGER_set(X509_get_serialNumber(cert),serial); 1328 X509_gmtime_adj(X509_get_notBefore(cert),0); 1329 X509_gmtime_adj(X509_get_notAfter(cert),(long)60*60*24*days); 1330 X509_set_pubkey(cert,pkey); 1331 1332 name=X509_get_subject_name(cert); 1333 1334 X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, k_C, -1, -1, 0); 1335 X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, k_ST, -1, -1, 0); 1336 X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, k_L, -1, -1, 0); 1337 X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, k_O, -1, -1, 0); 1338 X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, k_OU, -1, -1, 0); 1339 X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, k_CN, -1, -1, 0); 1340 X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, k_Email, -1, -1, 0); 1341 1342 X509_set_subject_name(cert,name); 1343 1344 if (!X509_sign(cert,pkey,EVP_md5())) { 1345 X509_free(cert); 1346 EVP_PKEY_free(pkey); 1347 Tcl_SetResult(interp,"Error signing certificate",NULL); 1348 return TCL_ERROR; 1349 } 1350 1351 out=BIO_new(BIO_s_file()); 1352 BIO_write_filename(out,pemout); 1353 1354 PEM_write_bio_X509(out,cert); 1355 BIO_free_all(out); 1356 1357 X509_free(cert); 1358 EVP_PKEY_free(pkey); 1359 } else { 1360 Tcl_SetResult(interp,"Error generating private key",NULL); 1361 return TCL_ERROR; 1362 } 1363 } 1364 break; 1365 default: 1366 break; 1367 } 1368 return TCL_OK; 1369} 1370 1371/* 1372 *------------------------------------------------------------------- 1373 * 1374 * Tls_Free -- 1375 * 1376 * This procedure cleans up when a SSL socket based channel 1377 * is closed and its reference count falls below 1 1378 * 1379 * Results: 1380 * none 1381 * 1382 * Side effects: 1383 * Frees all the state 1384 * 1385 *------------------------------------------------------------------- 1386 */ 1387void 1388Tls_Free( char *blockPtr ) 1389{ 1390 State *statePtr = (State *)blockPtr; 1391 1392 Tls_Clean(statePtr); 1393 ckfree(blockPtr); 1394} 1395 1396/* 1397 *------------------------------------------------------------------- 1398 * 1399 * Tls_Clean -- 1400 * 1401 * This procedure cleans up when a SSL socket based channel 1402 * is closed and its reference count falls below 1. This should 1403 * be called synchronously by the CloseProc, not in the 1404 * EventuallyFree callback. 1405 * 1406 * Results: 1407 * none 1408 * 1409 * Side effects: 1410 * Frees all the state 1411 * 1412 *------------------------------------------------------------------- 1413 */ 1414void 1415Tls_Clean(State *statePtr) 1416{ 1417 /* 1418 * we're assuming here that we're single-threaded 1419 */ 1420 1421 if (statePtr->timer != (Tcl_TimerToken) NULL) { 1422 Tcl_DeleteTimerHandler(statePtr->timer); 1423 statePtr->timer = NULL; 1424 } 1425 1426 if (statePtr->bio) { 1427 /* This will call SSL_shutdown. Bug 1414045 */ 1428 dprintf(stderr, "BIO_free_all(%p)\n", statePtr->bio); 1429 BIO_free_all(statePtr->bio); 1430 statePtr->bio = NULL; 1431 } 1432 if (statePtr->ssl) { 1433 dprintf(stderr, "SSL_free(%p)\n", statePtr->ssl); 1434 SSL_free(statePtr->ssl); 1435 statePtr->ssl = NULL; 1436 } 1437 if (statePtr->ctx) { 1438 SSL_CTX_free(statePtr->ctx); 1439 statePtr->ctx = NULL; 1440 } 1441 if (statePtr->callback) { 1442 Tcl_DecrRefCount(statePtr->callback); 1443 statePtr->callback = NULL; 1444 } 1445 if (statePtr->password) { 1446 Tcl_DecrRefCount(statePtr->password); 1447 statePtr->password = NULL; 1448 } 1449} 1450 1451/* 1452 *------------------------------------------------------------------- 1453 * 1454 * Tls_Init -- 1455 * 1456 * This is a package initialization procedure, which is called 1457 * by Tcl when this package is to be added to an interpreter. 1458 * 1459 * Results: Ssl configured and loaded 1460 * 1461 * Side effects: 1462 * create the ssl command, initialise ssl context 1463 * 1464 *------------------------------------------------------------------- 1465 */ 1466 1467int 1468Tls_Init(Tcl_Interp *interp) /* Interpreter in which the package is 1469 * to be made available. */ 1470{ 1471 int major, minor, patchlevel, release, i; 1472 char rnd_seed[16] = "GrzSlplKqUdnnzP!"; /* 16 bytes */ 1473 1474 /* 1475 * The original 8.2.0 stacked channel implementation (and the patch 1476 * that preceded it) had problems with scalability and robustness. 1477 * These were address in 8.3.2 / 8.4a2, so we now require that as a 1478 * minimum for TLS 1.4+. We only support 8.2+ now (8.3.2+ preferred). 1479 */ 1480 if ( 1481#ifdef USE_TCL_STUBS 1482 Tcl_InitStubs(interp, "8.2", 0) 1483#else 1484 Tcl_PkgRequire(interp, "Tcl", "8.2", 0) 1485#endif 1486 == NULL) { 1487 return TCL_ERROR; 1488 } 1489 1490 /* 1491 * Get the version so we can runtime switch on available functionality. 1492 * TLS should really only be used in 8.3.2+, but the other works for 1493 * some limited functionality, so an attempt at support is made. 1494 */ 1495 Tcl_GetVersion(&major, &minor, &patchlevel, &release); 1496 if ((major > 8) || ((major == 8) && ((minor > 3) || ((minor == 3) && 1497 (release == TCL_FINAL_RELEASE) && (patchlevel >= 2))))) { 1498 /* 8.3.2+ */ 1499 channelTypeVersion = TLS_CHANNEL_VERSION_2; 1500 } else { 1501 /* 8.2.0 - 8.3.1 */ 1502 channelTypeVersion = TLS_CHANNEL_VERSION_1; 1503 } 1504 1505 if (SSL_library_init() != 1) { 1506 Tcl_AppendResult(interp, "could not initialize SSL library", NULL); 1507 return TCL_ERROR; 1508 } 1509 SSL_load_error_strings(); 1510 ERR_load_crypto_strings(); 1511 1512 /* 1513 * Seed the random number generator in the SSL library, 1514 * using the do/while construct because of the bug note in the 1515 * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1 1516 * 1517 * The crux of the problem is that Solaris 7 does not have a 1518 * /dev/random or /dev/urandom device so it cannot gather enough 1519 * entropy from the RAND_seed() when TLS initializes and refuses 1520 * to go further. Earlier versions of OpenSSL carried on regardless. 1521 */ 1522 srand((unsigned int) time((time_t *) NULL)); 1523 do { 1524 for (i = 0; i < 16; i++) { 1525 rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0)); 1526 } 1527 RAND_seed(rnd_seed, sizeof(rnd_seed)); 1528 } while (RAND_status() != 1); 1529 1530 Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, 1531 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1532 1533 Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, 1534 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1535 1536 Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, 1537 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1538 1539 Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, 1540 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1541 1542 Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, 1543 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1544 1545 Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, 1546 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1547 1548 Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, 1549 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 1550 1551 return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION); 1552} 1553 1554/* 1555 *------------------------------------------------------* 1556 * 1557 * Tls_SafeInit -- 1558 * 1559 * ------------------------------------------------* 1560 * Standard procedure required by 'load'. 1561 * Initializes this extension for a safe interpreter. 1562 * ------------------------------------------------* 1563 * 1564 * Sideeffects: 1565 * As of 'Tls_Init' 1566 * 1567 * Result: 1568 * A standard Tcl error code. 1569 * 1570 *------------------------------------------------------* 1571 */ 1572 1573int 1574Tls_SafeInit (Tcl_Interp* interp) 1575{ 1576 return Tls_Init (interp); 1577} 1578