Check-in [e64e21d80e]
Bounty program for improvements to Tcl and certain Tcl packages.
Overview
Comment: * tls.c (ImportObjCmd): removed unnecessary use of 'bio' arg. (Tls_Init): check return value of SSL_library_init. Also lots of whitespace cleanup (more like Tcl Eng style guide), but not all code was cleaned up. * tlsBIO.c: minor whitespace cleanup * tlsIO.c: minor whitespace cleanup. (TlsInputProc, TlsOutputProc): Added ERR_clear_error before calls to BIO_read or BIO_write, because we could otherwise end up pulling an error off the stack that didn't belong to us. Also cleanup up excessive use of gotos.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tls-1-3-io-rewrite
Files: files | file ages | folders
SHA1: e64e21d80e4a03c855cf0ab9cbd330f3a2443ad7
User & Date: hobbs on 2000-07-26 22:15:07
Other Links: branch diff | manifest | tags
Context
2000-07-26
23:11
* tests/tlsIO.test: updated comments, fixed a pcCrash case that was due to debug assertion in Windows SSL. Closed-Leaf check-in: 5ed815df85 user: hobbs tags: merge-1-3-io-rewrite-07-26-00, tls-1-3-io-rewrite
22:15
* tls.c (ImportObjCmd): removed unnecessary use of 'bio' arg. (Tls_Init): check return value of SSL_library_init. Also lots of whitespace cleanup (more like Tcl Eng style guide), but not all code was cleaned up. * tlsBIO.c: minor whitespace cleanup * tlsIO.c: minor whitespace cleanup. (TlsInputProc, TlsOutputProc): Added ERR_clear_error before calls to BIO_read or BIO_write, because we could otherwise end up pulling an error off the stack that didn't belong to us. Also cleanup up excessive use of gotos. check-in: e64e21d80e user: hobbs tags: tls-1-3-io-rewrite
2000-07-21
05:32
* tests/tlsIO.test: corrected various tests to be correct for TLS stacked channels (as opposed to the standard sockets the test suite was adopted from). Key differences are that TLS cannot operate in one process without all channels being non-blocking, or the handshake will block, and handshaking must be forced in some cases. Also, handshakes don't seem to complete unless the client has placed at least one byte for the server to read in the channel. * tests/remote.tcl: corrected the finding of tests certificates * tlsIO.c (TlsCloseProc): removed deleting of timer handler as that is handled by Tls_Clean. * tls.tcl (tls::_accept): corrected the internal _accept to trickle callback errors to the user. * Makefile.in: made the install-binaries target regenerate the pkgIndex.tcl correctly. The test target probably shouldn't screw it up, but this is to be on the safe side. check-in: 977988aed6 user: hobbs tags: tls-1-3-io-rewrite
Changes

Modified ChangeLog from [c9bfe5bf82] to [2accd518be].















1
2
3
4
5
6
7
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







2000-07-26  Jeff Hobbs  <[email protected]>

	* tls.c (ImportObjCmd): removed unnecessary use of 'bio' arg.
	(Tls_Init): check return value of SSL_library_init.  Also lots of
	whitespace cleanup (more like Tcl Eng style guide), but not all
	code was cleaned up.

	* tlsBIO.c: minor whitespace cleanup

	* tlsIO.c: minor whitespace cleanup.
	(TlsInputProc, TlsOutputProc): Added ERR_clear_error before calls
	to BIO_read or BIO_write, because we could otherwise end up
	pulling an error off the stack that didn't belong to us.  Also
	cleanup up excessive use of gotos.

2000-07-20  Jeff Hobbs  <[email protected]>

	* tests/tlsIO.test: corrected various tests to be correct for TLS
	stacked channels (as opposed to the standard sockets the test
	suite was adopted from).  Key differences are that TLS cannot
	operate in one process without all channels being non-blocking, or
	the handshake will block, and handshaking must be forced in some

Modified tls.c from [82fbf20832] to [d793bbc229].

1
2
3
4

5
6
7
8
9
10
11
1
2
3

4
5
6
7
8
9
10
11


-
+







/*
 * Copyright (C) 1997-1999 Matt Newman <matt[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.2 2000/07/21 05:32:56 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.3 2000/07/26 22:15:07 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
 * OpenSSL 0.9.2B
 *
217
218
219
220
221
222
223


224
225
226



227
228
229


230
231
232
233
234

235
236

237
238


239
240

241
242

243

244
245
246
247
248
249
250
217
218
219
220
221
222
223
224
225



226
227
228



229
230

231
232
233

234
235

236
237

238
239
240

241
242

243
244
245
246
247
248
249
250
251
252






+
+
-
-
-
+
+
+
-
-
-
+
+
-



-
+

-
+

-
+
+

-
+

-
+

+







 *	The err field of the currently operative State is set
 *	  to a string describing the SSL negotiation failure reason
 *-------------------------------------------------------------------
 */
static int
VerifyCallback(int ok, X509_STORE_CTX *ctx)
{
    Tcl_Obj *cmdPtr;
    char *errStr;
    SSL *ssl = (SSL*)X509_STORE_CTX_get_app_data(ctx);
    X509 *cert = X509_STORE_CTX_get_current_cert(ctx);
    State *statePtr = (State*)SSL_get_app_data(ssl);
    SSL   *ssl		= (SSL*)X509_STORE_CTX_get_app_data(ctx);
    X509  *cert		= X509_STORE_CTX_get_current_cert(ctx);
    State *statePtr	= (State*)SSL_get_app_data(ssl);
    Tcl_Obj *cmdPtr;
    int depth = X509_STORE_CTX_get_error_depth(ctx);
    int err = X509_STORE_CTX_get_error(ctx);
    int depth		= X509_STORE_CTX_get_error_depth(ctx);
    int err		= X509_STORE_CTX_get_error(ctx);
    char *errStr;

    dprintf(stderr, "Verify: %d\n", ok);

    if (!ok)
    if (!ok) {
	errStr = (char*)X509_verify_cert_error_string(err);
    else
    } else {
	errStr = (char *)0;

    }

    if (statePtr->callback == (Tcl_Obj*)NULL) {
	if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT)
	if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
	    return ok;
	else
	} else {
	    return 1;
	}
    }
    cmdPtr = Tcl_DuplicateObj(statePtr->callback);

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj( "verify", -1));

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
303
304
305
306
307
308
309
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327


328
329
330


331
332
333


334
335
336


337
338

339
340

341
342

343
344
345


346
347
348
349
350
351
352
305
306
307
308
309
310
311

312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327


328
329
330


331
332
333


334
335
336


337
338
339

340
341

342
343

344
345


346
347
348
349
350
351
352
353
354






-
+















-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
+

-
+

-
+

-
-
+
+







 */
void
Tls_Error(State *statePtr, char *msg)
{
    Tcl_Obj *cmdPtr;

    if (msg && *msg) {
	Tcl_SetErrorCode( statePtr->interp, "SSL", msg, (char *)NULL);
	Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL);
    } else {
	msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL);
    }
    statePtr->err = msg;

    if (statePtr->callback == (Tcl_Obj*)NULL) {
	char buf[BUFSIZ];
	sprintf(buf, "SSL channel \"%s\": error: %s",
	    Tcl_GetChannelName(statePtr->self), msg);
	Tcl_SetResult( statePtr->interp, buf, TCL_VOLATILE);
	Tcl_BackgroundError( statePtr->interp);
	return;
    }
    cmdPtr = Tcl_DuplicateObj(statePtr->callback);

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj( "error", -1));
    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj("error", -1));

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) );
    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
	    Tcl_NewStringObj( msg, -1) );
    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
	    Tcl_NewStringObj(msg, -1));

    Tcl_Preserve( (ClientData) statePtr->interp);
    Tcl_Preserve( (ClientData) statePtr);
    Tcl_Preserve((ClientData) statePtr->interp);
    Tcl_Preserve((ClientData) statePtr);

    Tcl_IncrRefCount( cmdPtr);
    Tcl_IncrRefCount(cmdPtr);
    if (Tcl_GlobalEvalObj(statePtr->interp, cmdPtr) != TCL_OK) {
	Tcl_BackgroundError( statePtr->interp);
	Tcl_BackgroundError(statePtr->interp);
    }
    Tcl_DecrRefCount( cmdPtr);
    Tcl_DecrRefCount(cmdPtr);

    Tcl_Release( (ClientData) statePtr);
    Tcl_Release( (ClientData) statePtr->interp);
    Tcl_Release((ClientData) statePtr);
    Tcl_Release((ClientData) statePtr->interp);
}

/*
 *-------------------------------------------------------------------
 *
 * PasswordCallback -- 
 *
455
456
457
458
459
460
461
462

463
464
465
466
467
468

469
470
471
472
473
474
475
476
457
458
459
460
461
462
463

464

465
466
467
468

469

470
471
472
473
474
475
476






-
+
-




-
+
-







		Tcl_AppendResult(interp, "protocol not supported", NULL);
		return TCL_ERROR;
#else
		ctx = SSL_CTX_new(TLSv1_method()); break;
#endif
    }
    if (ctx == NULL) {
	Tcl_AppendResult(interp, REASON(),
	Tcl_AppendResult(interp, REASON(), (char *) NULL);
	    (char *) NULL);
	return TCL_ERROR;
    }
    ssl = SSL_new(ctx);
    if (ssl == NULL) {
	Tcl_AppendResult(interp, REASON(),
	Tcl_AppendResult(interp, REASON(), (char *) NULL);
	    (char *) NULL);
	SSL_CTX_free(ctx);
	return TCL_ERROR;
    }
    objPtr = Tcl_NewListObj( 0, NULL);

    if (!verbose) {
	for (index = 0; ; index++) {
568
569
570
571
572
573
574

575
576
577
578
579
580
581
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582






+







	    }

	    Tcl_AppendResult(interp, "handshake failed: ", errStr,
		    (char *) NULL);
	    return TCL_ERROR;
	}
    }

    Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
598
599
600
601
602
603
604
605
606
607
608


609
610
611
612
613
614
615
616
617








618
619
620
621
622
623
624
599
600
601
602
603
604
605

606


607
608
609








610
611
612
613
614
615
616
617
618
619
620
621
622
623
624






-

-
-
+
+

-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+







ImportObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST objv[];
{
    Tcl_Channel chan;		/* The channel to set a mode on. */
    BIO *bio;
    State *statePtr;		/* client state for ssl socket */
    SSL_CTX *ctx = NULL;
    Tcl_Obj *script = NULL;
    SSL_CTX *ctx	= NULL;
    Tcl_Obj *script	= NULL;
    int idx;
    int flags = TLS_TCL_INIT;
    int server = 0;		/* is connection incoming or outgoing? */
    char *key = NULL;
    char *cert = NULL;
    char *ciphers = NULL;
    char *CAfile = NULL;
    char *CAdir = NULL;
    char *model = NULL;
    int flags		= TLS_TCL_INIT;
    int server		= 0;	/* is connection incoming or outgoing? */
    char *key		= NULL;
    char *cert		= NULL;
    char *ciphers	= NULL;
    char *CAfile	= NULL;
    char *CAdir		= NULL;
    char *model		= NULL;
#if defined(NO_SSL2)
    int ssl2 = 0;
#else
    int ssl2 = 1;
#endif
#if defined(NO_SSL3)
    int ssl3 = 0;
670
671
672
673
674
675
676
677

678
679

680
681
682
683
684
685
686
687
688
689
690





691
692
693
694
695
696


697
698
699
700
701
702
703
704
705
706
707


708
709
710

711
712
713

714
715
716
717
718
719
720
721
722



723
724
725
726



727
728
729


730
731
732
733
734
735





736
737

738






739

740

741
742
743
744
745
746



747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767

768
769
770

771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788


789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805

806
807
808
809


810
811
812
813
814
815
816
817

818
819
820
821
822
823
824
670
671
672
673
674
675
676

677
678

679
680
681
682
683
684
685





686
687
688
689
690
691
692
693
694


695
696
697
698
699
700
701
702
703
704
705


706
707
708
709

710
711
712

713
714
715
716
717
718
719



720
721
722
723



724
725
726
727


728
729
730





731
732
733
734
735
736

737
738
739
740
741
742
743
744
745
746
747
748
749
750
751



752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774

775
776
777

778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793



794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811

812
813
814


815
816
817
818
819
820
821
822
823

824
825
826
827
828
829
830
831






-
+

-
+






-
-
-
-
-
+
+
+
+
+




-
-
+
+









-
-
+
+


-
+


-
+






-
-
-
+
+
+

-
-
-
+
+
+

-
-
+
+

-
-
-
-
-
+
+
+
+
+

-
+

+
+
+
+
+
+

+

+



-
-
-
+
+
+




















-
+


-
+















-
-
-
+
+
















-
+


-
-
+
+







-
+







	OPTBOOL( "-ssl3", ssl3);
	OPTBOOL( "-tls1", tls1);

	OPTBAD( "option", "-cafile, -cadir, -certfile, -cipher, -command, -keyfile, -model, -require, -request, -ssl2, -ssl3, -server, 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);

    /* reset to NULL if blank string provided */
    if (cert && !*cert) cert = NULL;
    if (key && !*key) key = NULL;
    if (ciphers && !*ciphers) ciphers = NULL;
    if (CAfile && !*CAfile) CAfile = NULL;
    if (CAdir && !*CAdir) CAdir = NULL;
    if (cert && !*cert)		cert	= NULL;
    if (key && !*key)		key	= NULL;
    if (ciphers && !*ciphers)	ciphers	= NULL;
    if (CAfile && !*CAfile)	CAfile	= NULL;
    if (CAdir && !*CAdir)	CAdir	= NULL;

    if (model != NULL) {
	int mode;
	/* Get the "model" context */
	chan = Tcl_GetChannel( interp, model, &mode);
	if (chan == (Tcl_Channel)0) {
	chan = Tcl_GetChannel(interp, model, &mode);
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
#ifdef TCL_CHANNEL_VERSION_2
	/*
	 * Make sure to operate on the topmost channel
	 */
	chan = Tcl_GetTopChannel(chan);
#endif
	if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
	    Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
		    "\": not a TLS channel", NULL);
	    Tcl_AppendResult(interp, "bad channel \"",
		    Tcl_GetChannelName(chan), "\": not a TLS channel", NULL);
	    return TCL_ERROR;
	}
	statePtr = (State *)Tcl_GetChannelInstanceData( chan);
	statePtr = (State *) Tcl_GetChannelInstanceData(chan);
	ctx = statePtr->ctx;
    } else {
	if ((ctx = CTX_Init( interp, proto, key, cert, CAdir, CAfile, ciphers))
	if ((ctx = CTX_Init(interp, proto, key, cert, CAdir, CAfile, ciphers))
	    == (SSL_CTX*)0) {
	    return TCL_ERROR;
	}
    }

    /* new SSL state */
    statePtr = (State *) Tcl_Alloc((unsigned) sizeof(State));
    statePtr->self = (Tcl_Channel)NULL;
    statePtr->timer = (Tcl_TimerToken)NULL;
    statePtr		= (State *) Tcl_Alloc((unsigned) sizeof(State));
    statePtr->self	= (Tcl_Channel)NULL;
    statePtr->timer	= (Tcl_TimerToken)NULL;

    statePtr->flags = flags;
    statePtr->watchMask = 0;
    statePtr->mode = 0;
    statePtr->flags	= flags;
    statePtr->watchMask	= 0;
    statePtr->mode	= 0;

    statePtr->interp = interp;
    statePtr->callback = (Tcl_Obj *)0;
    statePtr->interp	= interp;
    statePtr->callback	= (Tcl_Obj *)0;

    statePtr->vflags = verify;
    statePtr->ssl = (SSL*)0;
    statePtr->ctx = ctx;
    statePtr->bio = (BIO*)0;
    statePtr->p_bio = (BIO*)0;
    statePtr->vflags	= verify;
    statePtr->ssl	= (SSL*)0;
    statePtr->ctx	= ctx;
    statePtr->bio	= (BIO*)0;
    statePtr->p_bio	= (BIO*)0;

    statePtr->err = "";
    statePtr->err	= "";

    /*
     * 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_SetChannelOption(interp, chan, "-translation", "binary");
#ifndef TCL_CHANNEL_VERSION_2
    Tcl_SetChannelOption(interp, chan, "-buffering", "none");
#endif

#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2
    statePtr->parent = chan;
    statePtr->self = Tcl_ReplaceChannel( interp,
				Tls_ChannelType(), (ClientData) statePtr,
			       (TCL_READABLE | TCL_WRITABLE), statePtr->parent);
    statePtr->self = Tcl_ReplaceChannel(interp,
	    Tls_ChannelType(), (ClientData) statePtr,
	    (TCL_READABLE | TCL_WRITABLE), statePtr->parent);
#else
#ifdef TCL_CHANNEL_VERSION_2
    statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(),
	    (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan);
#else
    statePtr->self = chan;
    Tcl_StackChannel( interp, Tls_ChannelType(), (ClientData) statePtr,
	    (TCL_READABLE | TCL_WRITABLE), chan);
#endif
#endif
    if (statePtr->self == (Tcl_Channel) NULL) {
	/*
	 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
	 */
	Tls_Free((char *) statePtr);
        return TCL_ERROR;
    }

    /* allocate script */
    if (script) {
	char * tmp = Tcl_GetStringFromObj(script, NULL);
	char *tmp = Tcl_GetStringFromObj(script, NULL);
	if (tmp && *tmp) {
	    statePtr->callback = Tcl_DuplicateObj(script);
	    Tcl_IncrRefCount( statePtr->callback);
	    Tcl_IncrRefCount(statePtr->callback);
	}
    }
    /* This is only needed because of a bug in OpenSSL, where the
     * ssl->verify_callback is not referenced!!! (Must be done
     * *before* SSL_new() is called!
     */
    SSL_CTX_set_verify(statePtr->ctx, verify, VerifyCallback);

    /*
     * 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: ", REASON(),
		(char *) NULL);
	Tls_Free((char *) statePtr);
        return TCL_ERROR;
    }

    /*
     * SSL Callbacks
     */

    SSL_set_app_data(statePtr->ssl, (VOID *)statePtr);	/* point back to us */

    /*
     * The following is broken - we need is to set the
     * verify_mode, but the library ignores the verify_callback!!!
     */
    /*SSL_set_verify(statePtr->ssl, verify, VerifyCallback);*/

    SSL_CTX_set_info_callback( statePtr->ctx, InfoCallback);
    SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);

    /* Create Tcl_Channel BIO Handler */
    statePtr->p_bio = bio = BIO_new_tcl( statePtr, BIO_CLOSE);
    statePtr->bio = BIO_new(BIO_f_ssl());
    statePtr->p_bio	= BIO_new_tcl(statePtr, BIO_CLOSE);
    statePtr->bio	= BIO_new(BIO_f_ssl());

    if (server) {
	statePtr->flags |= TLS_TCL_SERVER;
	SSL_set_accept_state(statePtr->ssl);
    } else {
	SSL_set_connect_state(statePtr->ssl);
    }
    SSL_set_bio(statePtr->ssl, bio, bio);
    SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio);
    BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_CLOSE);

    /*
     * End of SSL Init
     */
    Tcl_SetResult(interp, Tcl_GetChannelName(statePtr->self), TCL_VOLATILE);
    return TCL_OK;
964
965
966
967
968
969
970
971

972
973
974
975
976
977
978
971
972
973
974
975
976
977

978
979
980
981
982
983
984
985






-
+







    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);
		REASON(), (char *) NULL);
	SSL_CTX_free(ctx);
	return (SSL_CTX *)0;
#endif
    }
    SSL_CTX_set_client_CA_list(ctx, SSL_load_client_CA_file( F2N(CAfile, &ds) ));

    Tcl_DStringFree(&ds);
1009
1010
1011
1012
1013
1014
1015
1016
1017


1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036







1037
1038
1039
1040
1041
1042
1043




1044
1045
1046
1047
1048
1049
1050
1016
1017
1018
1019
1020
1021
1022


1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037






1038
1039
1040
1041
1042
1043
1044
1045
1046
1047




1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058






-
-
+
+













-
-
-
-
-
-
+
+
+
+
+
+
+



-
-
-
-
+
+
+
+







    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "channel");
        return TCL_ERROR;
    }
    channelName = Tcl_GetStringFromObj(objv[1], NULL);

    chan = Tcl_GetChannel( interp, channelName, &mode);
    if (chan == (Tcl_Channel)0) {
    chan = Tcl_GetChannel(interp, channelName, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
#ifdef TCL_CHANNEL_VERSION_2
    /*
     * Make sure to operate on the topmost channel
     */
    chan = Tcl_GetTopChannel(chan);
#endif
    if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
        Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
                "\": not a TLS channel", NULL);
        return TCL_ERROR;
    }
    statePtr = (State *)Tcl_GetChannelInstanceData( chan);
    peer = SSL_get_peer_certificate(statePtr->ssl);
    if (peer)
	objPtr = Tls_NewX509Obj( interp, peer);
    else
	objPtr = Tcl_NewListObj( 0, NULL);
    statePtr	= (State *) Tcl_GetChannelInstanceData(chan);
    peer	= SSL_get_peer_certificate(statePtr->ssl);
    if (peer) {
	objPtr = Tls_NewX509Obj(interp, peer);
    } else {
	objPtr = Tcl_NewListObj(0, NULL);
    }

    ciphers = (char*)SSL_get_cipher(statePtr->ssl);
    if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) {
	Tcl_ListObjAppendElement( interp, objPtr,
		Tcl_NewStringObj( "cipher", -1) );
	Tcl_ListObjAppendElement( interp, objPtr,
		Tcl_NewStringObj( SSL_get_cipher(statePtr->ssl), -1) );
	Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj("cipher", -1));
	Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1));
    }
    Tcl_SetObjResult( interp, objPtr);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
1133
1134
1135
1136
1137
1138
1139




1140
1141
1142
1143
1144
1145


1146
1147
1148


1149
1150
1151


1152
1153
1154


1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153

1154


1155
1156
1157


1158
1159
1160


1161
1162
1163


1164
1165
1166
1167
1168

1169
1170
1171
1172
1173
1174
1175






+
+
+
+


-

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+



-







                                         * to be made available. */
{
#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 2
    if (!Tcl_InitStubs(interp, TCL_VERSION, 0)) {
        return TCL_ERROR;
    }
#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();
    SSL_library_init();

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

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

    Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd , (ClientData) 0,
                      (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd , (ClientData) 0,
                      (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    return Tcl_PkgProvide(interp, PACKAGE, VERSION);
}


/*
 *------------------------------------------------------*
 *
 *	Tls_SafeInit --
 *
 *	------------------------------------------------*

Modified tlsBIO.c from [1167365c8d] to [8a7d792ec5].

1
2
3
4

5
6
7
8
9
10
11
1
2
3

4
5
6
7
8
9
10
11


-
+







/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.3 2000/07/21 05:32:57 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.4 2000/07/26 22:15:07 hobbs Exp $
 *
 * Provides BIO layer to interface openssl to Tcl.
 */

#include "tlsInt.h"

/*
34
35
36
37
38
39
40
41
42
43
44




45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

62
63
64
65
66
67

68
69

70
71
72
73

74
75
76
77
78

79
80
81
82
83

84

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

103
104

105
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
34
35
36
37
38
39
40




41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

61
62
63
64
65
66

67
68

69
70
71
72

73
74
75
76
77

78
79
80
81
82

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

103
104

105
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






-
-
-
-
+
+
+
+
















-
+





-
+

-
+



-
+




-
+




-
+

+

















-
+

-
+



-
+




-
+




-
+

+








-
+







BIO *
BIO_new_tcl(statePtr, flags)
    State *statePtr;
    int flags;
{
    BIO *bio;

    bio = BIO_new(&BioMethods);
    bio->ptr = (char*)statePtr;
    bio->init = 1;
    bio->shutdown = flags;
    bio			= BIO_new(&BioMethods);
    bio->ptr		= (char*)statePtr;
    bio->init		= 1;
    bio->shutdown	= flags;

    return bio;
}

BIO_METHOD *
BIO_s_tcl()
{
    return &BioMethods;
}

static int
BioWrite (bio, buf, bufLen)
    BIO *bio;
    char *buf;
    int bufLen;
{
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    Tcl_Channel chan = Tls_GetParent((State*)(bio->ptr));
    int ret;

    dprintf(stderr,"\nBioWrite(0x%x, <buf>, %d) [0x%x]", bio, bufLen, chan);

#ifdef TCL_CHANNEL_VERSION_2
    ret = Tcl_WriteRaw( chan, buf, bufLen);
    ret = Tcl_WriteRaw(chan, buf, bufLen);
#else
    ret = Tcl_Write( chan, buf, bufLen);
    ret = Tcl_Write(chan, buf, bufLen);
#endif

    dprintf(stderr,"\n[0x%x] BioWrite(%d) -> %d [%d.%d]", chan, bufLen, ret,
		Tcl_Eof( chan), Tcl_GetErrno());
	    Tcl_Eof(chan), Tcl_GetErrno());

    BIO_clear_flags(bio, BIO_FLAGS_WRITE|BIO_FLAGS_SHOULD_RETRY);

    if (ret == 0) {
	if (!Tcl_Eof( chan)) {
	if (!Tcl_Eof(chan)) {
	    BIO_set_retry_write(bio);
	    ret = -1;
	}
    }
    if (BIO_should_read(bio))
    if (BIO_should_read(bio)) {
	BIO_set_retry_read(bio);
    }
    return ret;
}

static int
BioRead (bio, buf, bufLen)
    BIO *bio;
    char *buf;
    int bufLen;
{
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    int ret = 0;

    dprintf(stderr,"\nBioRead(0x%x, <buf>, %d) [0x%x]", bio, bufLen, chan);

    if (buf == NULL) return 0;

#ifdef TCL_CHANNEL_VERSION_2
    ret = Tcl_ReadRaw( chan, buf, bufLen);
    ret = Tcl_ReadRaw(chan, buf, bufLen);
#else
    ret = Tcl_Read( chan, buf, bufLen);
    ret = Tcl_Read(chan, buf, bufLen);
#endif

    dprintf(stderr,"\n[0x%x] BioRead(%d) -> %d [%d.%d]", chan, bufLen, ret,
	Tcl_Eof(chan), Tcl_GetErrno());
	    Tcl_Eof(chan), Tcl_GetErrno());

    BIO_clear_flags(bio, BIO_FLAGS_READ|BIO_FLAGS_SHOULD_RETRY);

    if (ret == 0) {
	if (!Tcl_Eof( chan)) {
	if (!Tcl_Eof(chan)) {
	    BIO_set_retry_read(bio);
	    ret = -1;
	}
    }
    if (BIO_should_write(bio))
    if (BIO_should_write(bio)) {
	BIO_set_retry_write(bio);
    }
    return ret;
}

static int
BioPuts	(bio, str)
    BIO *bio;
    char *str;
{
    return BioWrite( bio, str, strlen(str));
    return BioWrite(bio, str, strlen(str));
}

static long
BioCtrl	(bio, cmd, num, ptr)
    BIO *bio;
    int cmd;
    long num;
173
174
175
176
177
178
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
175
176
177
178
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






-
+
















-
+







	ret = bio->shutdown;
	break;
    case BIO_CTRL_SET_CLOSE:
	bio->shutdown = (int)num;
	break;
    case BIO_CTRL_EOF:
	dprintf(stderr, "BIO_CTRL_EOF\n");
	ret = Tcl_Eof( chan);
	ret = Tcl_Eof(chan);
	break;
    case BIO_CTRL_PENDING:
	ret = (Tcl_InputBuffered(chan) ? 1 : 0);
	dprintf(stderr, "BIO_CTRL_PENDING(%d)\n", ret);
	break;
    case BIO_CTRL_WPENDING:
	ret = 0;
	break;
    case BIO_CTRL_DUP:
	break;
    case BIO_CTRL_FLUSH:
	dprintf(stderr, "BIO_CTRL_FLUSH\n");
	if (
#ifdef TCL_CHANNEL_VERSION_2
	    Tcl_WriteRaw(chan, "", 0) >= 0
#else
	    Tcl_Flush( chan) == TCL_OK
	    Tcl_Flush(chan) == TCL_OK
#endif
	    ) {
	    ret = 1;
	} else {
	    ret = -1;
	}
	break;

Modified tlsIO.c from [d750d9a254] to [1cbb80c69b].

1
2
3
4

5
6
7
8
9
10
11
1
2
3

4
5
6
7
8
9
10
11


-
+







/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.3 2000/07/21 05:32:57 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.4 2000/07/26 22:15:07 hobbs Exp $
 *
 * TLS (aka SSL) Channel - can be layered on any bi-directional
 * Tcl_Channel (Note: Requires Trf Core Patch)
 *
 * This was built from scratch based upon observation of OpenSSL 0.9.2B
 *
 * Addition credit is due for Andreas Kupries ([email protected]), for
164
165
166
167
168
169
170
171

172
173
174
175
176
177
178
164
165
166
167
168
169
170

171
172
173
174
175
176
177
178






-
+







     */

    Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
	TlsChannelHandler, (ClientData) statePtr);
#endif

    Tls_Clean(statePtr);
    Tcl_EventuallyFree( (ClientData)statePtr, Tls_Free);
    Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * TlsInputProc --
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












217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234






235
236
237
238
239
240
241




242
243
244
245
246
247
248
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
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237

238
239
240





241
242
243
244
245
246







247
248
249
250
251
252
253
254
255
256
257






-
-
-
-
+
+
+
+

















+
+
+
+
+
+
+
+
+
+
+
+









-



-
-
-
-
-
+
+
+
+
+
+
-
-
-
-
-
-
-
+
+
+
+







 *	Reads input from the input device of the channel.
 *
 *-------------------------------------------------------------------
 */

static int
TlsInputProc(ClientData instanceData,	/* Socket state. */
             char *buf,			/* Where to store data read. */
             int bufSize,		/* How much space is available
                                         * in the buffer? */
             int *errorCodePtr)		/* Where to store error code. */
	char *buf,			/* Where to store data read. */
	int bufSize,			/* How much space is available
					 * in the buffer? */
	int *errorCodePtr)		/* Where to store error code. */
{
    State *statePtr = (State *) instanceData;
    int bytesRead;			/* How many bytes were read? */

    *errorCodePtr = 0;

    dprintf(stderr,"\nBIO_read(%d)", bufSize);

    if (!SSL_is_init_finished(statePtr->ssl)) {
	bytesRead = Tls_WaitForConnect(statePtr, errorCodePtr);
	if (bytesRead <= 0) {
	    goto input;
	}
    }
    if (statePtr->flags & TLS_TCL_INIT) {
	statePtr->flags &= ~(TLS_TCL_INIT);
    }
    /*
     * We need to clear the SSL error stack now because we sometimes reach
     * this function with leftover errors in the stack.  If BIO_read
     * returns -1 and intends EAGAIN, there is a leftover error, it will be
     * misconstrued as an error, not EAGAIN.
     *
     * Alternatively, we may want to handle the <0 return codes from
     * BIO_read specially (as advised in the RSA docs).  TLS's lower level BIO
     * functions play with the retry flags though, and this seems to work
     * correctly.  Similar fix in TlsOutputProc. - hobbs
     */
    ERR_clear_error();
    bytesRead = BIO_read(statePtr->bio, buf, bufSize);
    dprintf(stderr,"\nBIO_read -> %d", bytesRead);

    if (bytesRead < 0) {
	int err = SSL_get_error(statePtr->ssl, bytesRead);

	if (err == SSL_ERROR_SSL) {
	    Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, bytesRead));
	    *errorCodePtr = ECONNABORTED;
	    goto input;
	} else if (BIO_should_retry(statePtr->bio)) {
	    dprintf(stderr,"RE! ");
	    *errorCodePtr = EAGAIN;
	    goto input;
	}
	if (Tcl_GetErrno() == ECONNRESET) {
	    /* Soft EOF */
	    bytesRead = 0;
	} else {
	    *errorCodePtr = Tcl_GetErrno();
	    if (*errorCodePtr == ECONNRESET) {
		/* Soft EOF */
		*errorCodePtr = 0;
		bytesRead = 0;
	    goto input;
	} else {
	    *errorCodePtr = Tcl_GetErrno();
	    goto input;
	}
    }
input:
	    }
	}
    }
    input:
    dprintf(stderr, "\nInput(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
    return bytesRead;
}

/*
 *-------------------------------------------------------------------
 *
259
260
261
262
263
264
265
266

267
268
269
270
271
272
273
274
275

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291












292
293


294
295

296
297
298
















299
300
301
302

303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319





320
321
322
323
324





325
326
327




328
329
330

331
332
333
334
335
336
337
268
269
270
271
272
273
274

275
276
277
278
279
280
281
282
283

284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313

314
315
316

317
318


319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335



336

















337
338
339
340
341





342
343
344
345
346



347
348
349
350
351
352

353
354
355
356
357
358
359
360






-
+








-
+
















+
+
+
+
+
+
+
+
+
+
+
+

-
+
+

-
+

-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
-
-
-
+
+
+
+


-
+







 *	Writes output on the output device of the channel.
 *
 *-------------------------------------------------------------------
 */

static int
TlsOutputProc(ClientData instanceData,	/* Socket state. */
              char *buf,			/* The data buffer. */
              char *buf,		/* The data buffer. */
              int toWrite,		/* How many bytes to write? */
              int *errorCodePtr)	/* Where to store error code. */
{
    State *statePtr = (State *) instanceData;
    int written, err;

    *errorCodePtr = 0;

    dprintf(stderr,"\nBIO_write(%d)", toWrite);
    dprintf(stderr,"\nBIO_write(0x%x, %d)", statePtr, toWrite);

    if (!SSL_is_init_finished(statePtr->ssl)) {
	written = Tls_WaitForConnect(statePtr, errorCodePtr);
	if (written <= 0) {
	    goto output;
	}
    }
    if (statePtr->flags & TLS_TCL_INIT) {
	statePtr->flags &= ~(TLS_TCL_INIT);
    }
    if (toWrite == 0) {
	dprintf(stderr, "zero-write\n");
	BIO_flush(statePtr->bio);
	written = 0;
	goto output;
    } else {
	/*
	 * We need to clear the SSL error stack now because we sometimes reach
	 * this function with leftover errors in the stack.  If BIO_write
	 * returns -1 and intends EAGAIN, there is a leftover error, it will be
	 * misconstrued as an error, not EAGAIN.
	 *
	 * Alternatively, we may want to handle the <0 return codes from
	 * BIO_write specially (as advised in the RSA docs).  TLS's lower level
	 * BIO functions play with the retry flags though, and this seems to
	 * work correctly.  Similar fix in TlsInputProc. - hobbs
	 */
	ERR_clear_error();
	written = BIO_write(statePtr->bio, buf, toWrite);
	dprintf(stderr,"\nBIO_write(%d) -> [%d]", toWrite, written);
	dprintf(stderr,"\nBIO_write(0x%x, %d) -> [%d]",
		statePtr, toWrite, written);
    }
    if (written < 0 || written == 0) {
    if (written <= 0) {
	switch ((err = SSL_get_error(statePtr->ssl, written))) {
	case SSL_ERROR_NONE:
	    if (written <= 0) {
	    case SSL_ERROR_NONE:
		if (written < 0) {
		    written = 0;
		}
		break;
	    case SSL_ERROR_WANT_WRITE:
		dprintf(stderr," write W BLOCK");
		break;
	    case SSL_ERROR_WANT_READ:
		dprintf(stderr," write R BLOCK");
		break;
	    case SSL_ERROR_WANT_X509_LOOKUP:
		dprintf(stderr," write X BLOCK");
		break;
	    case SSL_ERROR_ZERO_RETURN:
		dprintf(stderr," closed\n");
		written = 0;
		goto output;
	    }
	    break;
		break;
	case SSL_ERROR_WANT_WRITE:
	    dprintf(stderr,"write W BLOCK\n");
	    break;
	case SSL_ERROR_WANT_READ:
	    dprintf(stderr,"write R BLOCK\n");
	    break;
	case SSL_ERROR_WANT_X509_LOOKUP:
	    dprintf(stderr,"write X BLOCK\n");
	    break;
	case SSL_ERROR_ZERO_RETURN:
	    dprintf(stderr,"closed\n");
	    written = 0;
	    goto output;
	case SSL_ERROR_SYSCALL:
	    *errorCodePtr = Tcl_GetErrno();
	    dprintf(stderr,"[%d] syscall errr: %d\n", written, Tcl_GetErrno());
	    written = -1;
	    case SSL_ERROR_SYSCALL:
		*errorCodePtr = Tcl_GetErrno();
		dprintf(stderr," [%d] syscall errr: %d",
			written, *errorCodePtr);
		written = -1;
	    goto output;
	case SSL_ERROR_SSL:
	    Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written));
	    *errorCodePtr = ECONNABORTED;
	    written = -1;
		break;
	    case SSL_ERROR_SSL:
		Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written));
		*errorCodePtr = ECONNABORTED;
		written = -1;
	    goto output;
	default:
	    dprintf(stderr,"unknown err: %d\n", err);
		break;
	    default:
		dprintf(stderr," unknown err: %d\n", err);
		break;
	}
    }
output:
    output:
    dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written);
    return written;
}

/*
 *-------------------------------------------------------------------
 *