︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
-
+
|
#define F2N(key, dsp) \
(((key) == NULL) ? (char *) NULL : \
Tcl_TranslateFileName(interp, (key), (dsp)))
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 *CApath, char *CAfile,
Tcl_Size key_asn1_len, Tcl_Size cert_asn1_len, char *CApath, char *CAfile,
char *ciphers, char *ciphersuites, int level, char *DHparams);
static int TlsLibInit(int uninitialize);
#define TLS_PROTO_SSL2 0x01
#define TLS_PROTO_SSL3 0x02
#define TLS_PROTO_TLS1 0x04
|
︙ | | |
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
-
+
|
*-------------------------------------------------------------------
*/
static void
InfoCallback(const SSL *ssl, int where, int ret) {
State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr;
char *major; char *minor;
const char *major, *minor;
dprintf("Called");
if (statePtr->callback == (Tcl_Obj*)NULL)
return;
if (where & SSL_CB_HANDSHAKE_START) {
|
︙ | | |
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
|
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
|
-
+
|
* Side effects:
* The err field of the currently operative State is set
* to a string describing the SSL negotiation failure reason
*
*-------------------------------------------------------------------
*/
void
Tls_Error(State *statePtr, char *msg) {
Tls_Error(State *statePtr, const char *msg) {
Tcl_Interp *interp = statePtr->interp;
Tcl_Obj *cmdPtr, *listPtr;
unsigned long err;
statePtr->err = msg;
dprintf("Called");
|
︙ | | |
1432
1433
1434
1435
1436
1437
1438
1439
1440
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
|
1432
1433
1434
1435
1436
1437
1438
1439
1440
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
|
-
-
+
+
-
-
+
+
+
+
|
"\": not a TLS channel", (char *) NULL);
Tcl_SetErrorCode(interp, "TLS", "IMPORT", "CHANNEL", "INVALID", (char *) NULL);
Tls_Free((tls_free_type *) 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, CApath, CAfile, ciphers, ciphersuites, level, DHparams)) == NULL) {
if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, cert, key_len,
cert_len, CApath, CAfile, ciphers, ciphersuites, level, DHparams)) == NULL) {
Tls_Free((tls_free_type *) 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
* each channel in the stack maintained its own buffers.
*/
Tcl_DStringInit(&upperChannelTranslation);
Tcl_DStringInit(&upperChannelBlocking);
Tcl_DStringInit(&upperChannelEOFChar);
Tcl_DStringInit(&upperChannelEncoding);
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);
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((tls_free_type *) statePtr);
Tcl_DStringFree(&upperChannelTranslation);
Tcl_DStringFree(&upperChannelEncoding);
Tcl_DStringFree(&upperChannelEOFChar);
Tcl_DStringFree(&upperChannelBlocking);
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));
|
︙ | | |
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
|
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
|
-
+
+
+
+
+
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
|
* Side effects:
* May modify the behavior of an IO channel.
*
*-------------------------------------------------------------------
*/
static int
UnimportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
Tcl_Channel chan; /* The channel to set a mode on. */
Tcl_Channel chan, child; /* The stacked and underlying channels */
Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar;
int res = TCL_OK;
(void) clientData;
dprintf("Called");
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
/* Validate channel name */
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
/* Make sure to operate on the topmost channel */
chan = Tcl_GetTopChannel(chan);
child = Tcl_GetStackedChannel(chan);
if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
/* Verify is a stacked channel */
if (child == NULL) {
Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
"\": not a TLS channel", (char *) NULL);
"\": not a stacked channel", (char *) NULL);
Tcl_SetErrorCode(interp, "TLS", "UNIMPORT", "CHANNEL", "INVALID", (char *) NULL);
return TCL_ERROR;
}
/* Flush any pending data */
if (Tcl_Flush(chan) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringInit(&upperChannelTranslation);
Tcl_DStringInit(&upperChannelBlocking);
Tcl_DStringInit(&upperChannelEOFChar);
Tcl_DStringInit(&upperChannelEncoding);
/* Get current config - EOL translation, encoding and buffering options are shared between all channels in the stack */
Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking);
Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding);
Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar);
Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation);
/* Unstack the channel and restore underlying channel config */
if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) {
return TCL_ERROR;
if (Tcl_UnstackChannel(interp, chan) == TCL_OK) {
Tcl_SetChannelOption(interp, child, "-encoding", Tcl_DStringValue(&upperChannelEncoding));
Tcl_SetChannelOption(interp, child, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar));
Tcl_SetChannelOption(interp, child, "-translation", Tcl_DStringValue(&upperChannelTranslation));
Tcl_SetChannelOption(interp, child, "-blocking", Tcl_DStringValue(&upperChannelBlocking));
} else {
res = TCL_ERROR;
}
/* Clean-up */
Tcl_DStringFree(&upperChannelTranslation);
Tcl_DStringFree(&upperChannelEncoding);
Tcl_DStringFree(&upperChannelEOFChar);
Tcl_DStringFree(&upperChannelBlocking);
return TCL_OK;
return res;
}
/*
*-------------------------------------------------------------------
*
* CTX_Init -- construct a SSL_CTX instance
*
* Results:
* A valid SSL_CTX instance or NULL.
*
* Side effects:
* constructs SSL context (CTX)
*
*-------------------------------------------------------------------
*/
static SSL_CTX *
CTX_Init(State *statePtr, int isServer, int proto, char *keyfile, char *certfile,
unsigned char *key, unsigned char *cert, int key_len, int cert_len, char *CApath,
unsigned char *key, unsigned char *cert, Tcl_Size key_len, Tcl_Size cert_len, char *CApath,
char *CAfile, char *ciphers, char *ciphersuites, int level, char *DHparams) {
Tcl_Interp *interp = statePtr->interp;
SSL_CTX *ctx = NULL;
Tcl_DString ds;
int off = 0, abort = 0;
int load_private_key;
const SSL_METHOD *method;
|
︙ | | |
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
|
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
|
-
+
|
SSL_CTX_free(ctx);
return NULL;
}
Tcl_DStringFree(&ds);
} else if (cert != NULL) {
load_private_key = 1;
if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) {
if (SSL_CTX_use_certificate_ASN1(ctx, (int) cert_len, cert) <= 0) {
Tcl_AppendResult(interp, "unable to set certificate: ",
GET_ERR_REASON(), (char *) NULL);
SSL_CTX_free(ctx);
return NULL;
}
} else {
certfile = (char*)X509_get_default_cert_file();
|
︙ | | |
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
|
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
|
-
+
|
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) {
if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key, (int) key_len) <= 0) {
/* flush the passphrase which might be left in the result */
Tcl_SetResult(interp, NULL, TCL_STATIC);
Tcl_AppendResult(interp, "unable to set public key: ", GET_ERR_REASON(), (char *) NULL);
SSL_CTX_free(ctx);
return NULL;
}
}
|
︙ | | |
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
|
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
|
+
+
+
|
res = SSL_get_peer_signature_nid(statePtr->ssl, &nid);
} else {
res = SSL_get_signature_nid(statePtr->ssl, &nid);
}
if (!res) {nid = 0;}
LAPPEND_STR(interp, objPtr, "signatureHashAlgorithm", OBJ_nid2ln(nid), -1);
/* Added in OpenSSL 1.1.1a */
#if OPENSSL_VERSION_NUMBER > 0x10101000L
if (objc == 2) {
res = SSL_get_peer_signature_type_nid(statePtr->ssl, &nid);
} else {
res = SSL_get_signature_type_nid(statePtr->ssl, &nid);
}
if (!res) {nid = 0;}
LAPPEND_STR(interp, objPtr, "signatureType", OBJ_nid2ln(nid), -1);
#endif
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*-------------------------------------------------------------------
|
︙ | | |
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
|
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
|
+
+
+
+
+
|
".static"
#endif
), NULL);
}
return TCL_OK;
}
/* Init script */
static const char tlsTclInitScript[] = {
#include "tls.tcl.h"
};
/*
*-------------------------------------------------------------------
*
* Tls_Init --
*
* This is a package initialization procedure, which is called
* by Tcl when this package is to be added to an interpreter.
|
︙ | | |
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
|
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
|
-
-
-
-
-
|
#if TCL_MAJOR_VERSION > 8
#define MIN_VERSION "9.0"
#else
#define MIN_VERSION "8.5"
#endif
static const char tlsTclInitScript[] = {
#include "tls.tcl.h"
0x00
};
DLLEXPORT int Tls_Init(Tcl_Interp *interp) {
dprintf("Called");
#ifdef USE_TCL_STUBS
if (Tcl_InitStubs(interp, MIN_VERSION, 0) == NULL) {
return TCL_ERROR;
|
︙ | | |
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
|
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
|
+
|
}
Tcl_CreateObjCommand(interp, "::tls::ciphers", CiphersObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::connection", ConnectionInfoObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::handshake", HandshakeObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::import", ImportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::unimport", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::unstack", UnimportObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::status", StatusObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::version", VersionObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::misc", MiscObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "::tls::protocols", ProtocolsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
BuildInfoCommand(interp);
|
︙ | | |
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
|
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
/* Initialize BOTH libcrypto and libssl. */
OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS | OPENSSL_INIT_LOAD_CRYPTO_STRINGS
| OPENSSL_INIT_ADD_ALL_CIPHERS | OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);
BIO_new_tcl(NULL, 0);
#if 0
/*
* XXX:TODO: Remove this code and replace it with a check
* for enough entropy and do not try to create our own
* terrible entropy
*/
/*
* Seed the random number generator in the SSL library,
* using the do/while construct because of the bug note in the
* OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1
*
* The crux of the problem is that Solaris 7 does not have a
* /dev/random or /dev/urandom device so it cannot gather enough
* entropy from the RAND_seed() when TLS initializes and refuses
* to go further. Earlier versions of OpenSSL carried on regardless.
*/
srand((unsigned int) time((time_t *) NULL));
do {
for (i = 0; i < 16; i++) {
rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0));
}
RAND_seed(rnd_seed, sizeof(rnd_seed));
} while (RAND_status() != 1);
#endif
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
Tcl_MutexUnlock(&init_mx);
#endif
return status;
}
|