Check-in [f0c5ec5595]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

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 2016-12-14 06:18:05
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

Changes to tls.htm.

    99     99           host port</em></a></dt>
   100    100       <dt><b>tls::socket</b><em> ?-server command? ?options? port</em></dt>
   101    101       <dd>This is a helper function that utilizes the underlying
   102    102           commands (<strong>tls::import</strong>). It behaves
   103    103           exactly the same as the native Tcl <strong>socket</strong>
   104    104           command except that the options can include any of the
   105    105           applicable <a href="#tls::import"><strong>tls:import</strong></a>
   106         -        options.</dd>
          106  +        options with one additional option:
          107  +<blockquote>
          108  +    <dl>
          109  +        <dt><strong>-autoservername</strong> <em>bool</em></dt>
          110  +        <dd>Automatically send the -servername as the <em>host</em> argument
          111  +            (<strong>default</strong>: <em>false</em>)</dd>
          112  +    </dl>
          113  +</blockquote>
   107    114       <dt>&nbsp;</dt>
   108    115       <dt><a name="tls::handshake"><strong>tls::handshake</strong> <em>channel</em></a></dt>
   109    116       <dd>Forces handshake to take place, and returns 0 if
   110    117           handshake is still in progress (non-blocking), or 1 if
   111    118           the handshake was successful. If the handshake failed
   112    119           this routine will throw an error.</dd>
   113    120       <dt>&nbsp;</dt>

Changes to tls.tcl.

    58     58   }
    59     59   #
    60     60   # Helper function - behaves exactly as the native socket command.
    61     61   #
    62     62   proc tls::socket {args} {
    63     63       variable socketCmd
    64     64       variable defaults
           65  +
           66  +    # server,option,variable,args
           67  +    set usageRules {
           68  +        {0 -async sopts 0}
           69  +        {* -myaddr sopts 1}
           70  +        {0 -myport sopts 1}
           71  +        {* -type sopts 1}
           72  +        {* -cadir iopts 1}
           73  +        {* -cafile iopts 1}
           74  +        {* -certfile iopts 1}
           75  +        {* -cipher iopts 1}
           76  +        {* -command iopts 1}
           77  +        {* -dhparams iopts 1}
           78  +        {* -keyfile iopts 1}
           79  +        {* -password iopts 1}
           80  +        {* -request iopts 1}
           81  +        {* -require iopts 1}
           82  +        {0 -autoservername discardOpts 1}
           83  +        {* -servername iopts 1}
           84  +        {* -ssl2 iopts 1}
           85  +        {* -ssl3 iopts 1}
           86  +        {* -tls1 iopts 1}
           87  +        {* -tls1.1 iopts 1}
           88  +        {* -tls1.2 iopts 1}
           89  +    }
           90  +
    65     91       set idx [lsearch $args -server]
    66     92       if {$idx != -1} {
    67     93   	set server 1
    68     94   	set callback [lindex $args [expr {$idx+1}]]
    69     95   	set args [lreplace $args $idx [expr {$idx+1}]]
    70     96   
    71     97   	set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
    72         -	set options "-cadir, -cafile, -certfile, -cipher, -command, -dhparams, -keyfile, -myaddr, -password, -request, -require, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2"
    73     98       } else {
    74     99   	set server 0
    75    100   
    76    101   	set usage "wrong # args: should be \"tls::socket ?options? host port\""
    77         -	set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -dhparams, -keyfile, -myaddr, -myport, -password, -request, -require, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2"
          102  +    }
          103  +
          104  +    # Create several structures from our list of options
          105  +    ## 1. options: a text representation of the valid options for the current
          106  +    ##             server type
          107  +    ## 2. argSwitchBody: Switch body for processing arguments
          108  +    set options [list]
          109  +    set argSwitchBody [list]
          110  +    foreach usageRule $usageRules {
          111  +        set ruleServer [lindex $usageRule 0]
          112  +        set ruleOption [lindex $usageRule 1]
          113  +        set ruleVarToUpdate [lindex $usageRule 2]
          114  +        set ruleVarArgsToConsume [lindex $usageRule 3]
          115  +
          116  +        if {![string match $ruleServer $server]} {
          117  +            continue
          118  +        }
          119  +
          120  +        lappend options $ruleOption
          121  +        switch -- $ruleVarArgsToConsume {
          122  +            0 { set argToExecute {lappend @VAR@ $arg; set argsArray($arg) true} }
          123  +            1 { set argToExecute {set argValue [lindex $args [incr idx]]; lappend @VAR@ $arg $argValue; set argsArray($arg) $argValue} }
          124  +            default { return -code error "Internal argument construction error" }
          125  +        }
          126  +        lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
    78    127       }
          128  +    set options [join $options {, }]
          129  +    lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
          130  +    lappend argSwitchBody default break
          131  +
          132  +    # Combine defaults with current options
          133  +    set args [concat $defaults $args]
          134  +
    79    135       set argc [llength $args]
    80    136       set sopts {}
    81         -    set iopts [concat [list -server $server] $defaults]	;# Import options
          137  +    set iopts [list -server $server]
    82    138   
          139  +    array set argsArray [list]
    83    140       for {set idx 0} {$idx < $argc} {incr idx} {
    84    141   	set arg [lindex $args $idx]
    85         -	switch -glob -- $server,$arg {
    86         -	    0,-async	{lappend sopts $arg}
    87         -	    0,-myport	-
    88         -	    *,-type	-
    89         -	    *,-myaddr	{lappend sopts $arg [lindex $args [incr idx]]}
    90         -	    *,-cadir	-
    91         -	    *,-cafile	-
    92         -	    *,-certfile	-
    93         -	    *,-cipher	-
    94         -	    *,-command	-
    95         -	    *,-dhparams -
    96         -	    *,-keyfile	-
    97         -	    *,-password	-
    98         -	    *,-request	-
    99         -	    *,-require	-
   100         -            *,-servername -
   101         -	    *,-ssl2	-
   102         -	    *,-ssl3	-
   103         -	    *,-tls1	-
   104         -	    *,-tls1.1	-
   105         -	    *,-tls1.2	{lappend iopts $arg [lindex $args [incr idx]]}
   106         -	    -*		{return -code error "bad option \"$arg\": must be one of $options"}
   107         -	    default	{break}
   108         -	}
          142  +	switch -glob -- $server,$arg $argSwitchBody
   109    143       }
          144  +
   110    145       if {$server} {
   111    146   	if {($idx + 1) != $argc} {
   112    147   	    return -code error $usage
   113    148   	}
   114    149   	set uid [incr ::tls::srvuid]
   115    150   
   116    151   	set port [lindex $args [expr {$argc-1}]]
................................................................................
   118    153   	#set sopts [linsert $sopts 0 -server $callback]
   119    154   	set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
   120    155   	#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
   121    156       } else {
   122    157   	if {($idx + 2) != $argc} {
   123    158   	    return -code error $usage
   124    159   	}
          160  +
   125    161   	set host [lindex $args [expr {$argc-2}]]
   126    162   	set port [lindex $args [expr {$argc-1}]]
          163  +
          164  +        # If an "-autoservername" option is found, honor it
          165  +        if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
          166  +            if {![info exists argsArray(-servername)]} {
          167  +                set argsArray(-servername) $host
          168  +                lappend iopts -servername $host
          169  +            }
          170  +        }
          171  +
   127    172   	lappend sopts $host $port
   128    173       }
   129    174       #
   130    175       # Create TCP/IP socket
   131    176       #
   132    177       set chan [eval $socketCmd $sopts]
   133    178       if {!$server && [catch {