@@ -3,11 +3,11 @@ * 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.16 2003/05/15 21:02:10 razzell Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.17 2003/07/07 20:24:49 hobbs 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 @@ -52,10 +52,13 @@ static int StatusObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int VersionObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static int MiscObjCmd _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 @@ -69,17 +72,17 @@ #ifndef NO_DH /* from openssl/apps/s_server.c */ static unsigned char dh512_p[]={ - 0xDA,0x58,0x3C,0x16,0xD9,0x85,0x22,0x89,0xD0,0xE4,0xAF,0x75, - 0x6F,0x4C,0xCA,0x92,0xDD,0x4B,0xE5,0x33,0xB8,0x04,0xFB,0x0F, - 0xED,0x94,0xEF,0x9C,0x8A,0x44,0x03,0xED,0x57,0x46,0x50,0xD3, - 0x69,0x99,0xDB,0x29,0xD7,0x76,0x27,0x6B,0xA2,0xD3,0xD4,0x12, - 0xE2,0x18,0xF4,0xDD,0x1E,0x08,0x4C,0xF6,0xD8,0x00,0x3E,0x7C, - 0x47,0x74,0xE8,0x33, - }; + 0xDA,0x58,0x3C,0x16,0xD9,0x85,0x22,0x89,0xD0,0xE4,0xAF,0x75, + 0x6F,0x4C,0xCA,0x92,0xDD,0x4B,0xE5,0x33,0xB8,0x04,0xFB,0x0F, + 0xED,0x94,0xEF,0x9C,0x8A,0x44,0x03,0xED,0x57,0x46,0x50,0xD3, + 0x69,0x99,0xDB,0x29,0xD7,0x76,0x27,0x6B,0xA2,0xD3,0xD4,0x12, + 0xE2,0x18,0xF4,0xDD,0x1E,0x08,0x4C,0xF6,0xD8,0x00,0x3E,0x7C, + 0x47,0x74,0xE8,0x33, + }; static unsigned char dh512_g[]={ 0x02, }; static DH *get_dh512() @@ -389,11 +392,11 @@ int result; if (statePtr->password == NULL) { if (Tcl_Eval(interp, "tls::password") == TCL_OK) { char *ret = (char *) Tcl_GetStringResult(interp); - strncpy(buf, ret, size); + strncpy(buf, ret, size); return strlen(ret); } else { return -1; } } @@ -413,11 +416,11 @@ Tcl_Release((ClientData) statePtr); Tcl_Release((ClientData) statePtr->interp); if (result == TCL_OK) { char *ret = (char *) Tcl_GetStringResult(interp); - strncpy(buf, ret, size); + strncpy(buf, ret, size); return strlen(ret); } else { return -1; } } @@ -459,11 +462,11 @@ char *cp, buf[BUFSIZ]; int index, verbose = 0; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIndexFromObj( interp, objv[1], protocols, "protocol", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -567,27 +570,27 @@ State *statePtr; /* client state for ssl socket */ int ret = 1; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); - return TCL_ERROR; + return TCL_ERROR; } chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + 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; + Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), + "\": not a TLS channel", NULL); + return TCL_ERROR; } statePtr = (State *)Tcl_GetChannelInstanceData(chan); if (!SSL_is_init_finished(statePtr->ssl)) { int err; @@ -596,11 +599,11 @@ CONST char *errStr = statePtr->err; Tcl_ResetResult(interp); Tcl_SetErrno(err); if (!errStr || *errStr == 0) { - errStr = Tcl_PosixError(interp); + errStr = Tcl_PosixError(interp); } Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL); return TCL_ERROR; @@ -668,16 +671,16 @@ int proto = 0; int verify = 0, require = 0, request = 1; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?"); - return TCL_ERROR; + return TCL_ERROR; } chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { /* * Make sure to operate on the topmost channel */ @@ -708,13 +711,13 @@ 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) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; - if (verify == 0) verify = SSL_VERIFY_NONE; + if (verify == 0) verify = SSL_VERIFY_NONE; proto |= (ssl2 ? TLS_PROTO_SSL2 : 0); proto |= (ssl3 ? TLS_PROTO_SSL3 : 0); proto |= (tls1 ? TLS_PROTO_TLS1 : 0); @@ -817,24 +820,24 @@ if (statePtr->self == (Tcl_Channel) NULL) { /* * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. */ Tls_Free((char *) statePtr); - return TCL_ERROR; + return TCL_ERROR; } /* * SSL Initialization */ statePtr->ssl = SSL_new(statePtr->ctx); if (!statePtr->ssl) { - /* SSL library error */ - Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), + /* SSL library error */ + Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), (char *) NULL); Tls_Free((char *) statePtr); - return TCL_ERROR; + return TCL_ERROR; } /* * SSL Callbacks */ @@ -952,64 +955,64 @@ /* set our certificate */ if (cert != NULL) { Tcl_DStringInit(&ds); - if (SSL_CTX_use_certificate_file(ctx, F2N( cert, &ds), + if (SSL_CTX_use_certificate_file(ctx, F2N( cert, &ds), SSL_FILETYPE_PEM) <= 0) { Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "unable to set certificate file ", cert, ": ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - - /* get the private key associated with this certificate */ - if (key == NULL) key=cert; - - if (SSL_CTX_use_PrivateKey_file(ctx, F2N( key, &ds), + Tcl_AppendResult(interp, + "unable to set certificate file ", cert, ": ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + + /* get the private key associated with this certificate */ + 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; - } + Tcl_AppendResult(interp, + "unable to set public key file ", key, " ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } Tcl_DStringFree(&ds); - /* Now we know that a key and cert have been set against - * the SSL context */ - if (!SSL_CTX_check_private_key(ctx)) { - Tcl_AppendResult(interp, - "private key does not match the certificate public key", - (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } + /* Now we know that a key and cert have been set against + * the SSL context */ + if (!SSL_CTX_check_private_key(ctx)) { + Tcl_AppendResult(interp, + "private key does not match the certificate public key", + (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } } else { - cert = (char*)X509_get_default_cert_file(); + cert = (char*)X509_get_default_cert_file(); - if (SSL_CTX_use_certificate_file(ctx, cert, + if (SSL_CTX_use_certificate_file(ctx, cert, SSL_FILETYPE_PEM) <= 0) { #if 0 Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "unable to use default certificate file ", cert, ": ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; + Tcl_AppendResult(interp, + "unable to use default certificate file ", cert, ": ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; #endif - } + } } Tcl_DStringInit(&ds); Tcl_DStringInit(&ds1); if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) || - !SSL_CTX_set_default_verify_paths(ctx)) { + !SSL_CTX_set_default_verify_paths(ctx)) { #if 0 Tcl_DStringFree(&ds); Tcl_DStringFree(&ds1); /* Don't currently care if this fails */ Tcl_AppendResult(interp, "SSL default verify paths: ", @@ -1077,13 +1080,13 @@ * 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; + Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), + "\": not a TLS channel", NULL); + return TCL_ERROR; } statePtr = (State *) Tcl_GetChannelInstanceData(chan); if (objc == 2) peer = SSL_get_peer_certificate(statePtr->ssl); else @@ -1135,10 +1138,170 @@ objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } + +/* + *------------------------------------------------------------------- + * + * MiscObjCmd -- misc commands + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int +MiscObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + const char *commands [] = { "req", NULL }; + enum command { C_REQ, C_DUMMY }; + int cmd; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], commands, + "command", 0,&cmd) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum command) cmd) { + case C_REQ: { + EVP_PKEY *pkey=NULL; + X509 *cert=NULL; + X509_NAME *name=NULL; + Tcl_Obj **listv; + int listc,i; + + BIO *in=NULL,*out=NULL; + + char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email=""; + char *keyout,*pemout,*str; + int keysize,serial=0,days=365; + + if ((objc<5) || (objc>6)) { + Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) { + return TCL_ERROR; + } + keyout=Tcl_GetString(objv[3]); + pemout=Tcl_GetString(objv[4]); + + if (objc>=6) { + if (Tcl_ListObjGetElements(interp, objv[5], + &listc, &listv) != TCL_OK) { + return TCL_ERROR; + } + + if ((listc%2) != 0) { + Tcl_SetResult(interp,"Information list must have even number of arguments",NULL); + return TCL_ERROR; + } + for (i=0; i