Check-in [d248bc5f5e]
Bounty program for improvements to Tcl and certain Tcl packages.
Overview
Comment:Ticket 47, applied patch with last suggested change by Jeff (moving setting of "initialization"-flag).
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: d248bc5f5ec13c7b414cbd39eb66d6c5e4159330
User & Date: andreas_kupries on 2014-04-16 18:33:03
Other Links: manifest | tags
Context
2014-12-08
19:09
Applied patches #12 and #13 for Server Name Indication (SNI) support, and TLS 1.1, 1.2 support. check-in: 54d14de805 user: andreas_kupries tags: trunk
2014-04-16
18:33
Ticket 47, applied patch with last suggested change by Jeff (moving setting of "initialization"-flag). check-in: d248bc5f5e user: andreas_kupries tags: trunk
2012-07-09
23:28
* configure.in: Bump to version 1.6.3. * win/makefile.vc: * configure: regen with ac-2.59 * tls.c (MiscObjCmd): Fixed non-static string array used in call of Tcl_GetIndexFromObj(). Memory smash waiting to happen. Thanks to Brian Griffin for alerting us all to the problem. check-in: c1eb553b32 user: andreas_kupries tags: trunk
Changes

Modified tls.c from [493d79f8dc] to [34519f36fc].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
61
62
63
64
65
66
67


68
69
70
71
72
73
74
...
143
144
145
146
147
148
149


150
151
152
153
154
155
156
....
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
....
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
....
1631
1632
1633
1634
1635
1636
1637



















































































/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 * some modifications:
 *	Copyright (C) 2000 Ajuba Solutions
 *	Copyright (C) 2002 ActiveState Corporation
 *	Copyright (C) 2004 Starfish Systems 
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.33 2012/07/09 23:28:02 andreas_kupries 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
 * OpenSSL 0.9.2B
 *
................................................................................
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	UnimportObjCmd _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
#define ENABLED(flag, mask)	(((flag) & (mask)) == (mask))

/*
................................................................................

/*
 * Threaded operation requires locking callbacks
 * Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL.
 */

static Tcl_Mutex locks[CRYPTO_NUM_LOCKS];



static void          CryptoThreadLockCallback (int mode, int n, const char *file, int line);
static unsigned long CryptoThreadIdCallback   (void);

static void
CryptoThreadLockCallback(int mode, int n, const char *file, int line)
{
................................................................................
 *-------------------------------------------------------------------
 */

int
Tls_Init(Tcl_Interp *interp)		/* Interpreter in which the package is
					 * to be made available. */
{
    int major, minor, patchlevel, release, i;
    char rnd_seed[16] = "GrzSlplKqUdnnzP!";	/* 16 bytes */
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
    size_t num_locks;
#endif

    /*
     * The original 8.2.0 stacked channel implementation (and the patch
     * that preceded it) had problems with scalability and robustness.
     * These were address in 8.3.2 / 8.4a2, so we now require that as a
     * minimum for TLS 1.4+.  We only support 8.2+ now (8.3.2+ preferred).
     */
................................................................................
	/* 8.3.2+ */
	channelTypeVersion = TLS_CHANNEL_VERSION_2;
    } else {
	/* 8.2.0 - 8.3.1 */
	channelTypeVersion = TLS_CHANNEL_VERSION_1;
    }

    if (CRYPTO_set_mem_functions((void *(*)(size_t))Tcl_Alloc,
				 (void *(*)(void *, size_t))Tcl_Realloc,
				 (void(*)(void *))Tcl_Free) == 0) {
       /* Not using Tcl's mem functions ... not critical */
    }

#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
    /* should we consider allocating mutexes? */
    num_locks = CRYPTO_num_locks();
    if (num_locks > CRYPTO_NUM_LOCKS) {
       Tcl_AppendResult(interp, "crypto num locks size error", NULL);
       return TCL_ERROR;
    }

    CRYPTO_set_locking_callback(CryptoThreadLockCallback);
    CRYPTO_set_id_callback(CryptoThreadIdCallback);
#endif

    if (SSL_library_init() != 1) {
	Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
	return TCL_ERROR;
    }
    SSL_load_error_strings();
    ERR_load_crypto_strings();

    /*
     * 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);

    Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

................................................................................
 */

int
Tls_SafeInit (Tcl_Interp* interp)
{
    return Tls_Init (interp);
}

























































































|







 







>
>







 







>
>







 







|
<
<
<
<







 







|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
...
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
....
1507
1508
1509
1510
1511
1512
1513
1514




1515
1516
1517
1518
1519
1520
1521
....
1540
1541
1542
1543
1544
1545
1546
1547


















1548
1549
1550




















1551
1552
1553
1554
1555
1556
1557
....
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 * some modifications:
 *	Copyright (C) 2000 Ajuba Solutions
 *	Copyright (C) 2002 ActiveState Corporation
 *	Copyright (C) 2004 Starfish Systems 
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.34 2014/04/16 18:33:03 andreas_kupries 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
 * OpenSSL 0.9.2B
 *
................................................................................
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	UnimportObjCmd _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));

static int	TlsLibInit _ANSI_ARGS_ (()) ;

#define TLS_PROTO_SSL2	0x01
#define TLS_PROTO_SSL3	0x02
#define TLS_PROTO_TLS1	0x04
#define ENABLED(flag, mask)	(((flag) & (mask)) == (mask))

/*
................................................................................

/*
 * Threaded operation requires locking callbacks
 * Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL.
 */

static Tcl_Mutex locks[CRYPTO_NUM_LOCKS];
static Tcl_Mutex init_mx;
static int initialized;

static void          CryptoThreadLockCallback (int mode, int n, const char *file, int line);
static unsigned long CryptoThreadIdCallback   (void);

static void
CryptoThreadLockCallback(int mode, int n, const char *file, int line)
{
................................................................................
 *-------------------------------------------------------------------
 */

int
Tls_Init(Tcl_Interp *interp)		/* Interpreter in which the package is
					 * to be made available. */
{
    int major, minor, patchlevel, release;





    /*
     * The original 8.2.0 stacked channel implementation (and the patch
     * that preceded it) had problems with scalability and robustness.
     * These were address in 8.3.2 / 8.4a2, so we now require that as a
     * minimum for TLS 1.4+.  We only support 8.2+ now (8.3.2+ preferred).
     */
................................................................................
	/* 8.3.2+ */
	channelTypeVersion = TLS_CHANNEL_VERSION_2;
    } else {
	/* 8.2.0 - 8.3.1 */
	channelTypeVersion = TLS_CHANNEL_VERSION_1;
    }

    if (TlsLibInit() != TCL_OK) {


















	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::handshake", HandshakeObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

................................................................................
 */

int
Tls_SafeInit (Tcl_Interp* interp)
{
    return Tls_Init (interp);
}

 
/*
 *------------------------------------------------------*
 *
 *	TlsLibInit --
 *
 *	------------------------------------------------*
 *	Initializes SSL library once per application
 *	------------------------------------------------*
 *
 *	Side effects:
 *		initilizes SSL library
 *
 *	Result:
 *		none
 *
 *------------------------------------------------------*
 */
static int
TlsLibInit ()
{
    int i;
    char rnd_seed[16] = "GrzSlplKqUdnnzP!";	/* 16 bytes */
#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
    size_t num_locks;
#endif
    int status=TCL_OK;

    if (!initialized) {
	Tcl_MutexLock(&init_mx);
	if (!initialized) {
	    initialized = 1;

	    if (CRYPTO_set_mem_functions((void *(*)(size_t))Tcl_Alloc,
					 (void *(*)(void *, size_t))Tcl_Realloc,
					 (void(*)(void *))Tcl_Free) == 0) {
	       /* Not using Tcl's mem functions ... not critical */
	    }

#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
	    /* should we consider allocating mutexes? */
	    num_locks = CRYPTO_num_locks();
	    if (num_locks > CRYPTO_NUM_LOCKS) {
		status=TCL_ERROR;
		goto done;
	    }

	    CRYPTO_set_locking_callback(CryptoThreadLockCallback);
	    CRYPTO_set_id_callback(CryptoThreadIdCallback);
#endif

	    if (SSL_library_init() != 1) {
	    	status=TCL_ERROR;
		goto done;
	    }
	    SSL_load_error_strings();
	    ERR_load_crypto_strings();

	    /*
	     * 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);
	}
    	done:

	Tcl_MutexUnlock(&init_mx);
    }
    return status;
}