Index: tls.htm ================================================================== --- tls.htm +++ tls.htm @@ -101,11 +101,18 @@
This is a helper function that utilizes the underlying commands (tls::import). It behaves exactly the same as the native Tcl socket command except that the options can include any of the applicable tls:import - options.
+ options with one additional option: +
+
+
-autoservername bool
+
Automatically send the -servername as the host argument + (default: false)
+
+
 
tls::handshake channel
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 @@ -398,13 +405,13 @@

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

SPECIAL CONSIDERATIONS

The capabilities of this package can vary enormously based Index: tls.tcl ================================================================== --- tls.tcl +++ tls.tcl @@ -60,55 +60,90 @@ # 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 { - 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} - } - } + switch -glob -- $server,$arg $argSwitchBody + } + if {$server} { if {($idx + 1) != $argc} { return -code error $usage } set uid [incr ::tls::srvuid] @@ -120,12 +155,22 @@ #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 #