TclTLS
Changes On Branch 219e71c67267efdd
Login
HomeTimelineDownloadBrowse SourceBranchesTagsTicketsWiki
Hide Diff Patch Side-by-Side Diff

Changes In Branch feature-0d4541b86d-autoservername Through [219e71c672] Excluding Merge-Ins

This is equivalent to a diff from c920627e0b to 219e71c672

2016-12-14
14:40
Updated EOF while reading from the BIO to map to soft EOF check-in: 24ce678ecd user: rkeene tags: trunk
14:07
Consolidated rules for parsing options and now verify them in tls::init as well check-in: 98b60c41b6 user: rkeene tags: feature-0d4541b86d-autoservername
06:27
Updated example to include "-autoservername" check-in: 219e71c672 user: rkeene tags: feature-0d4541b86d-autoservername
06:18
Started work on adding an "-autoservername" option to tls::socket which will automatically add the -servername <host> option check-in: f0c5ec5595 user: rkeene tags: feature-0d4541b86d-autoservername
01:10
Minor update to the README check-in: c920627e0b user: rkeene tags: trunk
2016-12-13
21:50
Remove spurious sentence check-in: 4dca0b3137 user: rkeene tags: trunk

Modified tls.htm from [4c4e8f1d42] to [9d6687fab1].

︙
99
100
101
102
103
104
105
106








107
108
109
110
111
112
113

99
100
101
102
103
104
105

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120








-
+
+
+
+
+
+
+
+








        host port</em></a></dt>
    <dt><b>tls::socket</b><em> ?-server command? ?options? port</em></dt>
    <dd>This is a helper function that utilizes the underlying
        commands (<strong>tls::import</strong>). It behaves
        exactly the same as the native Tcl <strong>socket</strong>
        command except that the options can include any of the
        applicable <a href="#tls::import"><strong>tls:import</strong></a>
        options.</dd>
        options with one additional option:
<blockquote>
    <dl>
        <dt><strong>-autoservername</strong> <em>bool</em></dt>
        <dd>Automatically send the -servername as the <em>host</em> argument
            (<strong>default</strong>: <em>false</em>)</dd>
    </dl>
</blockquote>
    <dt>&nbsp;</dt>
    <dt><a name="tls::handshake"><strong>tls::handshake</strong> <em>channel</em></a></dt>
    <dd>Forces handshake to take place, and returns 0 if
        handshake is still in progress (non-blocking), or 1 if
        the handshake was successful. If the handshake failed
        this routine will throw an error.</dd>
    <dt>&nbsp;</dt>
︙
396
397
398
399
400
401
402
403

404
405

406
407
408
409
410
411
412

403
404
405
406
407
408
409

410
411

412
413
414
415
416
417
418
419








-
+

-
+








<p>This example uses a sample server.pem provided with the TLS release,
courtesy of the <strong>OpenSSL</strong> project.</p>

<pre><code>
package require http
package require tls

http::register https 443 [list ::tls::socket -require 1 -cafile ./server.pem]
http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]

set tok [http::geturl https://developer.netscape.com/]
set tok [http::geturl https://www.tcl.tk/]
</code></pre>

<h3><a name="SPECIAL CONSIDERATIONS">SPECIAL CONSIDERATIONS</a></h3>

<p>The capabilities of this package can vary enormously based
upon how your OpenSSL library was configured and built. At the
most macro-level OpenSSL supports a &quot;no patents&quot; build,
︙

Modified tls.tcl from [90f08f912e] to [845877fe79].

︙
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

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
138
139
140
141

142
























143
144
145
146
147
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








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







-




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


-
+

+


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















+


+
+
+
+
+
+
+
+
+








}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
    variable socketCmd
    variable defaults

    # server,option,variable,args
    set usageRules {
        {0 -async sopts 0}
        {* -myaddr sopts 1}
        {0 -myport sopts 1}
        {* -type sopts 1}
        {* -cadir iopts 1}
        {* -cafile iopts 1}
        {* -certfile iopts 1}
        {* -cipher iopts 1}
        {* -command iopts 1}
        {* -dhparams iopts 1}
        {* -keyfile iopts 1}
        {* -password iopts 1}
        {* -request iopts 1}
        {* -require iopts 1}
        {0 -autoservername discardOpts 1}
        {* -servername iopts 1}
        {* -ssl2 iopts 1}
        {* -ssl3 iopts 1}
        {* -tls1 iopts 1}
        {* -tls1.1 iopts 1}
        {* -tls1.2 iopts 1}
    }

    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, -command, -dhparams, -keyfile, -myaddr, -password, -request, -require, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2"
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
    }
	set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -dhparams, -keyfile, -myaddr, -myport, -password, -request, -require, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2"
    }

    # 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 [list]
    set argSwitchBody [list]
    foreach usageRule $usageRules {
        set ruleServer [lindex $usageRule 0]
        set ruleOption [lindex $usageRule 1]
        set ruleVarToUpdate [lindex $usageRule 2]
        set ruleVarArgsToConsume [lindex $usageRule 3]

        if {![string match $ruleServer $server]} {
            continue
        }

        lappend options $ruleOption
        switch -- $ruleVarArgsToConsume {
            0 { set argToExecute {lappend @VAR@ $arg; set argsArray($arg) true} }
            1 { set argToExecute {set argValue [lindex $args [incr 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]
    }
    set options [join $options {, }]
    lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
    lappend argSwitchBody default break

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

    set argc [llength $args]
    set sopts {}
    set iopts [concat [list -server $server] $defaults]	;# Import options
    set iopts [list -server $server]

    array set argsArray [list]
    for {set idx 0} {$idx < $argc} {incr idx} {
	set arg [lindex $args $idx]
	switch -glob -- $server,$arg {
	switch -glob -- $server,$arg $argSwitchBody
	    0,-async	{lappend sopts $arg}
	    0,-myport	-
	    *,-type	-
	    *,-myaddr	{lappend sopts $arg [lindex $args [incr idx]]}
	    *,-cadir	-
	    *,-cafile	-
	    *,-certfile	-
	    *,-cipher	-
	    *,-command	-
	    *,-dhparams -
	    *,-keyfile	-
	    *,-password	-
	    *,-request	-
	    *,-require	-
            *,-servername -
	    *,-ssl2	-
	    *,-ssl3	-
	    *,-tls1	-
	    *,-tls1.1	-
	    *,-tls1.2	{lappend iopts $arg [lindex $args [incr idx]]}
	    -*		{return -code error "bad option \"$arg\": must be one of $options"}
	    default	{break}
	}
    }
    }

    if {$server} {
	if {($idx + 1) != $argc} {
	    return -code error $usage
	}
	set uid [incr ::tls::srvuid]

	set port [lindex $args [expr {$argc-1}]]
	lappend sopts $port
	#set sopts [linsert $sopts 0 -server $callback]
	set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
	#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
    } else {
	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
            }
        }

	lappend sopts $host $port
    }
    #
    # Create TCP/IP socket
    #
    set chan [eval $socketCmd $sopts]
    if {!$server && [catch {
︙

Powered by Fossil · RSS