Diff

Differences From Artifact [8569dadd68]:

To Artifact [7f2f9df19f]:


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 <matt@novadigm.com>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.8 2000/07/27 01:58:18 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.9 2000/08/15 00:02:08 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 (a.kupries@westend.com), for
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
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







-
-
+

+
+
+
+
+
+
-
+













-
-
+
+

+
+
+
+
+
+










-



+
-
+
+
+
+







			int mask));
static void	TlsChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData));

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */
#ifdef TCL_CHANNEL_VERSION_2
static Tcl_ChannelType tlsChannelType = {
static Tcl_ChannelType tlsChannelType2 = {
    "tls",		/* Type name. */
#ifndef TCL_CHANNEL_VERSION_2
    /*
     * Avoids warning in Windows compiler when compiling with 8.3.1-.
     */
    (Tcl_DriverBlockModeProc *)
#endif
    TCL_CHANNEL_VERSION_2,	/* A v2 channel (8.3.2/8.4a2+) */
    TCL_CHANNEL_VERSION_2,	/* A v2 channel (8.3.2+) */
    TlsCloseProc,	/* Close proc. */
    TlsInputProc,	/* Input proc. */
    TlsOutputProc,	/* Output proc. */
    NULL,		/* Seek proc. */
    NULL,		/* Set option proc. */
    TlsGetOptionProc,	/* Get option proc. */
    TlsWatchProc,	/* Initialize notifier. */
    TlsGetHandleProc,	/* Get file handle out of channel. */
    NULL,		/* Close2Proc. */
    TlsBlockModeProc,	/* Set blocking/nonblocking mode.*/
    NULL,		/* FlushProc. */
    TlsNotifyProc,	/* handlerProc. */
};
#else
static Tcl_ChannelType tlsChannelType = {

static Tcl_ChannelType tlsChannelType1 = {
    "tls",		/* Type name. */
#ifdef TCL_CHANNEL_VERSION_2
    /*
     * Avoids warning in Windows compiler when compiling with 8.3.2+.
     */
    (Tcl_ChannelTypeVersion)
#endif
    TlsBlockModeProc,	/* Set blocking/nonblocking mode.*/
    TlsCloseProc,	/* Close proc. */
    TlsInputProc,	/* Input proc. */
    TlsOutputProc,	/* Output proc. */
    NULL,		/* Seek proc. */
    NULL,		/* Set option proc. */
    TlsGetOptionProc,	/* Get option proc. */
    TlsWatchProc,	/* Initialize notifier. */
    TlsGetHandleProc,	/* Get file handle out of channel. */
};
#endif

Tcl_ChannelType *Tls_ChannelType()
{
    if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
    return &tlsChannelType;
	return &tlsChannelType2;
    } else {
	return &tlsChannelType1;
    }
}

/*
 *-------------------------------------------------------------------
 *
 * TlsBlockModeProc --
 *
118
119
120
121
122
123
124
125
126
127
128




129
130

131
132
133
134
135
136
137
132
133
134
135
136
137
138




139
140
141
142
143

144
145
146
147
148
149
150
151







-
-
-
-
+
+
+
+

-
+







    State *statePtr = (State *) instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
	statePtr->flags |= TLS_TCL_ASYNC;
    } else {
	statePtr->flags &= ~(TLS_TCL_ASYNC);
    }
#ifdef TCL_CHANNEL_VERSION_2
    return 0;
#else
    return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
    if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
	return 0;
    } else {
	return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
		"-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1");
#endif
    }
}

/*
 *-------------------------------------------------------------------
 *
 * TlsCloseProc --
 *
153
154
155
156
157
158
159
160
161
162
163
164





165
166
167


168

169
170
171
172
173
174
175
167
168
169
170
171
172
173





174
175
176
177
178
179


180
181

182
183
184
185
186
187
188
189







-
-
-
-
-
+
+
+
+
+

-
-
+
+
-
+







TlsCloseProc(ClientData instanceData,	/* The socket to close. */
             Tcl_Interp *interp)	/* For error reporting - unused. */
{
    State *statePtr = (State *) instanceData;

    dprintf(stderr,"\nTlsCloseProc(0x%x)", statePtr);

#ifndef TCL_CHANNEL_VERSION_2
    /*
     * Remove event handler to underlying channel, this could
     * be because we are closing for real, or being "unstacked".
     */
    if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
	/*
	 * Remove event handler to underlying channel, this could
	 * be because we are closing for real, or being "unstacked".
	 */

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

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










426
427

428

429
430
431
432
433
434
435
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
425
426











427
428
429
430
431
432
433
434
435
436
437

438

439
440
441
442
443
444
445
446







-
-












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

-

+
+
-
-
+
+

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

-
-
-
+
+
+

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

-
+
-
+







 *-------------------------------------------------------------------
 *
 * TlsGetOptionProc --
 *
 *	Computes an option value for a SSL socket based channel, or a
 *	list of all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a
 *	list of all options and	their values is returned in the
 *	supplied DString.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------
 */
static int
TlsGetOptionProc(ClientData instanceData,	/* Socket state. */
                 Tcl_Interp *interp,		/* For errors - can be NULL. */
                 char *optionName,		/* Name of the option to
                                                 * retrieve the value for, or
                                                 * NULL to get all options and
                                                 * their values. */
                 Tcl_DString *dsPtr)	         /* Where to store the computed value
                                                  * initialized by caller. */
	Tcl_Interp *interp,		/* For errors - can be NULL. */
	char *optionName,		/* Name of the option to
					 * retrieve the value for, or
					 * NULL to get all options and
					 * their values. */
	Tcl_DString *dsPtr)		/* Where to store the computed value
					 * initialized by caller. */
{
#ifdef TCL_CHANNEL_VERSION_2
    State *statePtr = (State *) instanceData;

    if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
    Tcl_Channel downChan = Tls_GetParent(statePtr);
    Tcl_DriverGetOptionProc *getOptionProc;
	Tcl_Channel downChan = Tls_GetParent(statePtr);
	Tcl_DriverGetOptionProc *getOptionProc;

    getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
    if (getOptionProc != NULL) {
	return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
		interp, optionName, dsPtr);
    } else if (optionName == (char*) NULL) {
	/*
	 * Request is query for all options, this is ok.
	 */
	return TCL_OK;
    }
    /*
     * Request for a specific option has to fail, we don't have any.
     */
    return TCL_ERROR;
#else
	getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
	if (getOptionProc != NULL) {
	    return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
		    interp, optionName, dsPtr);
	} else if (optionName == (char*) NULL) {
	    /*
	     * Request is query for all options, this is ok.
	     */
	    return TCL_OK;
	}
	/*
	 * Request for a specific option has to fail, we don't have any.
	 */
	return TCL_ERROR;
    } else {
    State *statePtr = (State *) instanceData;
    size_t len = 0;
	size_t len = 0;

    if (optionName != (char *) NULL) {
        len = strlen(optionName);
    }
	if (optionName != (char *) NULL) {
	    len = strlen(optionName);
	}
#if 0
    if ((len == 0) ||
        ((len > 1) && (optionName[1] == 'c') &&
         (strncmp(optionName, "-cipher", len) == 0))) {
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-cipher");
        }
        Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
        if (len) {
            return TCL_OK;
        }
    }
	if ((len == 0) || ((len > 1) && (optionName[1] == 'c') &&
		(strncmp(optionName, "-cipher", len) == 0))) {
	    if (len == 0) {
		Tcl_DStringAppendElement(dsPtr, "-cipher");
	    }
	    Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
	    if (len) {
		return TCL_OK;
	    }
	}
#endif
    return TCL_OK;
	return TCL_OK;
#endif
    }
}

/*
 *-------------------------------------------------------------------
 *
 * TlsWatchProc --
 *
449
450
451
452
453
454
455
456
457


458
459

460
461
462
463
464
465
466
467







468
469

470
471
472


473
474
475
476



477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492















493
494
495
496
497
498





499
500
501
502
503
504
505
506
507








508
509
510
511




512

513
514
515
516
517
518
519
460
461
462
463
464
465
466


467
468
469

470
471







472
473
474
475
476
477
478
479

480
481


482
483
484



485
486
487
488















489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504





505
506
507
508
509
510








511
512
513
514
515
516
517
518
519



520
521
522
523

524
525
526
527
528
529
530
531







-
-
+
+

-
+

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

-
+

-
-
+
+

-
-
-
+
+
+

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

-
-
-
-
-
+
+
+
+
+

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

-
-
-
+
+
+
+
-
+







TlsWatchProc(ClientData instanceData,	/* The socket state. */
             int mask)			/* Events of interest; an OR-ed
                                         * combination of TCL_READABLE,
                                         * TCL_WRITABLE and TCL_EXCEPTION. */
{
    State *statePtr = (State *) instanceData;

#ifdef TCL_CHANNEL_VERSION_2
    Tcl_Channel     downChan;
    if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
	Tcl_Channel     downChan;

    statePtr->watchMask = mask;
	statePtr->watchMask = mask;

    /* No channel handlers any more. We will be notified automatically
     * about events on the channel below via a call to our
     * 'TransformNotifyProc'. But we have to pass the interest down now.
     * We are allowed to add additional 'interest' to the mask if we want
     * to. But this transformation has no such interest. It just passes
     * the request down, unchanged.
     */
	/* No channel handlers any more. We will be notified automatically
	 * about events on the channel below via a call to our
	 * 'TransformNotifyProc'. But we have to pass the interest down now.
	 * We are allowed to add additional 'interest' to the mask if we want
	 * to. But this transformation has no such interest. It just passes
	 * the request down, unchanged.
	 */

    downChan = Tls_GetParent(statePtr);
	downChan = Tls_GetParent(statePtr);

    (Tcl_GetChannelType(downChan))
	->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
	(Tcl_GetChannelType(downChan))
	    ->watchProc(Tcl_GetChannelInstanceData(downChan), mask);

    /*
     * Management of the internal timer.
     */
	/*
	 * Management of the internal timer.
	 */

    if (statePtr->timer != (Tcl_TimerToken) NULL) {
        Tcl_DeleteTimerHandler(statePtr->timer);
	statePtr->timer = (Tcl_TimerToken) NULL;
    }
    if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
        /*
	 * There is interest in readable events and we actually have
	 * data waiting, so generate a timer to flush that.
	 */
	statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
		TlsChannelHandlerTimer, (ClientData) statePtr);
    }
#else
    if (mask == statePtr->watchMask)
	return;
	if (statePtr->timer != (Tcl_TimerToken) NULL) {
	    Tcl_DeleteTimerHandler(statePtr->timer);
	    statePtr->timer = (Tcl_TimerToken) NULL;
	}
	if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
	    /*
	     * There is interest in readable events and we actually have
	     * data waiting, so generate a timer to flush that.
	     */
	    statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
		    TlsChannelHandlerTimer, (ClientData) statePtr);
	}
    } else {
	if (mask == statePtr->watchMask)
	    return;

    if (statePtr->watchMask) {
	/*
	 * Remove event handler to underlying channel, this could
	 * be because we are closing for real, or being "unstacked".
	 */
	if (statePtr->watchMask) {
	    /*
	     * Remove event handler to underlying channel, this could
	     * be because we are closing for real, or being "unstacked".
	     */

	Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
		TlsChannelHandler, (ClientData) statePtr);
    }
    statePtr->watchMask = mask;
    if (statePtr->watchMask) {
	/*
	 * Setup active monitor for events on underlying Channel.
	 */
	    Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
		    TlsChannelHandler, (ClientData) statePtr);
	}
	statePtr->watchMask = mask;
	if (statePtr->watchMask) {
	    /*
	     * Setup active monitor for events on underlying Channel.
	     */

	Tcl_CreateChannelHandler(Tls_GetParent(statePtr),
		statePtr->watchMask, TlsChannelHandler, (ClientData) statePtr);
    }
	    Tcl_CreateChannelHandler(Tls_GetParent(statePtr),
		    statePtr->watchMask, TlsChannelHandler,
		    (ClientData) statePtr);
	}
#endif
    }
}

/*
 *-------------------------------------------------------------------
 *
 * TlsGetHandleProc --
 *
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
592
593
594
595
596
597
598

599
600
601
602
603
604
605







-







	Tcl_DeleteTimerHandler(statePtr->timer);
	statePtr->timer = (Tcl_TimerToken) NULL;
    }

    return mask;
}

#ifndef TCL_CHANNEL_VERSION_2
/*
 *------------------------------------------------------*
 *
 *      TlsChannelHandler --
 *
 *      ------------------------------------------------*
 *      Handler called by Tcl as a result of
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
671
672
673
674
675
676
677

678
679
680
681
682
683
684







-







	 * Data is waiting, flush it out in short time
	 */
	statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
		TlsChannelHandlerTimer, (ClientData) statePtr);
    }
    Tcl_Release( (ClientData)statePtr);
}
#endif

/*
 *------------------------------------------------------*
 *
 *	TlsChannelHandlerTimer --
 *
 *	------------------------------------------------*
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
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
832

833


834
835







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

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

-
+
-
-
+

    }
}

Tcl_Channel
Tls_GetParent( statePtr )
    State *statePtr;
{
#ifdef TCL_CHANNEL_VERSION_2
    return Tcl_GetStackedChannel(statePtr->self);
#else
    if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
	return Tcl_GetStackedChannel(statePtr->self);
    } else {
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2
    return statePtr->parent;
#else
    /* The reason for the existence of this procedure is
     * the fact that stacking a transform over another
     * transform will leave our internal pointer unchanged,
     * and thus pointing to the new transform, and not the
     * Channel structure containing the saved state of this
     * transform. This is the price to pay for leaving
     * Tcl_Channel references intact. The only other solution
     * is an extension of Tcl_ChannelType with another driver
     * procedure to notify a Channel about the (un)stacking.
     *
     * It walks the chain of Channel structures until it
     * finds the one pointing having 'ctrl' as instanceData
     * and then returns the superceding channel to that. (AK)
     */
 
    Tcl_Channel self = statePtr->self;
    Tcl_Channel next;
	/* The reason for the existence of this procedure is
	 * the fact that stacking a transform over another
	 * transform will leave our internal pointer unchanged,
	 * and thus pointing to the new transform, and not the
	 * Channel structure containing the saved state of this
	 * transform. This is the price to pay for leaving
	 * Tcl_Channel references intact. The only other solution
	 * is an extension of Tcl_ChannelType with another driver
	 * procedure to notify a Channel about the (un)stacking.
	 *
	 * It walks the chain of Channel structures until it
	 * finds the one pointing having 'ctrl' as instanceData
	 * and then returns the superceding channel to that. (AK)
	 */

	Tcl_Channel self = statePtr->self;
	Tcl_Channel next;

    while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) {
	next = Tcl_GetStackedChannel (self);
	if (next == (Tcl_Channel) NULL) {
	    /* 09/24/1999 Unstacking bug,
	     * found by Matt Newman <matt@sensus.org>.
	     *
	     * We were unable to find the channel structure for this
	     * transformation in the chain of stacked channel. This
	     * means that we are currently in the process of unstacking
	     * it *and* there were some bytes waiting which are now
	     * flushed. In this situation the pointer to the channel
	     * itself already refers to the parent channel we have to
	     * write the bytes into, so we return that.
	     */
	    return statePtr->self;
	}
	self = next;
    }
	while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) {
	    next = Tcl_GetStackedChannel (self);
	    if (next == (Tcl_Channel) NULL) {
		/* 09/24/1999 Unstacking bug,
		 * found by Matt Newman <matt@sensus.org>.
		 *
		 * We were unable to find the channel structure for this
		 * transformation in the chain of stacked channel. This
		 * means that we are currently in the process of unstacking
		 * it *and* there were some bytes waiting which are now
		 * flushed. In this situation the pointer to the channel
		 * itself already refers to the parent channel we have to
		 * write the bytes into, so we return that.
		 */
		return statePtr->self;
	    }
	    self = next;
	}

    return Tcl_GetStackedChannel (self);
	return Tcl_GetStackedChannel (self);
#endif
#endif
    }
}