tls - binding to OpenSSL toolkit.
package require Tcl 8.4
+
package require Tcl 8.5
package require tls
tls::init ?options?
tls::socket ?options? host port
tls::socket ?-server command? ?options? port
@@ -63,12 +69,18 @@
tls::handshake channel
tls::import channel ?options?
tls::unimport channel
tls::ciphers protocol ?verbose? ?supported?
-tls::protocols
-tls::version
+tls::protocols
+tls::version
+
+tls::hash type data
+tls::md4 data
+tls::md5 data
+tls::sha1 data
+tls::sha256 data
This extension provides a generic binding to tls1.3. Exact list depends on OpenSSL version and
compile time flags.
Index: generic/tls.c
==================================================================
--- generic/tls.c
+++ generic/tls.c
@@ -444,11 +444,11 @@
Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
if (msg != NULL) {
Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(msg, -1));
- } else if ((msg = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), (Tcl_Size *)NULL)) != NULL) {
+ } else if ((msg = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL)) != NULL) {
Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(msg, -1));
} else {
listPtr = Tcl_NewListObj(0, NULL);
while ((err = ERR_get_error()) != 0) {
@@ -551,19 +551,19 @@
Tcl_Release((ClientData) statePtr);
/* If successful, pass back password string and truncate if too long */
if (code == TCL_OK) {
- Tcl_Size len;
+ int len;
char *ret = (char *) Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
- if (len > (Tcl_Size) size-1) {
- len = (Tcl_Size) size-1;
+ if (len > size-1) {
+ len = size-1;
}
strncpy(buf, ret, (size_t) len);
buf[len] = '\0';
Tcl_Release((ClientData) interp);
- return((int) len);
+ return(len);
}
Tcl_Release((ClientData) interp);
return -1;
}
@@ -613,15 +613,15 @@
Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
/* Session id */
session_id = SSL_SESSION_get_id(session, &ulen);
- Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(session_id, (Tcl_Size) ulen));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(session_id, (int) ulen));
/* Session ticket */
SSL_SESSION_get0_ticket(session, &ticket, &len2);
- Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(ticket, (Tcl_Size) len2));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewByteArrayObj(ticket, (int) len2));
/* Lifetime - number of seconds */
Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewLongObj((long) SSL_SESSION_get_ticket_lifetime_hint(session)));
@@ -902,11 +902,11 @@
/* Create command to eval */
cmdPtr = Tcl_DuplicateObj(statePtr->vcmd);
Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj("hello", -1));
Tcl_ListObjAppendElement(interp, cmdPtr,
Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
- Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(servername, (Tcl_Size) len));
+ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewStringObj(servername, (int) len));
/* Eval callback command */
Tcl_IncrRefCount(cmdPtr);
if ((code = EvalCallback(interp, statePtr, cmdPtr)) > 1) {
res = SSL_CLIENT_HELLO_RETRY;
@@ -923,10 +923,125 @@
/********************/
/* Commands */
/********************/
+/*
+ *-------------------------------------------------------------------
+ *
+ * Hash Calc -- return hash hex string for message digest
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+int
+HashCalc(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const EVP_MD *type) {
+ char *data;
+ int len;
+ unsigned int mdlen;
+ unsigned char mdbuf[EVP_MAX_MD_SIZE];
+ unsigned char hashbuf[EVP_MAX_MD_SIZE*2+1];
+ const char *hex = "0123456789ABCDEF";
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ data = Tcl_GetByteArrayFromObj(objv[1], &len);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* Calc hash, convert to hex string, and write to result */
+ if (EVP_Digest(data, (size_t) len, mdbuf, &mdlen, type, NULL)) {
+ unsigned char *mptr = mdbuf;
+ unsigned char *hptr = &hashbuf[0];
+
+ for (unsigned int i = 0; i < mdlen; i++) {
+ *hptr++ = hex[(*mptr>>4)&0xF];
+ *hptr++ = hex[(*mptr++)&0xF];
+ }
+ *hptr = 0;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(hashbuf, mdlen*2));
+ } else {
+ Tcl_SetResult(interp, "Hash calculation error", NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Hash Commands -- Return hash hex string for message digest
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------
+ */
+HashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ int len;
+ const char *name;
+ const EVP_MD *type;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type data");
+ return TCL_ERROR;
+ }
+
+ name = Tcl_GetStringFromObj(objv[1],&len);
+ if (name == NULL || (type = EVP_get_digestbyname(name)) == NULL) {
+ Tcl_AppendResult(interp, "Invalid digest type \"", name, "\"", NULL);
+ return TCL_ERROR;
+ }
+ objc--;
+ objv++;
+ return HashCalc(interp, objc, objv, type);
+}
+
+/*
+ * Command to Calculate MD4 Hash
+ */
+int
+HashMD4Cmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ return HashCalc(interp, objc, objv, EVP_md4());
+}
+
+/*
+ * Command to Calculate MD5 Hash
+ */
+int
+HashMD5Cmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ return HashCalc(interp, objc, objv, EVP_md5());
+}
+
+/*
+ * Command to Calculate SHA-1 Hash
+ */
+int
+HashSHA1Cmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ return HashCalc(interp, objc, objv, EVP_sha1());
+}
+
+/*
+ * Command to Calculate SHA-256 Hash
+ */
+int
+HashSHA256Cmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ return HashCalc(interp, objc, objv, EVP_sha256());
+}
+
/*
*-------------------------------------------------------------------
*
* CiphersObjCmd -- list available ciphers
*
@@ -1171,11 +1286,11 @@
return(TCL_ERROR);
}
ERR_clear_error();
- chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], (Tcl_Size *)NULL), NULL);
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
if (chan == (Tcl_Channel) NULL) {
return(TCL_ERROR);
}
/* Make sure to operate on the topmost channel */
@@ -1249,20 +1364,19 @@
SSL_CTX *ctx = NULL;
Tcl_Obj *script = NULL;
Tcl_Obj *password = NULL;
Tcl_Obj *vcmd = NULL;
Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar;
- int idx;
- Tcl_Size len;
+ int idx, len;
int flags = TLS_TCL_INIT;
int server = 0; /* is connection incoming or outgoing? */
char *keyfile = NULL;
char *certfile = NULL;
unsigned char *key = NULL;
- Tcl_Size key_len = 0;
+ int key_len = 0;
unsigned char *cert = NULL;
- Tcl_Size cert_len = 0;
+ int cert_len = 0;
char *ciphers = NULL;
char *ciphersuites = NULL;
char *CAfile = NULL;
char *CAdir = NULL;
char *DHparams = NULL;
@@ -1295,20 +1409,20 @@
return TCL_ERROR;
}
ERR_clear_error();
- chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], (Tcl_Size *)NULL), NULL);
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
/* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
for (idx = 2; idx < objc; idx++) {
- char *opt = Tcl_GetStringFromObj(objv[idx], (Tcl_Size *)NULL);
+ char *opt = Tcl_GetStringFromObj(objv[idx], NULL);
if (opt[0] != '-')
break;
OPTOBJ("-alpn", alpn);
@@ -1424,12 +1538,12 @@
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx;
} else {
- if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, cert, (int) key_len,
- (int) cert_len, CAdir, CAfile, ciphers, ciphersuites, level, DHparams)) == NULL) {
+ if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, cert, key_len,
+ cert_len, CAdir, CAfile, ciphers, ciphersuites, level, DHparams)) == NULL) {
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
}
@@ -1515,12 +1629,11 @@
http/1.1, h2, h3, ftp, imap, pop3, xmpp-client, xmpp-server, mqtt, irc, etc. */
if (alpn) {
/* Convert a TCL list into a protocol-list in wire-format */
unsigned char *protos, *p;
unsigned int protos_len = 0;
- Tcl_Size cnt, i;
- int j;
+ int i, len, cnt;
Tcl_Obj **list;
if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
Tls_Free((char *) statePtr);
return TCL_ERROR;
@@ -1533,20 +1646,20 @@
Tcl_AppendResult(interp, "ALPN protocol name too long", (char *) NULL);
Tcl_SetErrorCode(interp, "TLS", "IMPORT", "ALPN", "FAILED", (char *) NULL);
Tls_Free((char *) statePtr);
return TCL_ERROR;
}
- protos_len += 1 + (int) len;
+ protos_len += 1 + len;
}
/* Build the complete protocol-list */
protos = ckalloc(protos_len);
/* protocol-lists consist of 8-bit length-prefixed, byte strings */
- for (j = 0, p = protos; j < cnt; j++) {
- char *str = Tcl_GetStringFromObj(list[j], &len);
- *p++ = (unsigned char) len;
- memcpy(p, str, (size_t) len);
+ for (i = 0, p = protos; i < cnt; i++) {
+ char *str = Tcl_GetStringFromObj(list[i], &len);
+ *p++ = len;
+ memcpy(p, str, len);
p += len;
}
/* SSL_set_alpn_protos makes a copy of the protocol-list */
/* Note: This functions reverses the return value convention */
@@ -1720,48 +1833,48 @@
const SSL_METHOD *method;
dprintf("Called");
if (!proto) {
- Tcl_AppendResult(interp, "no valid protocol selected", (char *) NULL);
+ Tcl_AppendResult(interp, "no valid protocol selected", NULL);
return NULL;
}
/* create SSL context */
#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
if (ENABLED(proto, TLS_PROTO_SSL2)) {
- Tcl_AppendResult(interp, "SSL2 protocol not supported", (char *) NULL);
+ Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
return NULL;
}
#endif
#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
if (ENABLED(proto, TLS_PROTO_SSL3)) {
- Tcl_AppendResult(interp, "SSL3 protocol not supported", (char *) NULL);
+ Tcl_AppendResult(interp, "SSL3 protocol not supported", NULL);
return NULL;
}
#endif
#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
if (ENABLED(proto, TLS_PROTO_TLS1)) {
- Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", (char *) NULL);
+ Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", NULL);
return NULL;
}
#endif
#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
- Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", (char *) NULL);
+ Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", NULL);
return NULL;
}
#endif
#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
- Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", (char *) NULL);
+ Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", NULL);
return NULL;
}
#endif
#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
if (ENABLED(proto, TLS_PROTO_TLS1_3)) {
- Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", (char *) NULL);
+ Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", NULL);
return NULL;
}
#endif
if (proto == 0) {
/* Use full range */
@@ -2062,11 +2175,11 @@
Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel");
return TCL_ERROR;
}
/* Get channel Id */
- channelName = Tcl_GetStringFromObj(objv[(objc == 2 ? 1 : 2)], (Tcl_Size *) NULL);
+ channelName = Tcl_GetStringFromObj(objv[(objc == 2 ? 1 : 2)], NULL);
chan = Tcl_GetChannel(interp, channelName, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
@@ -2132,11 +2245,11 @@
/* Verify mode depth */
LAPPEND_INT(interp, objPtr, "verifyDepth", SSL_get_verify_depth(statePtr->ssl));
/* Report the selected protocol as a result of the negotiation */
SSL_get0_alpn_selected(statePtr->ssl, &proto, &len);
- LAPPEND_STR(interp, objPtr, "alpn", (char *)proto, (Tcl_Size) len);
+ LAPPEND_STR(interp, objPtr, "alpn", (char *)proto, (int) len);
LAPPEND_STR(interp, objPtr, "protocol", SSL_get_version(statePtr->ssl), -1);
/* Valid for non-RSA signature and TLS 1.3 */
if (objc == 2) {
res = SSL_get_peer_signature_nid(statePtr->ssl, &nid);
@@ -2182,11 +2295,11 @@
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return(TCL_ERROR);
}
- chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], (Tcl_Size *)NULL), NULL);
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
if (chan == (Tcl_Channel) NULL) {
return(TCL_ERROR);
}
/* Make sure to operate on the topmost channel */
@@ -2289,16 +2402,16 @@
const unsigned char *session_id, *proto;
char buffer[SSL_MAX_MASTER_KEY_LENGTH];
/* Report the selected protocol as a result of the ALPN negotiation */
SSL_SESSION_get0_alpn_selected(session, &proto, &len2);
- LAPPEND_STR(interp, objPtr, "alpn", (char *) proto, (Tcl_Size) len2);
+ LAPPEND_STR(interp, objPtr, "alpn", (char *) proto, (int) len2);
/* Report the selected protocol as a result of the NPN negotiation */
#ifdef USE_NPN
SSL_get0_next_proto_negotiated(ssl, &proto, &ulen);
- LAPPEND_STR(interp, objPtr, "npn", (char *) proto, (Tcl_Size) ulen);
+ LAPPEND_STR(interp, objPtr, "npn", (char *) proto, (int) ulen);
#endif
/* Resumable session */
LAPPEND_BOOL(interp, objPtr, "resumable", SSL_SESSION_is_resumable(session));
@@ -2308,30 +2421,30 @@
/* Timeout value - SSL_CTX_get_timeout (in seconds) */
LAPPEND_LONG(interp, objPtr, "timeout", SSL_SESSION_get_timeout(session));
/* Session id - TLSv1.2 and below only */
session_id = SSL_SESSION_get_id(session, &ulen);
- LAPPEND_BARRAY(interp, objPtr, "session_id", session_id, (Tcl_Size) ulen);
+ LAPPEND_BARRAY(interp, objPtr, "session_id", session_id, (int) ulen);
/* Session context */
session_id = SSL_SESSION_get0_id_context(session, &ulen);
- LAPPEND_BARRAY(interp, objPtr, "session_context", session_id, (Tcl_Size) ulen);
+ LAPPEND_BARRAY(interp, objPtr, "session_context", session_id, (int) ulen);
/* Session ticket - client only */
SSL_SESSION_get0_ticket(session, &ticket, &len2);
- LAPPEND_BARRAY(interp, objPtr, "session_ticket", ticket, (Tcl_Size) len2);
+ LAPPEND_BARRAY(interp, objPtr, "session_ticket", ticket, (int) len2);
/* Session ticket lifetime hint (in seconds) */
LAPPEND_LONG(interp, objPtr, "lifetime", SSL_SESSION_get_ticket_lifetime_hint(session));
/* Ticket app data */
SSL_SESSION_get0_ticket_appdata(session, &ticket, &len2);
- LAPPEND_BARRAY(interp, objPtr, "ticket_app_data", ticket, (Tcl_Size) len2);
+ LAPPEND_BARRAY(interp, objPtr, "ticket_app_data", ticket, (int) len2);
/* Get master key */
len2 = SSL_SESSION_get_master_key(session, buffer, SSL_MAX_MASTER_KEY_LENGTH);
- LAPPEND_BARRAY(interp, objPtr, "master_key", buffer, (Tcl_Size) len2);
+ LAPPEND_BARRAY(interp, objPtr, "master_key", buffer, (int) len2);
/* Compression id */
unsigned int id = SSL_SESSION_get_compress_id(session);
LAPPEND_STR(interp, objPtr, "compression_id", id == 1 ? "zlib" : "none", -1);
}
@@ -2435,12 +2548,11 @@
*/
static int
MiscObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
static const char *commands [] = { "req", "strreq", NULL };
enum command { C_REQ, C_STRREQ, C_DUMMY };
- Tcl_Size cmd;
- int isStr;
+ int cmd, isStr;
char buffer[16384];
dprintf("Called");
if (objc < 2) {
@@ -2459,12 +2571,11 @@
case C_STRREQ: {
EVP_PKEY *pkey=NULL;
X509 *cert=NULL;
X509_NAME *name=NULL;
Tcl_Obj **listv;
- Tcl_Size listc;
- int i;
+ int listc,i;
BIO *out=NULL;
char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email="";
char *keyout,*pemout,*str;
@@ -2491,11 +2602,12 @@
Tcl_SetVar(interp,keyout,"",0);
Tcl_SetVar(interp,pemout,"",0);
}
if (objc>=6) {
- if (Tcl_ListObjGetElements(interp, objv[5], &listc, &listv) != TCL_OK) {
+ 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);
@@ -2771,11 +2883,11 @@
return TCL_ERROR;
}
#endif
if (TlsLibInit(0) != TCL_OK) {
- Tcl_AppendResult(interp, "could not initialize SSL library", (char *) NULL);
+ Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::connection", ConnectionInfoObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
@@ -2785,10 +2897,16 @@
Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "tls::protocols", ProtocolsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::hash", HashCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::md4", HashMD4Cmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::md5", HashMD5Cmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::sha1", HashSHA1Cmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "tls::sha256", HashSHA256Cmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
if (interp) {
Tcl_Eval(interp, tlsTclInitScript);
}
return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);
Index: generic/tlsBIO.c
==================================================================
--- generic/tlsBIO.c
+++ generic/tlsBIO.c
@@ -6,24 +6,23 @@
#include "tlsInt.h"
static int BioWrite(BIO *bio, const char *buf, int bufLen) {
Tcl_Channel chan;
- Tcl_Size ret;
+ int ret;
int tclEofChan, tclErrno;
chan = Tls_GetParent((State *) BIO_get_data(bio), 0);
dprintf("[chan=%p] BioWrite(%p,
+ CALLBACK OPTIONS