TclTLS
Check-in [fad32ff05f]
Login
HomeTimelineDownloadBrowse SourceBranchesTagsTicketsWiki
Overview
Comment:Added more logging messages and updated get error message macro name
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: fad32ff05f165d2435e548d30ac464579d3b57d06a67c3bd9ef498a098779b99
User & Date: bohagan on 2024-02-02 03:33:04
Other Links: manifest | tags
Context
2024-02-03
03:15
Added more IO logging and error callback messages. Removed duplicate messages. check-in: a3728bd654 user: bohagan tags: trunk
2024-02-02
03:33
Added more logging messages and updated get error message macro name check-in: fad32ff05f user: bohagan tags: trunk
2023-12-29
21:12
Cast unused parameters to void to prevent unused parameter warnings Source: https://core.tcl-lang.org/tcltls/tktview/086954612f check-in: 41e1203724 user: bohagan tags: trunk
Changes
Side-by-Side Diff Ignore Whitespace Patch
Modified generic/tls.c from [afd3785b3b] to [ea83c6521f].
︙
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

41
42
43
44
45
46
47

48
49
50
51
52
53
54








-








/*
 * Forward declarations
 */

#define F2N(key, dsp) \
	(((key) == NULL) ? (char *) NULL : \
		Tcl_TranslateFileName(interp, (key), (dsp)))
#define REASON()	ERR_reason_error_string(ERR_get_error())

static SSL_CTX *CTX_Init(State *statePtr, int isServer, int proto, char *key,
		char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1,
		int key_asn1_len, int cert_asn1_len, char *CAdir, char *CAfile,
		char *ciphers, char *ciphersuites, int level, char *DHparams);

static int	TlsLibInit(int uninitialize);
︙
107
108
109
110
111
112
113


114
115
116
117
118
119
120

121
122
123
124
125
126

127
128

129
130
131
132
133
134
135

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139








+
+







+






+


+








 *	Evaluates callback command
 *
 *-------------------------------------------------------------------
 */
static int
EvalCallback(Tcl_Interp *interp, State *statePtr, Tcl_Obj *cmdPtr) {
    int code, ok = 0;

    dprintf("Called");

    Tcl_Preserve((ClientData) interp);
    Tcl_Preserve((ClientData) statePtr);

    /* Eval callback with success for ok or return value 1, fail for error or return value 0 */
    Tcl_ResetResult(interp);
    code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
    dprintf("EvalCallback: %d", code);
    if (code == TCL_OK) {
	/* Check result for return value */
	Tcl_Obj *result = Tcl_GetObjResult(interp);
	if (result == NULL || Tcl_GetIntFromObj(interp, result, &ok) != TCL_OK) {
	    ok = 1;
	}
	dprintf("Result: %d", ok);
    } else {
	/* Error - reject the certificate */
	dprintf("Tcl_BackgroundError");
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
	Tcl_BackgroundError(interp);
#else
	Tcl_BackgroundException(interp, code);
#endif
    }
︙
366
367
368
369
370
371
372

373

374
375
376
377
378
379
380

370
371
372
373
374
375
376
377

378
379
380
381
382
383
384
385








+
-
+








    SSL   *ssl		= (SSL*)X509_STORE_CTX_get_ex_data(ctx, SSL_get_ex_data_X509_STORE_CTX_idx());
    X509  *cert		= X509_STORE_CTX_get_current_cert(ctx);
    State *statePtr	= (State*)SSL_get_app_data(ssl);
    Tcl_Interp *interp	= statePtr->interp;
    int depth		= X509_STORE_CTX_get_error_depth(ctx);
    int err		= X509_STORE_CTX_get_error(ctx);

    dprintf("Called");
    dprintf("Verify: %d", ok);
    dprintf("VerifyCallback: %d", ok);

    if (statePtr->vcmd == (Tcl_Obj*)NULL) {
	if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
	    return ok;
	} else {
	    return 1;
	}
︙
1018
1019
1020
1021
1022
1023
1024
1025

1026
1027
1028
1029
1030
1031

1032
1033
1034
1035
1036
1037
1038

1023
1024
1025
1026
1027
1028
1029

1030
1031
1032
1033
1034
1035

1036
1037
1038
1039
1040
1041
1042
1043








-
+





-
+








	default:
	    method = TLS_method();
	    break;
    }

    ctx = SSL_CTX_new(method);
    if (ctx == NULL) {
	Tcl_AppendResult(interp, REASON(), NULL);
	Tcl_AppendResult(interp, GET_ERR_REASON(), NULL);
	return TCL_ERROR;
    }

    ssl = SSL_new(ctx);
    if (ssl == NULL) {
	Tcl_AppendResult(interp, REASON(), NULL);
	Tcl_AppendResult(interp, GET_ERR_REASON(), NULL);
	SSL_CTX_free(ctx);
	return TCL_ERROR;
    }

    /* Use list and order as would be sent in a ClientHello or all available ciphers */
    if (use_supported) {
	sk = SSL_get1_supported_ciphers(ssl);
︙
1441
1442
1443
1444
1445
1446
1447
1448


1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469

1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480

1481
1482
1483
1484
1485
1486
1487
1488
1489

1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500

1501
1502
1503
1504
1505
1506
1507

1446
1447
1448
1449
1450
1451
1452

1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474

1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485

1486
1487
1488
1489
1490
1491
1492
1493
1494

1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505

1506
1507
1508
1509
1510
1511
1512
1513








-
+
+




















-
+










-
+








-
+










-
+








    Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar);
    Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding);
    Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation);
    Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking);
    Tcl_SetChannelOption(interp, chan, "-translation", "binary");
    Tcl_SetChannelOption(interp, chan, "-blocking", "true");
    dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan));
    statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan);
    statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr,
	(TCL_READABLE | TCL_WRITABLE), chan);
    dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self));
    if (statePtr->self == (Tcl_Channel) NULL) {
	/*
	 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
	 */
	Tls_Free((char *) statePtr);
	return TCL_ERROR;
    }

    Tcl_SetChannelOption(interp, statePtr->self, "-translation", Tcl_DStringValue(&upperChannelTranslation));
    Tcl_SetChannelOption(interp, statePtr->self, "-encoding", Tcl_DStringValue(&upperChannelEncoding));
    Tcl_SetChannelOption(interp, statePtr->self, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar));
    Tcl_SetChannelOption(interp, statePtr->self, "-blocking", Tcl_DStringValue(&upperChannelBlocking));

    /*
     * SSL Initialization
     */
    statePtr->ssl = SSL_new(statePtr->ctx);
    if (!statePtr->ssl) {
	/* SSL library error */
	Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), (char *) NULL);
	Tcl_AppendResult(interp, "couldn't construct ssl session: ", GET_ERR_REASON(), (char *) NULL);
	    Tcl_SetErrorCode(interp, "TLS", "IMPORT", "INIT", "FAILED", (char *) NULL);
	Tls_Free((char *) statePtr);
	return TCL_ERROR;
    }

    /* Set host server name */
    if (servername) {
	/* Sets the server name indication (SNI) in ClientHello extension */
	/* Per RFC 6066, hostname is a ASCII encoded string, though RFC 4366 says UTF-8. */
	if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) {
	    Tcl_AppendResult(interp, "setting TLS host name extension failed", (char *) NULL);
	    Tcl_AppendResult(interp, "Set SNI extension failed: ", GET_ERR_REASON(), (char *) NULL);
	    Tcl_SetErrorCode(interp, "TLS", "IMPORT", "SNI", "FAILED", (char *) NULL);
	    Tls_Free((char *) statePtr);
	    return TCL_ERROR;
	}

	/* Set hostname for peer certificate hostname verification in clients.
	   Don't use SSL_set1_host since it has limitations. */
	if (!SSL_add1_host(statePtr->ssl, servername)) {
	    Tcl_AppendResult(interp, "setting DNS host name failed", (char *) NULL);
	    Tcl_AppendResult(interp, "Set DNS hostname failed: ", GET_ERR_REASON(), (char *) NULL);
	    Tcl_SetErrorCode(interp, "TLS", "IMPORT", "HOSTNAME", "FAILED", (char *) NULL);
	    Tls_Free((char *) statePtr);
	    return TCL_ERROR;
	}
    }

    /* Resume session id */
    if (session_id && strlen(session_id) <= SSL_MAX_SID_CTX_LENGTH) {
	/* SSL_set_session() */
	if (!SSL_SESSION_set1_id_context(SSL_get_session(statePtr->ssl), session_id, (unsigned int) strlen(session_id))) {
	    Tcl_AppendResult(interp, "Resume session id ", session_id, " failed", (char *) NULL);
	    Tcl_AppendResult(interp, "Resume session failed: ", GET_ERR_REASON(), (char *) NULL);
	    Tcl_SetErrorCode(interp, "TLS", "IMPORT", "SESSION", "FAILED", (char *) NULL);
	    Tls_Free((char *) statePtr);
	    return TCL_ERROR;
	}
    }

    /* Enable Application-Layer Protocol Negotiation. Examples are: http/1.0,
︙
1519
1520
1521
1522
1523
1524
1525
1526

1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547

1548
1549
1550
1551
1552
1553
1554

1525
1526
1527
1528
1529
1530
1531

1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552

1553
1554
1555
1556
1557
1558
1559
1560








-
+




















-
+








	    return TCL_ERROR;
	}

	/* Determine the memory required for the protocol-list */
	for (i = 0; i < cnt; i++) {
	    Tcl_GetStringFromObj(list[i], &len);
	    if (len > 255) {
		Tcl_AppendResult(interp, "ALPN protocol name too long", (char *) NULL);
		Tcl_AppendResult(interp, "ALPN protocol names 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;
	}

	/* 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);
	    p += len;
	}

	/* SSL_set_alpn_protos makes a copy of the protocol-list */
	/* Note: This functions reverses the return value convention */
	if (SSL_set_alpn_protos(statePtr->ssl, protos, protos_len)) {
	    Tcl_AppendResult(interp, "failed to set ALPN protocols", (char *) NULL);
	    Tcl_AppendResult(interp, "Set ALPN protocols failed: ", GET_ERR_REASON(), (char *) NULL);
	    Tcl_SetErrorCode(interp, "TLS", "IMPORT", "ALPN", "FAILED", (char *) NULL);
	    Tls_Free((char *) statePtr);
	    ckfree(protos);
	    return TCL_ERROR;
	}

	/* Store protocols list */
︙
1906
1907
1908
1909
1910
1911
1912
1913

1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931

1932
1933
1934
1935
1936
1937
1938
1939
1940

1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951

1952
1953
1954
1955
1956
1957
1958

1912
1913
1914
1915
1916
1917
1918

1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936

1937
1938
1939
1940
1941
1942
1943
1944
1945

1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956

1957
1958
1959
1960
1961
1962
1963
1964








-
+

















-
+








-
+










-
+








	    }
	    SSL_CTX_set_tmp_dh(ctx, dh);
	    DH_free(dh);

	} else {
	    /* Use well known DH parameters that have built-in support in OpenSSL */
	    if (!SSL_CTX_set_dh_auto(ctx, 1)) {
		Tcl_AppendResult(interp, "Could not enable set DH auto: ", REASON(), (char *) NULL);
		Tcl_AppendResult(interp, "Could not enable set DH auto: ", GET_ERR_REASON(), (char *) NULL);
		SSL_CTX_free(ctx);
		return NULL;
	    }
	}
    }
#endif

    /* set our certificate */
    load_private_key = 0;
    if (certfile != NULL) {
	load_private_key = 1;

	Tcl_DStringInit(&ds);

	if (SSL_CTX_use_certificate_file(ctx, F2N(certfile, &ds), SSL_FILETYPE_PEM) <= 0) {
	    Tcl_DStringFree(&ds);
	    Tcl_AppendResult(interp, "unable to set certificate file ", certfile, ": ",
			     REASON(), (char *) NULL);
		GET_ERR_REASON(), (char *) NULL);
	    SSL_CTX_free(ctx);
	    return NULL;
	}
    } else if (cert != NULL) {
	load_private_key = 1;
	if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) {
	    Tcl_DStringFree(&ds);
	    Tcl_AppendResult(interp, "unable to set certificate: ",
			     REASON(), (char *) NULL);
		GET_ERR_REASON(), (char *) NULL);
	    SSL_CTX_free(ctx);
	    return NULL;
	}
    } else {
	certfile = (char*)X509_get_default_cert_file();

	if (SSL_CTX_use_certificate_file(ctx, certfile, SSL_FILETYPE_PEM) <= 0) {
#if 0
	    Tcl_DStringFree(&ds);
	    Tcl_AppendResult(interp, "unable to use default certificate file ", certfile, ": ",
			     REASON(), (char *) NULL);
		GET_ERR_REASON(), (char *) NULL);
	    SSL_CTX_free(ctx);
	    return NULL;
#endif
	}
    }

    /* set our private key */
︙
1968
1969
1970
1971
1972
1973
1974
1975

1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986

1987
1988
1989
1990
1991
1992
1993

1974
1975
1976
1977
1978
1979
1980

1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991

1992
1993
1994
1995
1996
1997
1998
1999








-
+










-
+








	    }

	    if (SSL_CTX_use_PrivateKey_file(ctx, F2N(keyfile, &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 ", keyfile, " ",
			         REASON(), (char *) NULL);
		    GET_ERR_REASON(), (char *) NULL);
		SSL_CTX_free(ctx);
		return NULL;
	    }
	    Tcl_DStringFree(&ds);

	} else if (key != NULL) {
	    if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 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: ", REASON(), (char *) NULL);
		Tcl_AppendResult(interp, "unable to set public key: ", GET_ERR_REASON(), (char *) NULL);
		SSL_CTX_free(ctx);
		return NULL;
	    }
	}
	/* Now we know that a key and cert have been set against
	 * the SSL context */
	if (!SSL_CTX_check_private_key(ctx)) {
︙
2009
2010
2011
2012
2013
2014
2015
2016

2017
2018
2019
2020
2021
2022
2023

2015
2016
2017
2018
2019
2020
2021

2022
2023
2024
2025
2026
2027
2028
2029








-
+








	/* int SSL_CTX_set_default_verify_dir(SSL_CTX *ctx) and int SSL_CTX_set_default_verify_file(SSL_CTX *ctx) */
    if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) ||
	!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: ", REASON(), (char *) NULL);
	Tcl_AppendResult(interp, "SSL default verify paths: ", GET_ERR_REASON(), (char *) NULL);
	SSL_CTX_free(ctx);
	return NULL;
#endif
    }

    /* https://sourceforge.net/p/tls/bugs/57/ */
    /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */
︙
Modified generic/tlsIO.c from [77989c2965] to [30eb8c78b0].
︙
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205

206
207
208
209

210
211
212
213
214
215
216

179
180
181
182
183
184
185

186
187
188
189

190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216








-




-














+




+








	}

	if (bioShouldRetry) {
	    dprintf("The I/O did not complete -- but we should try it again");

	    if (statePtr->flags & TLS_TCL_ASYNC) {
		dprintf("Returning EAGAIN so that it can be retried later");

		*errorCodePtr = EAGAIN;
		return(-1);
	    } else {
		dprintf("Doing so now");

		continue;
	    }
	}

	dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though");
	break;
    }

    switch (rc) {
	case SSL_ERROR_NONE:
	    /* The connection is up, we are done here */
	    dprintf("The connection is up");
	    *errorCodePtr = 0;
	    break;

	case SSL_ERROR_ZERO_RETURN:
	    dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...");
	    *errorCodePtr = EINVAL;
	    return(-1);

	case SSL_ERROR_SYSCALL:
	    backingError = ERR_get_error();

	    if (backingError == 0 && err == 0) {
		dprintf("EOF reached")
		*errorCodePtr = ECONNRESET;
	    } else if (backingError == 0 && err == -1) {
︙
Modified generic/tlsInt.h from [0103fefac9] to [078f282c5e].
︙
100
101
102
103
104
105
106

107
108
109
110
111
112
113

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114








+








#else
#define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); }
#define dprintBuffer(bufferName, bufferLength) /**/
#define dprintFlags(statePtr) /**/
#endif

#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err))))
#define GET_ERR_REASON()	ERR_reason_error_string(ERR_get_error())

/* Common list append macros */
#define LAPPEND_BARRAY(interp, obj, text, value, size) {\
    if (text != NULL) Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(text, -1)); \
    Tcl_ListObjAppendElement(interp, obj, Tcl_NewByteArrayObj(value, size)); \
}
#define LAPPEND_STR(interp, obj, text, value, size) {\
︙
Powered by Fossil · RSS