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: |
f0c5ec5595811a56c50910d1c1c3ef86 |
| 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
Modified tls.htm from [4c4e8f1d42] to [0a4ae067eb].
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
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>
<dt> </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> </dt>
|
| > > > > > > > |
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 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> </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> </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
...
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
variable socketCmd
variable defaults
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"
}
set argc [llength $args]
set sopts {}
set iopts [concat [list -server $server] $defaults] ;# Import options
for {set idx 0} {$idx < $argc} {incr idx} {
set arg [lindex $args $idx]
switch -glob -- $server,$arg {
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}]]
................................................................................
#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}]]
lappend sopts $host $port
}
#
# Create TCP/IP socket
#
set chan [eval $socketCmd $sopts]
if {!$server && [catch {
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
>
>
>
>
>
>
>
>
>
>
|
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
...
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\""
} else {
set server 0
set usage "wrong # args: should be \"tls::socket ?options? host port\""
}
# 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 @[email protected] $arg; set argsArray($arg) true} }
1 { set argToExecute {set argValue [lindex $args [incr idx]]; lappend @[email protected] $arg $argValue; set argsArray($arg) $argValue} }
default { return -code error "Internal argument construction error" }
}
lappend argSwitchBody $ruleServer,$ruleOption [string map [list @[email protected] $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 [list -server $server]
array set argsArray [list]
for {set idx 0} {$idx < $argc} {incr idx} {
set arg [lindex $args $idx]
switch -glob -- $server,$arg $argSwitchBody
}
if {$server} {
if {($idx + 1) != $argc} {
return -code error $usage
}
set uid [incr ::tls::srvuid]
set port [lindex $args [expr {$argc-1}]]
................................................................................
#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 {
|