@@ -1,12 +1,13 @@ /* * Copyright (C) 1997-1999 Matt Newman * some modifications: * Copyright (C) 2000 Ajuba Solutions * Copyright (C) 2002 ActiveState Corporation + * Copyright (C) 2003 Starfish Systems * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.14 2002/02/04 22:46:31 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.15 2003/05/15 20:44:46 razzell Exp $ * * TLS (aka SSL) Channel - can be layered on any bi-directional * Tcl_Channel (Note: Requires Trf Core Patch) * * This was built (almost) from scratch based upon observation of @@ -48,11 +49,15 @@ static int ImportObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int StatusObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -static SSL_CTX *CTX_Init _ANSI_ARGS_((Tcl_Interp *interp, int proto, char *key, + +static int VersionObjCmd _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static SSL_CTX *CTX_Init _ANSI_ARGS_((State *statePtr, int proto, char *key, char *cert, char *CAdir, char *CAfile, char *ciphers)); #define TLS_PROTO_SSL2 0x01 #define TLS_PROTO_SSL3 0x02 #define TLS_PROTO_TLS1 0x04 @@ -170,11 +175,10 @@ else if (where & SSL_CB_LOOP) minor = "loop"; else if (where & SSL_CB_EXIT) minor = "exit"; else minor = "unknown"; } - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, Tcl_NewStringObj( "info", -1)); Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); @@ -187,11 +191,11 @@ if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) { Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); } else if (where & SSL_CB_ALERT) { - char *cp = SSL_alert_desc_string_long(ret); + char *cp = (char *) SSL_alert_desc_string_long(ret); Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, Tcl_NewStringObj( cp, -1) ); } else { Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, @@ -358,13 +362,13 @@ /* *------------------------------------------------------------------- * * PasswordCallback -- * - * Called when a password is needed to unpack RSA and PEM keys - * Evals the tcl proc: tls::password and returns the result as - * the password + * Called when a password is needed to unpack RSA and PEM keys. + * Evals any bound password script and returns the result as + * the password string. *------------------------------------------------------------------- */ #ifdef PRE_OPENSSL_0_9_4 /* * No way to handle user-data therefore no way without a global @@ -377,14 +381,42 @@ } #else static int PasswordCallback(char *buf, int size, int verify, void *udata) { - Tcl_Interp *interp = (Tcl_Interp*)udata; + State *statePtr = (State *) udata; + Tcl_Interp *interp = statePtr->interp; + Tcl_Obj *cmdPtr; + int result; - if (Tcl_Eval(interp, "tls::password") == TCL_OK) { - CONST char *ret = Tcl_GetStringResult(interp); + if (statePtr->password == NULL) { + if (Tcl_Eval(interp, "tls::password") == TCL_OK) { + char *ret = (char *) Tcl_GetStringResult(interp); + strncpy(buf, ret, size); + return strlen(ret); + } else { + return -1; + } + } + + cmdPtr = Tcl_DuplicateObj(statePtr->password); + + Tcl_Preserve((ClientData) statePtr->interp); + Tcl_Preserve((ClientData) statePtr); + + Tcl_IncrRefCount(cmdPtr); + result = Tcl_GlobalEvalObj(interp, cmdPtr); + if (result != TCL_OK) { + Tcl_BackgroundError(statePtr->interp); + } + Tcl_DecrRefCount(cmdPtr); + + Tcl_Release((ClientData) statePtr); + Tcl_Release((ClientData) statePtr->interp); + + if (result == TCL_OK) { + char *ret = (char *) Tcl_GetStringResult(interp); strncpy(buf, ret, size); return strlen(ret); } else { return -1; } @@ -606,10 +638,11 @@ { Tcl_Channel chan; /* The channel to set a mode on. */ State *statePtr; /* client state for ssl socket */ SSL_CTX *ctx = NULL; Tcl_Obj *script = NULL; + Tcl_Obj *password = NULL; int idx; int flags = TLS_TCL_INIT; int server = 0; /* is connection incoming or outgoing? */ char *key = NULL; char *cert = NULL; @@ -655,26 +688,27 @@ char *opt = Tcl_GetStringFromObj(objv[idx], NULL); if (opt[0] != '-') break; - OPTSTR( "-cafile", CAfile); OPTSTR( "-cadir", CAdir); + OPTSTR( "-cafile", CAfile); OPTSTR( "-certfile", cert); OPTSTR( "-cipher", ciphers); OPTOBJ( "-command", script); OPTSTR( "-keyfile", key); OPTSTR( "-model", model); + OPTOBJ( "-password", password); OPTBOOL( "-require", require); OPTBOOL( "-request", request); OPTBOOL( "-server", server); OPTBOOL( "-ssl2", ssl2); OPTBOOL( "-ssl3", ssl3); OPTBOOL( "-tls1", tls1); - OPTBAD( "option", "-cafile, -cadir, -certfile, -cipher, -command, -keyfile, -model, -require, -request, -ssl2, -ssl3, -server, or -tls1"); + OPTBAD( "option", "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -model, -password, -require, -request, -server, -ssl2, -ssl3, or -tls1"); return TCL_ERROR; } if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; @@ -689,37 +723,10 @@ if (key && !*key) key = NULL; if (ciphers && !*ciphers) ciphers = NULL; if (CAfile && !*CAfile) CAfile = NULL; if (CAdir && !*CAdir) CAdir = NULL; - if (model != NULL) { - int mode; - /* Get the "model" context */ - chan = Tcl_GetChannel(interp, model, &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - } - if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { - Tcl_AppendResult(interp, "bad channel \"", - Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); - return TCL_ERROR; - } - statePtr = (State *) Tcl_GetChannelInstanceData(chan); - ctx = statePtr->ctx; - } else { - if ((ctx = CTX_Init(interp, proto, key, cert, CAdir, CAfile, ciphers)) - == (SSL_CTX*)0) { - return TCL_ERROR; - } - } - /* new SSL state */ statePtr = (State *) Tcl_Alloc((unsigned) sizeof(State)); statePtr->self = (Tcl_Channel)NULL; statePtr->timer = (Tcl_TimerToken)NULL; @@ -727,18 +734,68 @@ statePtr->watchMask = 0; statePtr->mode = 0; statePtr->interp = interp; statePtr->callback = (Tcl_Obj *)0; + statePtr->password = (Tcl_Obj *)0; statePtr->vflags = verify; statePtr->ssl = (SSL*)0; - statePtr->ctx = ctx; + statePtr->ctx = (SSL_CTX*)0; statePtr->bio = (BIO*)0; statePtr->p_bio = (BIO*)0; statePtr->err = ""; + + /* allocate script */ + if (script) { + char *tmp = Tcl_GetStringFromObj(script, NULL); + if (tmp && *tmp) { + statePtr->callback = Tcl_DuplicateObj(script); + Tcl_IncrRefCount(statePtr->callback); + } + } + + /* allocate password */ + if (password) { + char *tmp = Tcl_GetStringFromObj(password, NULL); + if (tmp && *tmp) { + statePtr->password = Tcl_DuplicateObj(password); + Tcl_IncrRefCount(statePtr->password); + } + } + + if (model != NULL) { + int mode; + /* Get the "model" context */ + chan = Tcl_GetChannel(interp, model, &mode); + if (chan == (Tcl_Channel) NULL) { + Tls_Free((char *) statePtr); + return TCL_ERROR; + } + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + } + if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { + Tcl_AppendResult(interp, "bad channel \"", + Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); + Tls_Free((char *) statePtr); + return TCL_ERROR; + } + ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx; + } else { + if ((ctx = CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers)) + == (SSL_CTX*)0) { + Tls_Free((char *) statePtr); + return TCL_ERROR; + } + } + + statePtr->ctx = ctx; /* * We need to make sure that the channel works in binary (for the * encryption not to get goofed up). * We only want to adjust the buffering in pre-v2 channels, where @@ -763,24 +820,10 @@ */ Tls_Free((char *) statePtr); return TCL_ERROR; } - /* allocate script */ - if (script) { - char *tmp = Tcl_GetStringFromObj(script, NULL); - if (tmp && *tmp) { - statePtr->callback = Tcl_DuplicateObj(script); - Tcl_IncrRefCount(statePtr->callback); - } - } - /* This is only needed because of a bug in OpenSSL, where the - * ssl->verify_callback is not referenced!!! (Must be done - * *before* SSL_new() is called! - */ - SSL_CTX_set_verify(statePtr->ctx, verify, VerifyCallback); - /* * SSL Initialization */ statePtr->ssl = SSL_new(statePtr->ctx); @@ -796,15 +839,11 @@ * SSL Callbacks */ SSL_set_app_data(statePtr->ssl, (VOID *)statePtr); /* point back to us */ - /* - * The following is broken - we need is to set the - * verify_mode, but the library ignores the verify_callback!!! - */ - /*SSL_set_verify(statePtr->ssl, verify, VerifyCallback);*/ + SSL_set_verify(statePtr->ssl, verify, VerifyCallback); SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback); /* Create Tcl_Channel BIO Handler */ statePtr->p_bio = BIO_new_tcl(statePtr, BIO_CLOSE); @@ -840,19 +879,20 @@ * *------------------------------------------------------------------- */ static SSL_CTX * -CTX_Init(interp, proto, key, cert, CAdir, CAfile, ciphers) - Tcl_Interp *interp; +CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers) + State *statePtr; int proto; char *key; char *cert; char *CAdir; char *CAfile; char *ciphers; { + Tcl_Interp *interp = statePtr->interp; SSL_CTX *ctx = NULL; Tcl_DString ds; Tcl_DString ds1; int off = 0; @@ -897,11 +937,11 @@ /* set some callbacks */ SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback); #ifndef BSAFE - SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)interp); + SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr); #endif #ifndef NO_DH { DH* dh = get_dh512(); @@ -928,10 +968,12 @@ if (key == NULL) key=cert; if (SSL_CTX_use_PrivateKey_file(ctx, F2N( key, &ds), SSL_FILETYPE_PEM) <= 0) { Tcl_DStringFree(&ds); + /* flush the passphrase which might be left in the result */ + Tcl_SetResult(interp, NULL, TCL_STATIC); Tcl_AppendResult(interp, "unable to set public key file ", key, " ", REASON(), (char *) NULL); SSL_CTX_free(ctx); return (SSL_CTX *)0; @@ -1050,11 +1092,12 @@ objPtr = Tls_NewX509Obj(interp, peer); } else { objPtr = Tcl_NewListObj(0, NULL); } - Tcl_ListObjAppendElement (interp, objPtr, Tcl_NewStringObj ("sbits", -1)); + Tcl_ListObjAppendElement (interp, objPtr, + Tcl_NewStringObj ("sbits", -1)); Tcl_ListObjAppendElement (interp, objPtr, Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, NULL))); ciphers = (char*)SSL_get_cipher(statePtr->ssl); if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) { @@ -1064,10 +1107,38 @@ Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1)); } Tcl_SetObjResult( interp, objPtr); return TCL_OK; } + +/* + *------------------------------------------------------------------- + * + * VersionObjCmd -- return version string from OpenSSL. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int +VersionObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + Tcl_Obj *objPtr; + + objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1); + + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} /* *------------------------------------------------------------------- * * Tls_Free -- @@ -1124,14 +1195,22 @@ if (statePtr->ssl) { SSL_shutdown(statePtr->ssl); SSL_free(statePtr->ssl); statePtr->ssl = NULL; + } + if (statePtr->ctx) { + SSL_CTX_free(statePtr->ctx); + statePtr->ctx = NULL; } if (statePtr->callback) { Tcl_DecrRefCount(statePtr->callback); statePtr->callback = NULL; + } + if (statePtr->password) { + Tcl_DecrRefCount(statePtr->password); + statePtr->password = NULL; } } /* *------------------------------------------------------------------- @@ -1221,10 +1300,13 @@ Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); return Tcl_PkgProvide(interp, PACKAGE, VERSION); } /*