Check-in [3631274d64]
Overview
Comment:*** empty log message ***
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3631274d649f9e23fc1f83a94af73d1383e78337
User & Date: razzell on 2003-05-15 20:44:46
Other Links: manifest | tags
Context
2003-05-15
21:02
Added password callback support and version command. Fixed memory leak. check-in: 509dd7a9b6 user: razzell tags: trunk
20:44
*** empty log message *** check-in: 3631274d64 user: razzell tags: trunk
2002-02-04
22:46
* tls.htm: * tls.c: added support for local certificate status check, as well as returning the # of bits in the session key. [Patch #505698] (rose) * tls.c: * tlsIO.c: * tlsBIO.c: added CONSTs to satisfy Tcl 8.4 sources. This may give warnings when compiled against 8.3, but they can be ignored. check-in: c34385bbcd user: hobbs tags: trunk
Changes

Modified ChangeLog from [714f578cf0] to [cccb98d8c7].






















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
23
24
25
26
27
28
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







2003-05-15  Dan Razzell	<[email protected]>

	* tls.tcl:
	* tlsInt.h:
	* tls.c: add support for binding a password callback to the socket.
	Now each socket can have its own command and password callbacks instead
	of being forced to have all password management pass through a common
	procedure.  The common password procedure is retained for compatibility
	but its use should be DEPRECATED.
	Add version command to return OpenSSL version string.
	Remove unstable workarounds needed for verify in obsolete versions of
	OpenSSL.
	Fix memory leak. [Request #640660]
	More casts to eliminate compiler warnings.

	* tls.htm: document password callback.
	Correct technical and typographic errors.

	* README.txt: identify versions of OpenSSL which fix known problems.
	General warning of security problems in older versions of OpenSSL.

2002-02-04  Jeff Hobbs  <[email protected]>

	* tls.htm:
	* tls.c: added support for local certificate status check, as well
	as returning the # of bits in the session key. [Patch #505698] (rose)

	* tls.c:

Modified README.txt from [0b15f3a7be] to [5ce6323187].

1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24





25
26
27
28
29
30
31
1
2
3

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35



-
+



















-
+
+
+
+
+







Copyright (C) 1997-2000 Matt Newman <[email protected]>
TLS 1.4.1 Copyright (C) 2000 Ajuba Solutions

$Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/README.txt,v 1.3 2001/06/21 23:34:20 hobbs Exp $
$Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/README.txt,v 1.4 2003/05/15 20:44:46 razzell Exp $

TLS (aka SSL) Channel - can be layered on any bi-directional Tcl_Channel.

Both client and server-side sockets are possible, and this code should work
on any platform as it uses a generic mechanism for layering on SSL and Tcl.

The TLS 1.4 release requires Tcl 8.2.0+, with 8.3.2+ preferred.  The
stacked channel implementation in Tcl was originally introduced in 8.2.0
(previously the Trf patch) and rewritten for 8.3.2+ due to inherent
limitations in the earlier implementation.  TLS 1.4 should compile with
any stubs-capable Tcl interpreter, but will require 8.2+ when loaded.
There are known limitations in the 8.2.0-8.3.1 stacked channel
implementation, so it is encouraged that people use TLS 1.4+ with an
8.3.2+ Tcl interpreter.  These modifications are by Jeff Hobbs
<[email protected]>.

Full filevent sematics should also be intact - see tests directory for
blocking and non-blocking examples.

This was built (almost) from scratch based upon observation of OpenSSL 0.9.2B
This was built (almost) from scratch based upon observation of OpenSSL 0.9.2b.
For correct functioning, use OpenSSL 0.9.6g or later.  This release contains
important fixes to memory management, as well as incorporating the verify
callback correction which appeared in OpenSSL 0.9.6c.  For best security, use
the latest official release of OpenSSL.

Addition credit is due for Andreas Kupries ([email protected]), for
providing the Tcl_ReplaceChannel mechanism and working closely with me
to enhance it to support full fileevent semantics.

Also work done by the follow people provided the impetus to do this "right":-
tclSSL (Colin McCormack, Shared Technology)

Modified tls.c from [1f1f2854e3] to [32f77b5e42].

1
2
3
4
5

6
7

8
9
10
11
12
13
14
1
2
3
4
5
6
7

8
9
10
11
12
13
14
15





+

-
+







/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 * some modifications:
 *	Copyright (C) 2000 Ajuba Solutions
 *	Copyright (C) 2002 ActiveState Corporation
 *	Copyright (C) 2003 Starfish Systems
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.14 2002/02/04 22:46:31 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.15 2003/05/15 20:44:46 razzell 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
 *
46
47
48
49
50
51
52




53

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

58
59
60
61
62
63
64
65







+
+
+
+
-
+







			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	ImportObjCmd _ANSI_ARGS_ ((ClientData clientData,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	StatusObjCmd _ANSI_ARGS_ ((ClientData clientData,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static int	VersionObjCmd _ANSI_ARGS_ ((ClientData clientData,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static SSL_CTX *CTX_Init _ANSI_ARGS_((Tcl_Interp *interp, int proto, char *key,
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))

168
169
170
171
172
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
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







-
















-
+







	if (where & SSL_CB_READ)		minor = "read";
	else if (where & SSL_CB_WRITE)		minor = "write";
	else if (where & SSL_CB_LOOP)		minor = "loop";
	else if (where & SSL_CB_EXIT)		minor = "exit";
	else					minor = "unknown";
    }


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

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

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

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

    if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) {
	Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
	    Tcl_NewStringObj( SSL_state_string_long(ssl), -1) );
    } else if (where & SSL_CB_ALERT) {
	char *cp = SSL_alert_desc_string_long(ret);
	char *cp = (char *) SSL_alert_desc_string_long(ret);

	Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
	    Tcl_NewStringObj( cp, -1) );
    } else {
	Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
	    Tcl_NewStringObj( SSL_state_string_long(ssl), -1) );
    }
356
357
358
359
360
361
362
363
364
365



366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381

382



383

384
385


























386
387
388
389
390
391
392
360
361
362
363
364
365
366



367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386

387
388
389
390
391


392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424







-
-
-
+
+
+
















+
-
+
+
+

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







}

/*
 *-------------------------------------------------------------------
 *
 * PasswordCallback -- 
 *
 *	Called when a password is needed to unpack RSA and PEM keys
 *	Evals the tcl proc:  tls::password and returns the result as
 *	the password
 *	Called when a password is needed to unpack RSA and PEM keys.
 *	Evals any bound password script and returns the result as
 *	the password string.
 *-------------------------------------------------------------------
 */
#ifdef PRE_OPENSSL_0_9_4
/*
 * No way to handle user-data therefore no way without a global
 * variable to access the Tcl interpreter.
*/
static int
PasswordCallback(char *buf, int size, int verify)
{
    return -1;
}
#else
static int
PasswordCallback(char *buf, int size, int verify, void *udata)
{
    State *statePtr	= (State *) udata;
    Tcl_Interp *interp = (Tcl_Interp*)udata;
    Tcl_Interp *interp	= statePtr->interp;
    Tcl_Obj *cmdPtr;
    int result;

    if (statePtr->password == NULL) {
    if (Tcl_Eval(interp, "tls::password") == TCL_OK) {
	CONST char *ret = Tcl_GetStringResult(interp);
	if (Tcl_Eval(interp, "tls::password") == TCL_OK) {
	    char *ret = (char *) Tcl_GetStringResult(interp);
            strncpy(buf, ret, size);
	    return strlen(ret);
	} else {
	    return -1;
	}
    }

    cmdPtr = Tcl_DuplicateObj(statePtr->password);

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

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

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

    if (result == TCL_OK) {
	char *ret = (char *) Tcl_GetStringResult(interp);
        strncpy(buf, ret, size);
	return strlen(ret);
    } else {
	return -1;
    }
}
#endif
604
605
606
607
608
609
610

611
612
613
614
615
616
617
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650







+







    int objc;
    Tcl_Obj *CONST objv[];
{
    Tcl_Channel chan;		/* The channel to set a mode on. */
    State *statePtr;		/* client state for ssl socket */
    SSL_CTX *ctx	= NULL;
    Tcl_Obj *script	= NULL;
    Tcl_Obj *password	= 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;
653
654
655
656
657
658
659
660
661

662
663
664
665
666

667
668
669
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
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







-

+





+








-
+


















-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-











+



-
+




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








    for (idx = 2; idx < objc; idx++) {
	char *opt = Tcl_GetStringFromObj(objv[idx], NULL);

	if (opt[0] != '-')
	    break;

	OPTSTR( "-cafile", CAfile);
	OPTSTR( "-cadir", CAdir);
	OPTSTR( "-cafile", CAfile);
	OPTSTR( "-certfile", cert);
	OPTSTR( "-cipher", ciphers);
	OPTOBJ( "-command", script);
	OPTSTR( "-keyfile", key);
	OPTSTR( "-model", model);
	OPTOBJ( "-password", password);
	OPTBOOL( "-require", require);
	OPTBOOL( "-request", request);
	OPTBOOL( "-server", server);

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

	OPTBAD( "option", "-cafile, -cadir, -certfile, -cipher, -command, -keyfile, -model, -require, -request, -ssl2, -ssl3, -server, or -tls1");
	OPTBAD( "option", "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -model, -password, -require, -request, -server, -ssl2, -ssl3, or -tls1");

	return TCL_ERROR;
    }
    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;

    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 (model != NULL) {
	int mode;
	/* Get the "model" context */
	chan = Tcl_GetChannel(interp, model, &mode);
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
	if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
	    /*
	     * Make sure to operate on the topmost channel
	     */
	    chan = Tcl_GetTopChannel(chan);
	}
	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);
	ctx = statePtr->ctx;
    } else {
	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->flags	= flags;
    statePtr->watchMask	= 0;
    statePtr->mode	= 0;

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

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

    statePtr->err	= "";

    /* allocate script */
    if (script) {
	char *tmp = Tcl_GetStringFromObj(script, NULL);
	if (tmp && *tmp) {
	    statePtr->callback = Tcl_DuplicateObj(script);
	    Tcl_IncrRefCount(statePtr->callback);
	}
    }

    /* allocate password */
    if (password) {
	char *tmp = Tcl_GetStringFromObj(password, NULL);
	if (tmp && *tmp) {
	    statePtr->password = Tcl_DuplicateObj(password);
	    Tcl_IncrRefCount(statePtr->password);
	}
    }

    if (model != NULL) {
	int mode;
	/* Get the "model" context */
	chan = Tcl_GetChannel(interp, model, &mode);
	if (chan == (Tcl_Channel) NULL) {
	    Tls_Free((char *) statePtr);
	    return TCL_ERROR;
	}
	if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
	    /*
	     * Make sure to operate on the topmost channel
	     */
	    chan = Tcl_GetTopChannel(chan);
	}
	if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
	    Tcl_AppendResult(interp, "bad channel \"",
		    Tcl_GetChannelName(chan), "\": not a TLS channel", NULL);
	    Tls_Free((char *) statePtr);
	    return TCL_ERROR;
	}
	ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx;
    } else {
	if ((ctx = CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers))
	    == (SSL_CTX*)0) {
	    Tls_Free((char *) 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.
     */
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
818
819
820
821
822
823
824














825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843





844
845
846
847
848
849
850
851







-
-
-
-
-
-
-
-
-
-
-
-
-
-



















-
-
-
-
-
+







	/*
	 * 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);
	if (tmp && *tmp) {
	    statePtr->callback = Tcl_DuplicateObj(script);
	    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);
	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_set_verify(statePtr->ssl, verify, VerifyCallback);

    SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);

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

838
839
840
841
842
843
844
845
846


847
848
849
850
851
852
853

854
855
856
857
858
859
860
877
878
879
880
881
882
883


884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900







-
-
+
+







+







 * Side effects:
 *	constructs SSL context (CTX)
 *
 *-------------------------------------------------------------------
 */

static SSL_CTX *
CTX_Init(interp, proto, key, cert, CAdir, CAfile, ciphers)
    Tcl_Interp *interp;
CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers)
    State *statePtr;
    int proto;
    char *key;
    char *cert;
    char *CAdir;
    char *CAfile;
    char *ciphers;
{
    Tcl_Interp *interp = statePtr->interp;
    SSL_CTX *ctx = NULL;
    Tcl_DString ds;
    Tcl_DString ds1;
    int off = 0;

    /* create SSL context */
#if !defined(NO_SSL2) && !defined(NO_SSL3)
895
896
897
898
899
900
901
902

903
904
905
906
907
908
909
935
936
937
938
939
940
941

942
943
944
945
946
947
948
949







-
+







    if (ciphers != NULL)
	SSL_CTX_set_cipher_list(ctx, ciphers);

    /* set some callbacks */
    SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback);

#ifndef BSAFE
    SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)interp);
    SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr);
#endif

#ifndef NO_DH
    {
	DH* dh = get_dh512();
	SSL_CTX_set_tmp_dh(ctx, dh);
	DH_free(dh);
926
927
928
929
930
931
932


933
934
935
936
937
938
939
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981







+
+








        /* get the private key associated with this certificate */
        if (key == NULL) key=cert;

        if (SSL_CTX_use_PrivateKey_file(ctx, F2N( key, &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 ", key, " ",
                             REASON(), (char *) NULL);
            SSL_CTX_free(ctx);
            return (SSL_CTX *)0;
        }
	Tcl_DStringFree(&ds);
1048
1049
1050
1051
1052
1053
1054
1055


1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068




























1069
1070
1071
1072
1073
1074
1075
1090
1091
1092
1093
1094
1095
1096

1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146







-
+
+













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







	peer	= SSL_get_certificate(statePtr->ssl);
    if (peer) {
	objPtr = Tls_NewX509Obj(interp, peer);
    } else {
	objPtr = Tcl_NewListObj(0, NULL);
    }

    Tcl_ListObjAppendElement (interp, objPtr, Tcl_NewStringObj ("sbits", -1));
    Tcl_ListObjAppendElement (interp, objPtr,
	    Tcl_NewStringObj ("sbits", -1));
    Tcl_ListObjAppendElement (interp, objPtr,
	    Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, 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_SetObjResult( interp, objPtr);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * VersionObjCmd -- return version string from OpenSSL.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------
 */
static int
VersionObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj	*CONST objv[];
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1);

    Tcl_SetObjResult(interp, objPtr);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * Tls_Free --
 *
 *	This procedure cleans up when a SSL socket based channel
1122
1123
1124
1125
1126
1127
1128




1129
1130
1131
1132




1133
1134
1135
1136
1137
1138
1139
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218







+
+
+
+




+
+
+
+







	statePtr->timer = NULL;
    }

    if (statePtr->ssl) {
	SSL_shutdown(statePtr->ssl);
	SSL_free(statePtr->ssl);
	statePtr->ssl = NULL;
    }
    if (statePtr->ctx) {
	SSL_CTX_free(statePtr->ctx);
	statePtr->ctx = NULL;
    }
    if (statePtr->callback) {
	Tcl_DecrRefCount(statePtr->callback);
	statePtr->callback = NULL;
    }
    if (statePtr->password) {
	Tcl_DecrRefCount(statePtr->password);
	statePtr->password = NULL;
    }
}

/*
 *-------------------------------------------------------------------
 *
 * Tls_Init --
1219
1220
1221
1222
1223
1224
1225



1226
1227
1228
1229
1230
1231
1232
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314







+
+
+







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

    return Tcl_PkgProvide(interp, PACKAGE, VERSION);
}

/*
 *------------------------------------------------------*
 *

Modified tls.htm from [dd76fd83fe] to [a3ee30595b].



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
+
+








-







<!doctype html public "-//W3C//DTD HTML 4.0 Transitional//EN">

<html>

<head>
<meta http-equiv="Content-Type"
content="text/html; charset=iso-8859-1">
<meta name="Author"
content="Matt Newman &lt;[email protected]&gt;">
<meta name="Copyright" content="1999 Matt Newman.">
<meta name="GENERATOR" content="Microsoft FrontPage Express 2.0">
<title>TLS (SSL) Tcl Commands</title>
</head>

<body bgcolor="#FFFFFF">

<dl>
    <dd><a href="#NAME">NAME</a> <dl>
27
28
29
30
31
32
33

34
35
36
37

38
39
40
41
42
43
44
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46







+



-
+







            <dd><b>tls::socket </b><em>?options? host port</em></dd>
            <dd><b>tls::socket</b><em> ?-server command?
                ?options? port</em></dd>
            <dd><b>tls::handshake</b><em> channel</em></dd>
            <dd><b>tls::status </b><em>?-local? channel</em></dd>
            <dd><b>tls::import</b><em> channel ?options?</em></dd>
            <dd><b>tls::ciphers </b><em>protocol ?verbose?</em></dd>
            <dd><b>tls::version</b></dd>
        </dl>
    </dd>
    <dd><a href="#COMMANDS">COMMANDS</a></dd>
    <dd><a href="#CONFIGURATION OPTIONS">CONFIGURATION OPTIONS</a></dd>
    <dd><a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a></dd>
    <dd><a href="#HTTPS EXAMPLE">HTTPS EXAMPLE</a></dd>
    <dd><a href="#SEE ALSO">SPECIAL CONSIDERATIONS</a></dd>
    <dd><a href="#SEE ALSO">SEE ALSO</a></dd>
</dl>

<hr>

57
58
59
60
61
62
63
64



65
66
67
68
69
70
71
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73
74
75







-
+
+
+







port</em><br>
<b>tls::socket</b><em> ?-server command? ?options? port</em><br>
</a><a href="#tls::status"><b>tls::status </b><em>?-local? channel</em><br>
</a><a href="#tls::handshake"><b>tls::handshake</b><em> channel</em></a><br>
<br>
<a href="#tls::import"><b>tls::import </b><i>channel ?options?</i></a><br>
<a href="#tls::ciphers protocol ?verbose?"><strong>tls::ciphers</strong>
<em>protocol ?verbose?</em></a></p>
<em>protocol ?verbose?</em></a><br>
<a href="#tls::version"><b>tls::version</b></a>
</p>

<h3><a name="DESCRIPTION">DESCRIPTION</a></h3>

<p>This extension provides a generic binding to <a
href="http://www.openssl.org/">OpenSSL</a>, utilizing the
<strong>Tcl_StackChannel</strong>
API for Tcl 8.2 and higher. The sockets behave exactly the same
148
149
150
151
152
153
154
155
156
157
158


159
160
161
162
163
164
165
166
167
168










169
170
171
172
173
174
175








176
177
178
179
180
181
182
183
184
185

186
187
188
189
190
191
192
193
152
153
154
155
156
157
158


159
160
161
162
163
164
165
166
167
168




169
170
171
172
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
205
206
207
208
209
210







-
-


+
+






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







+
+
+
+
+
+
+
+









-
+
-







    <dd>SSL-enable a regular Tcl channel - it need not be a
        socket, but must provide bi-directional flow. Also
        setting session parameters for SSL handshake.</dd>
</dl>

<blockquote>
    <dl>
        <dt><strong>-cafile </strong><em>filename</em></dt>
        <dd>Provide the CA file.</dd>
        <dt>-<strong>cadir</strong> <em>dir</em></dt>
        <dd>Provide the directory containing the CA certificates.</dd>
        <dt><strong>-cafile </strong><em>filename</em></dt>
        <dd>Provide the CA file.</dd>
        <dt><strong>-certfile</strong> <em>filename</em></dt>
        <dd>Provide the certificate to use.</dd>
        <dt><strong>-cipher </strong><em>string</em></dt>
        <dd>Provide the cipher suites to use. Syntax is as per
            OpenSSL.</dd>
        <dt><strong>-command</strong><em> callback</em></dt>
        <dd>This callback is invoked to pass errors, tracing
            information and to allow Tcl scripts to perform
            additional verification of the certificate, which can
            override the default validation in OpenSSL.</dd>
        <dd>If specified, this callback will be invoked at several points
            during the OpenSSL handshake.  It can pass errors and tracing
            information, and it can allow Tcl scripts to perform
            their own validation of the certificate in place of the
            default validation provided by OpenSSL.
            The callback should return an integer whose interpretation
            depends on context.
            <br>
            See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a> for
            further discussion.</dd>
        <dt><strong>-keyfile</strong> <em>filename</em></dt>
        <dd>Provide the private key file. (<strong>default</strong>:
            value of -certfile)</dd>
        <dt><strong>-model</strong> <em>channel</em></dt>
        <dd>This will force this channel to share the same <em><strong>SSL_CTX</strong></em>
            structure as the specified <em>channel</em>, and
            therefore share callbacks etc.</dd>
        <dt><strong>-password</strong><em> callback</em></dt>
        <dd>If supplied, this callback will be invoked when OpenSSL needs
            to obtain a password, typically for a certificate.
            The callback should return a string which represents the
            password to be used.
            <br>
            See <a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a> for
            further discussion.</dd>
        <dt><strong>-request </strong><em>bool</em></dt>
        <dd>Request a certificate from peer during SSL handshake.
            (<strong>default</strong>: <em>true</em>)</dd>
        <dt><strong>-require</strong> <em>bool</em></dt>
        <dd>Require a valid certificate from peer during SSL
            handshake. If this is set to true then <strong>-request</strong>
            must also be set to true. (<strong>default</strong>: <em>false</em>)</dd>
        <dt><strong>-server</strong> <em>bool</em></dt>
        <dd>Handshake as server if true, else handshake as
            client.(<strong>default</strong>: <em>false</em>) <em>[Not
            client.(<strong>default</strong>: <em>false</em>)</dd>
            available to tls::socket]</em></dd>
        <dt><strong>-ssl2</strong> <em>bool</em></dt>
        <dd>Enable use of SSL v2. (<strong>default</strong>: <em>true</em>
            unless -DNO_PATENTS was specified in build)</dd>
        <dt><strong>-ssl3 </strong><em>bool</em></dt>
        <dd>Enable use of SSL v3. (<strong>default</strong>: <em>true</em>)</dd>
        <dt>-<strong>tls1</strong> <em>bool</em></dt>
        <dd>Enable use of TLS v1. (<strong>default</strong>: <em>false</em>)</dd>
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
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
258
259
260
261
262
263


264
265
266
267
268
269
270
271
272







+
-
+
+
+

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

-
-
-
+
+
+
+
+
+
+
+

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







        you supply, which must be one of <em>ssl2, ssl3, or tls1</em>.
        If <em>verbose</em> is specified as true then a verbose,
        semi-human readable list is returned providing additional
        information on the nature of the cipher support. In each
        case the result is a Tcl list.</dd>
</dl>

<dl>
<h3><a name="CONFIGURATION OPTIONS">CONFIGURATION OPTIONS</a></h3>
    <dt><a name="tls::version"><strong>tls::version</strong></a></dt>
    <dd>Returns the version string defined by OpenSSL.</dd>
</dl>

<h3><a name="CALLBACK OPTIONS">CALLBACK OPTIONS</a></h3>
<p>In addition to the options listed above you can set the <strong>tls::debug</strong>

flag to a non-zero value to see the output from the default
command callback (<strong>tls::callback</strong>) which shows the
<p>
As indicated above, individual channels can be given their own callbacks
to handle intermediate processing by the OpenSSL library, using the
<em>-command</em> and <em>-password</em> options passed to either of
progression of the SSL handshake. Setting this value to greated
than 1 will cause the default verify method in <strong>tls::callback</strong>
to always accept the certificate, even if it is invalid.</p>
<strong>tls::socket</strong> or <strong>tls::import</strong>.
</p>

<p>In a real-world deployment you should substitute your own
callback in place of <strong>tls::callback</strong>, via the <em>-command
</em>option to <strong>tls::socket</strong> or <strong>tls::import</strong>.</p>
<p>
Reference implementations of these callbacks are provided in the distribution
as <strong>tls::callback</strong> and <strong>tls::password</strong>.
Note that these are <em>sample</em> implementations only.  In a more realistic
deployment you would substitute your own callbacks, typically by configuring
the <em>-command</em> and <em>-password</em> options on each channel with
scripts to be executed when the callbacks are invoked.
</p>

<p>
The default behavior when the <em>-command</em> option is not specified is for
TLS to process the associated library callbacks internally.
<p>When the TLS layer needs to obtain a password, typically for a
certificate, the software will invoke a Tcl command called <strong>tls::password</strong>,
which should return a string which represents the password to be
used. A default implementation is provided, which simply returns<em>
The default behavior when the <em>-password</em> option is not specified is for
TLS to process the associated library callbacks by attempting to call
<strong>tls::password</strong>.
The difference between these two behaviors is a consequence of maintaining
compatibility with earlier implementations.  The use of implied callbacks
is not recommended.
</p>

<p>
The <strong>tls::debug</strong> variable provides some additional control
over the default commands.  Its value is zero by default.  Higher values
produce more diagnostic output.  Setting this value greater than zero
will also force the default verify method in <strong>tls::callback</strong>
&quot;secret&quot;</em> - you should redefine this procedure
after issuing the <em>package require tls</em>.</p>
to accept the certificate, even if it is invalid.
</p>

<h3><a name="HTTPS EXAMPLE">HTTPS EXAMPLE</a></h3>

<p>This example requires a patch to the <strong>http</strong>
module that ships with Tcl - this patch has been submitted for
inclusion in Tcl 8.2.1, but is also provided in the tls directory
if needed. A sample server.pem is provided with the TLS release,
260
261
262
263
264
265
266
267


268
269
299
300
301
302
303
304
305

306
307
308
309







-
+
+



<p><strong>socket</strong>, <strong>fileevent, </strong><a
href="http://www.openssl.org/"><strong>OpenSSL</strong></a></p>

<hr>

<pre>
Copyright 1999 Matt Newman.</pre>
Copyright &copy; 1999 Matt Newman.
</pre>
</body>
</html>

Modified tls.tcl from [3724c90f30] to [3de2fbdab5].

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/tls.tcl,v 1.3 2000/07/27 01:58:18 hobbs Exp $
# $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.tcl,v 1.4 2003/05/15 20:44:46 razzell Exp $
#
namespace eval tls {
    variable logcmd tclLog
    variable debug 0
 
    # Default flags passed to tls::import
    variable defaults {}
30
31
32
33
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
30
31
32
33
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







-
+




-
+








+
-
-
+
+
-
-



-
+

+
+







    set idx [lsearch $args -server]
    if {$idx != -1} {
	set server 1
	set callback [lindex $args [expr {$idx+1}]]
	set args [lreplace $args $idx [expr {$idx+1}]]

	set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
	set options "-cadir, -cafile, -certfile, -cipher, -keyfile, -myaddr, -request, -require, -ssl2, -ssl3, or -tls1"
	set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
	set options "-async, -cadir, -cafile, -certfile, -cipher, -keyfile, -myaddr, -myport, -request, -require, -ssl2, -ssl3, or -tls1"
	set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    }
    set argc [llength $args]
    set sopts {}
    set iopts [concat [list -server $server] ${tls::defaults}]	;# Import options

    for {set idx 0} {$idx < $argc} {incr idx} {
	set arg [lindex $args $idx]
	switch -glob -- $server,$arg {
	    0,-async	{lappend sopts $arg}
	    0,-myport	-
	    *,-myaddr	{lappend sopts $arg [lindex $args [incr idx]]}
	    0,-myaddr	-
	    *,-myport	{lappend sopts $arg [lindex $args [incr idx]]}
	    0,-async	{lappend sopts $arg}
	    *,-cipher	-
	    *,-cadir	-
	    *,-cafile	-
	    *,-certfile	-
	    *,-keyfile	-
	    *,-cipher	-
	    *,-command	-
	    *,-keyfile	-
	    *,-password	-
	    *,-request	-
	    *,-require	-
	    *,-ssl2	-
	    *,-ssl3	-
	    *,-tls1	{lappend iopts $arg [lindex $args [incr idx]]}
	    -*		{return -code error "bad option \"$arg\": must be one of $options"}
	    default	{break}
133
134
135
136
137
138
139
140
141
142

143
144
145
146
147
148
149
134
135
136
137
138
139
140


141
142
143
144
145
146
147
148
149







-
-

+







	log 2 "tls::_accept - called \"$callback\" succeeded"
    }
}
#
# Sample callback for hooking: -
#
# error
# info
# password
# verify
# info
#
proc tls::callback {option args} {
    variable debug

    #log 2 [concat $option $args]

    switch -- $option {
202
203
204
205
206
207
208

209
210
211
212
213

214
215
216
217
218
219
220
221
222
223
224
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







+





+











	    return 0
	}
	if {$cb(handshake) == "done"} {
	    return 1
	}
    }
}

proc tls::password {} {
    log 0 "TLS/Password: did you forget to set your passwd!"
    # Return the worlds best kept secret password.
    return "secret"
}

proc tls::log {level msg} {
    variable debug
    variable logcmd

    if {$level > $debug || $logcmd == ""} {
	return
    }
    set cmd $logcmd
    lappend cmd $msg
    uplevel #0 $cmd
}

Modified tlsInt.h from [14a764e8b0] to [3f35632d0e].

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/tlsInt.h,v 1.8 2000/08/18 19:17:14 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsInt.h,v 1.9 2003/05/15 20:44:46 razzell 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
91
92
93
94
95
96
97

98
99
100
101
102
103
104
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105







+








    int flags;		/* currently only CHANNEL_ASYNC */
    int watchMask;	/* current WatchProc mask */
    int mode;		/* current mode of parent channel */

    Tcl_Interp *interp;	/* interpreter in which this resides */
    Tcl_Obj *callback;	/* script called for tracing, verifying and errors */
    Tcl_Obj *password;	/* script called for certificate password */

    int vflags;		/* verify flags */
    SSL *ssl;		/* Struct for SSL processing */
    SSL_CTX *ctx;	/* SSL Context */
    BIO *bio;		/* Struct for SSL processing */
    BIO *p_bio;		/* Parent BIO (that is layered on Tcl_Channel) */