Diff
EuroTcl/OpenACS 11 - 12 JULY 2024, VIENNA

Differences From Artifact [ebec730afe]:

To Artifact [e64436e2e3]:


1
2
3
4
5
6

7
8

9
10
11
12
13
14
15
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 
 *	Copyright (C) 2004 Starfish Systems 
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.19 2004/02/04 04:02:19 razzell Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.20 2004/02/13 02:09:21 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
 *
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
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







-
+

-
+


-
+
+
+
+









-
-
+
+
+







}

/*
 *-------------------------------------------------------------------
 *
 * VerifyCallback --
 *
 *	monitors SSL cerificate validation process
 *	Monitors SSL certificate validation process.
 *	This is called whenever a certificate is inspected
 *	 or decided invalid
 *	or decided invalid.
 *
 * Results:
 *	ok - let SSL handle it
 *	A callback bound to the socket may return one of:
 *	    0			- the certificate is deemed invalid
 *	    1			- the certificate is deemed valid
 *	    empty string	- no change to certificate validation
 *
 * Side effects:
 *	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;
    Tcl_Obj *cmdPtr, *result;
    char *errStr, *string;
    int length;
    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);
    int depth		= X509_STORE_CTX_get_error_depth(ctx);
    int err		= X509_STORE_CTX_get_error(ctx);

    dprintf(stderr, "Verify: %d\n", ok);
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
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







-
+



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







-
+










-
-
-







	    Tcl_NewStringObj( errStr ? errStr : "", -1) );

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

    Tcl_IncrRefCount( cmdPtr);
    if (Tcl_GlobalEvalObj(statePtr->interp, cmdPtr) != TCL_OK) {
	/* it got an error - reject the certificate */
	/* It got an error - reject the certificate.		*/
	Tcl_BackgroundError( statePtr->interp);
	ok = 0;
    } else {
	result = Tcl_GetObjResult(statePtr->interp);
	string = Tcl_GetStringFromObj(result, &length);
	/* An empty result leaves verification unchanged.	*/
	if (length > 0) {
	if (Tcl_GetIntFromObj( statePtr->interp,
	    if (Tcl_GetIntFromObj(statePtr->interp, result, &ok) != TCL_OK) {
		    Tcl_GetObjResult( statePtr->interp), &ok) != TCL_OK) {
	    Tcl_BackgroundError( statePtr->interp);
	    ok = 0;
		Tcl_BackgroundError(statePtr->interp);
		ok = 0;
	    }
	}
    }
    Tcl_DecrRefCount( cmdPtr);

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

    return(ok);	/* leave the disposition as SSL set it */
    return(ok);	/* By default, leave verification unchanged.	*/
}

/*
 *-------------------------------------------------------------------
 *
 * Tls_Error --
 *
 *	Calls callback with $fd and $msg - so the callback can decide
 *	what to do with errors.
 *
 * Results:
 *	ok - let SSL handle it
 *
 * Side effects:
 *	The err field of the currently operative State is set
 *	  to a string describing the SSL negotiation failure reason
 *-------------------------------------------------------------------
 */
void
Tls_Error(State *statePtr, char *msg)