TclTLS
Check-in [1ef3d3faef]
Login
HomeTimelineDownloadBrowse SourceBranchesTagsTicketsWiki
Overview
Comment:Removed extra padding, convert spaces to tabs, etc.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tls-1.8
Files: files | file ages | folders
SHA3-256: 1ef3d3faef3bb7908e1cd7c7e8c8fec44b420d2aa106813d41e288d5a822d23b
User & Date: bohagan on 2024-10-26 16:08:31
Other Links: branch diff | manifest | tags
Context
2024-10-26
16:12
Added manifest.uuid file to clean files check-in: 28f9ada225 user: bohagan tags: tls-1.8
16:08
Removed extra padding, convert spaces to tabs, etc. check-in: 1ef3d3faef user: bohagan tags: tls-1.8
2024-10-25
05:13
More TCL9 updates check-in: ea36bcf6c4 user: bohagan tags: tls-1.8
Changes
Side-by-Side Diff Ignore Whitespace Patch
Modified generic/tls.c from [08752c37a7] to [87532f6227].
︙
2128
2129
2130
2131
2132
2133
2134
2135

2136
2137
2138
2139
2140
2141
2142

2128
2129
2130
2131
2132
2133
2134

2135
2136
2137
2138
2139
2140
2141
2142








-
+








	    if (certNames != NULL) {
		SSL_CTX_set_client_CA_list(ctx, certNames);
	    }
	    Tcl_DStringFree(&ds);
	}
#endif
    }
 

    if (abort > 0) {
	/* return error */
    }
    return ctx;
}

/*
︙
Modified generic/tlsBIO.c from [04379767a8] to [8197456eb7]. 
1
2
3
4
5
6
7
8
9
10
11
12
13
14

15
16
17
18
19
20
21

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

14
15
16
17
18
19
20
21














-
+








/*
 * Provides Custom BIO layer to interface OpenSSL with TCL. These
 * functions directly interface between the IO channel and BIO buffers.
 *
 * Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
 * Copyright (C) 2024 Brian O'Hagan
 *
 */

/*
		tlsBIO.c				tlsIO.c
  +------+                         +-----+                                     +------+
  |      |Tcl_WriteRaw <-- BioWrite| SSL |BIO_write <-- TlsOutputProc <-- Write|      |
  |socket|      <encrypted>        | BIO |            <unencrypted>            | App  | 
  |socket|      <encrypted>        | BIO |            <unencrypted>            | App  |
  |      |Tcl_ReadRaw  -->  BioRead|     |BIO_Read  --> TlsInputProc  -->  Read|      |
  +------+                         +-----+                                     +------+
*/

#include "tlsInt.h"
#include <openssl/bio.h>
︙
473
474
475
476
477
478
479
480

481
482
483
484
485
486
487

473
474
475
476
477
478
479

480
481
482
483
484
485
486
487








-
+








 */

BIO *BIO_new_tcl(State *statePtr, int flags) {
    BIO *bio;
#ifdef TCLTLS_SSL_USE_FASTPATH
    Tcl_Channel parentChannel;
    const Tcl_ChannelType *parentChannelType;
    

    int parentChannelFdIn, parentChannelFdOut, parentChannelFd;
    int validParentChannelFd;
#endif

    dprintf("BIO_new_tcl() called");

    /* Create custom BIO method */
︙
Modified generic/tlsIO.c from [d289c975da] to [5434dce8b9].
︙
21
22
23
24
25
26
27
28

29
30
31
32
33
34
35

21
22
23
24
25
26
27

28
29
30
31
32
33
34
35








-
+








 *
 */

/*
		tlsBIO.c				tlsIO.c
  +------+                         +-----+                                     +------+
  |      |Tcl_WriteRaw <-- BioWrite| SSL |BIO_write <-- TlsOutputProc <-- Write|      |
  |socket|      <encrypted>        | BIO |            <unencrypted>            | App  | 
  |socket|      <encrypted>        | BIO |            <unencrypted>            | App  |
  |      |Tcl_ReadRaw  -->  BioRead|     |BIO_Read  --> TlsInputProc  -->  Read|      |
  +------+                         +-----+                                     +------+
*/

#include "tlsInt.h"
#include <errno.h>
︙
384
385
386
387
388
389
390
391

392
393
394
395
396
397
398

384
385
386
387
388
389
390

391
392
393
394
395
396
397
398








-
+








 *	a POSIX error code if an error occurred, or 0 if none.
 *
 * Side effects:
 *    Reads input from the input device of the channel.
 *
 * Data is received in whole blocks known as records from the peer. A whole
 * record is processed (e.g. decrypted) in one go and is buffered by OpenSSL
 * until it is read by the application via a call to SSL_read. 
 * until it is read by the application via a call to SSL_read.
 *
 *-----------------------------------------------------------------------------
 */
static int TlsInputProc(ClientData instanceData, char *buf, int bufSize, int *errorCodePtr) {
    unsigned long backingError;
    State *statePtr = (State *) instanceData;
    int bytesRead, err;
︙
455
456
457
458
459
460
461
462

463
464
465
466
467
468
469

455
456
457
458
459
460
461

462
463
464
465
466
467
468
469








-
+








	    dprintf("Read failed with code=%d, bytes read=%d: should retry", err, bytesRead);
	    /* Some docs imply we should redo the BIO_read now */
	} else {
	    dprintf("Read failed with code=%d, bytes read=%d: error condition", err, bytesRead);
	}

	dprintf("BIO is EOF %d", BIO_eof(statePtr->bio));
	

	/* These are the same as BIO_retry_type */
	if (BIO_should_read(statePtr->bio)) {
	    dprintf("BIO has insufficient data to read and return");
	    statePtr->want |= TCL_READABLE;
	}
	if (BIO_should_write(statePtr->bio)) {
	    dprintf("BIO has pending data to write");
︙
591
592
593
594
595
596
597
598

599
600
601
602
603
604
605

591
592
593
594
595
596
597

598
599
600
601
602
603
604
605








-
+









/*
 *-----------------------------------------------------------------------------
 *
 * TlsOutputProc --
 *
 *	This procedure is invoked by the generic I/O layer to write data to the
 *	BIO whenever the the Tcl_Write(), Tcl_WriteChars, and Tcl_WriteObj 
 *	BIO whenever the the Tcl_Write(), Tcl_WriteChars, and Tcl_WriteObj
 *	functions are used. Equivalent to SSL_write_ex and SSL_write.
 *
 * Results:
 *    Returns the number of bytes written or -1 on error. Sets errorCodePtr
 *    to a POSIX error code if an error occurred, or 0 if none.
 *
 * Side effects:
︙
Modified generic/tlsX509.c from [9f6686e000] to [d88846a73e].
︙
42
43
44
45
46
47
48
49
50


51
52
53
54
55
56
57

42
43
44
45
46
47
48


49
50
51
52
53
54
55
56
57








-
-
+
+








    const char *hex = "0123456789abcdef";

    if (resultObj == NULL) {
	return NULL;
    }

    for (int i = 0; i < ilen; i++) {
        *dptr++ = hex[(*iptr>>4)&0xF];
        *dptr++ = hex[(*iptr++)&0xF];
	*dptr++ = hex[(*iptr>>4)&0xF];
	*dptr++ = hex[(*iptr++)&0xF];
    }
    return resultObj;
}

/*
 *-----------------------------------------------------------------------------
 *
︙
639
640
641
642
643
644
645
646

647
648
649
650
651
652
653

639
640
641
642
643
644
645

646
647
648
649
650
651
652
653








-
+








    LAPPEND_BOOL(interp, resultObj, "extInvalid", xflags & EXFLAG_INVALID);
    LAPPEND_BOOL(interp, resultObj, "isCACert", X509_check_ca(cert));

    /* The Unique Ids are used to handle the possibility of reuse of subject
	and/or issuer names over time. RFC 5280 section 4.1.2.8 */
    {
	const ASN1_BIT_STRING *iuid, *suid;
        X509_get0_uids(cert, &iuid, &suid);
	X509_get0_uids(cert, &iuid, &suid);

	Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("issuerUniqueId", -1));
	if (iuid != NULL) {
	    Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewByteArrayObj((const unsigned char *)iuid->data, (Tcl_Size) iuid->length));
	} else {
	    Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("", -1));
	}
︙
736
737
738
739
740
741
742
743

744
745

746
747
748
749
750
751
752

736
737
738
739
740
741
742

743
744

745
746
747
748
749
750
751
752








-
+

-
+









    /* Subject Information Access - RFC 5280 section 4.2.2.2, NID_sinfo_access */

    /* Certificate Alias. If uses a PKCS#12 structure, alias will reflect the
	friendlyName attribute (RFC 2985). */
    {
	int ilen = 0;
        unsigned char *string = X509_alias_get0(cert, &ilen);
	unsigned char *string = X509_alias_get0(cert, &ilen);
	LAPPEND_STR(interp, resultObj, "alias", (char *) string, (Tcl_Size) ilen);
        string = X509_keyid_get0(cert, &ilen);
	string = X509_keyid_get0(cert, &ilen);
	LAPPEND_STR(interp, resultObj, "keyId", (char *) string, (Tcl_Size) ilen);
    }

    /* Certificate and dump all data */
    if (all) {
	Tcl_Obj *allObj = Tcl_NewByteArrayObj(NULL, 0);
	Tcl_Obj *certObj = Tcl_NewByteArrayObj(NULL, 0);
︙
Modified library/tls.tcl from [e92fa9f6e0] to [852d83e8d6].
︙
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
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

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
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








-
+












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


















-
+










-
-
-
-
+
+
+
+

-
-
-
-
+
+
+
+

-
-
+
+

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

-
+








    # Maps UID to Server Socket
    variable srvmap
    variable srvuid 0

    # Over-ride this if you are using a different socket command
    variable socketCmd
    if {![info exists socketCmd]} {
        set socketCmd [info command ::socket]
	set socketCmd [info command ::socket]
    }

    # This is the possible arguments to tls::socket and tls::init
    # The format of this is a list of lists
    ## Each inner list contains the following elements
    ### Server (matched against "string match" for 0/1)
    ### Option name
    ### Variable to add the option to:
    #### sopts: [socket] option
    #### iopts: [tls::import] option
    ### How many arguments the following the option to consume
    variable socketOptionRules {
        {0 -async sopts 0}
        {* -myaddr sopts 1}
        {0 -myport sopts 1}
        {* -type sopts 1}
        {* -alpn iopts 1}
        {* -cadir iopts 1}
        {* -cafile iopts 1}
        {* -castore iopts 1}
        {* -cert iopts 1}
        {* -certfile iopts 1}
        {* -cipher iopts 1}
        {* -ciphersuites iopts 1}
        {* -command iopts 1}
        {* -dhparams iopts 1}
        {* -key iopts 1}
        {* -keyfile iopts 1}
        {* -password iopts 1}
        {* -post_handshake iopts 1}
        {* -request iopts 1}
        {* -require iopts 1}
        {* -securitylevel iopts 1}
        {* -autoservername discardOpts 1}
        {* -server iopts 1}
        {* -servername iopts 1}
        {* -session_id iopts 1}
        {* -ssl2 iopts 1}
        {* -ssl3 iopts 1}
        {* -tls1 iopts 1}
        {* -tls1.1 iopts 1}
        {* -tls1.2 iopts 1}
        {* -tls1.3 iopts 1}
        {* -validatecommand iopts 1}
        {* -vcmd iopts 1}
	{0 -async sopts 0}
	{* -myaddr sopts 1}
	{0 -myport sopts 1}
	{* -type sopts 1}
	{* -alpn iopts 1}
	{* -cadir iopts 1}
	{* -cafile iopts 1}
	{* -castore iopts 1}
	{* -cert iopts 1}
	{* -certfile iopts 1}
	{* -cipher iopts 1}
	{* -ciphersuites iopts 1}
	{* -command iopts 1}
	{* -dhparams iopts 1}
	{* -key iopts 1}
	{* -keyfile iopts 1}
	{* -password iopts 1}
	{* -post_handshake iopts 1}
	{* -request iopts 1}
	{* -require iopts 1}
	{* -securitylevel iopts 1}
	{* -autoservername discardOpts 1}
	{* -server iopts 1}
	{* -servername iopts 1}
	{* -session_id iopts 1}
	{* -ssl2 iopts 1}
	{* -ssl3 iopts 1}
	{* -tls1 iopts 1}
	{* -tls1.1 iopts 1}
	{* -tls1.2 iopts 1}
	{* -tls1.3 iopts 1}
	{* -validatecommand iopts 1}
	{* -vcmd iopts 1}
    }

    # tls::socket and tls::init options as a humane readable string
    variable socketOptionsNoServer
    variable socketOptionsServer

    # Internal [switch] body to validate options
    variable socketOptionsSwitchBody
}

proc tls::_initsocketoptions {} {
    variable socketOptionRules
    variable socketOptionsNoServer
    variable socketOptionsServer
    variable socketOptionsSwitchBody

    # Do not re-run if we have already been initialized
    if {[info exists socketOptionsSwitchBody]} {
        return
	return
    }

    # Create several structures from our list of options
    ## 1. options: a text representation of the valid options for the current
    ##             server type
    ## 2. argSwitchBody: Switch body for processing arguments
    set options(0) [list]
    set options(1) [list]
    set argSwitchBody [list]
    foreach optionRule $socketOptionRules {
        set ruleServer [lindex $optionRule 0]
        set ruleOption [lindex $optionRule 1]
        set ruleVarToUpdate [lindex $optionRule 2]
        set ruleVarArgsToConsume [lindex $optionRule 3]
	set ruleServer [lindex $optionRule 0]
	set ruleOption [lindex $optionRule 1]
	set ruleVarToUpdate [lindex $optionRule 2]
	set ruleVarArgsToConsume [lindex $optionRule 3]

        foreach server [list 0 1] {
            if {![string match $ruleServer $server]} {
                continue
            }
	foreach server [list 0 1] {
	    if {![string match $ruleServer $server]} {
		continue
	    }

            lappend options($server) $ruleOption
        }
	    lappend options($server) $ruleOption
	}

        switch -- $ruleVarArgsToConsume {
            0 {
                set argToExecute {
                    lappend @VAR@ $arg
                    set argsArray($arg) true
                }
            }
            1 {
                set argToExecute {
                    incr idx
                    if {$idx >= [llength $args]} {
                        return -code error "\"$arg\" option must be followed by value"
                    }
                    set argValue [lindex $args $idx]
                    lappend @VAR@ $arg $argValue
                    set argsArray($arg) $argValue
                }
            }
            default {
                return -code error "Internal argument construction error"
            }
        }
	switch -- $ruleVarArgsToConsume {
	    0 {
		set argToExecute {
		    lappend @VAR@ $arg
		    set argsArray($arg) true
		}
	    }
	    1 {
		set argToExecute {
		    incr idx
		    if {$idx >= [llength $args]} {
			return -code error "\"$arg\" option must be followed by value"
		    }
		    set argValue [lindex $args $idx]
		    lappend @VAR@ $arg $argValue
		    set argsArray($arg) $argValue
		}
	    }
	    default {
		return -code error "Internal argument construction error"
	    }
	}

        lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
	lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
    }

    # Add in the final options
    lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
    lappend argSwitchBody default break

    # Set the final variables
︙
212
213
214
215
216
217
218
219

220
221
222
223
224

225
226
227
228
229
230
231

212
213
214
215
216
217
218

219
220
221
222
223

224
225
226
227
228
229
230
231








-
+




-
+








    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 $socketOptionsServer
	set options $socketOptionsServer
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
        set options $socketOptionsNoServer
	set options $socketOptionsNoServer
    }

    # Combine defaults with current options
    set args [concat $defaults $args]

    set argc [llength $args]
    set sopts {}
︙
252
253
254
255
256
257
258
259
260
261
262
263
264
265







266
267
268
269
270
271
272

252
253
254
255
256
257
258







259
260
261
262
263
264
265
266
267
268
269
270
271
272








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








	if {($idx + 2) != $argc} {
	    return -code error $usage
	}

	set host [lindex $args [expr {$argc-2}]]
	set port [lindex $args [expr {$argc-1}]]

        # If an "-autoservername" option is found, honor it
        if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
            if {![info exists argsArray(-servername)]} {
                set argsArray(-servername) $host
                lappend iopts -servername $host
            }
        }
	# If an "-autoservername" option is found, honor it
	if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
	    if {![info exists argsArray(-servername)]} {
		set argsArray(-servername) $host
		lappend iopts -servername $host
	    }
	}

	lappend sopts $host $port
    }
    #
    # Create TCP/IP socket
    #
    set chan [eval $socketCmd $sopts]
︙
Modified tests/keytest2.tcl from [4103d4acae] to [de5bedeb58]. 
1

2
3
4
5
6
7
8


1
2
3
4
5
6
7
8

-
+








#! /usr/bin/env tclsh
#!/usr/bin/env tclsh

set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]]
package require tls

set s [tls::socket 127.0.0.1 12300]
puts $s "A line"
flush $s
︙
Powered by Fossil · RSS