TclTLS
Check-in [f0c5ec5595]
Login
HomeTimelineDownloadBrowse SourceBranchesTagsTicketsWiki
Overview
Comment:Started work on adding an "-autoservername" option to tls::socket which will automatically add the -servername <host> option
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | feature-0d4541b86d-autoservername
Files: files | file ages | folders
SHA1: f0c5ec5595811a56c50910d1c1c3ef865ca8bb56
User & Date: rkeene on 2016-12-14 06:18:05
Other Links: branch diff | manifest | tags
Context
2016-12-14
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
Changes
Side-by-Side Diff Ignore Whitespace Patch
Modified tls.htm from [4c4e8f1d42] to [0a4ae067eb].
︙
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>
︙
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