Check-in [42735119d8]

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

Overview
Comment:Integrated -autoservername feature (addresses [0d4541b86d])
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:42735119d8c238f7177dfe0c43a675f11b4f7df5
User & Date: rkeene 2016-12-17 15:43:38
Context
2017-04-18
14:29
Updated references to DH parameter bit sizes and ensure error messages are printed if generating fails entirely check-in: 83b1dea4d4 user: rkeene tags: trunk
2016-12-17
15:44
Merged in changes from trunk check-in: 04c303f1f5 user: rkeene tags: tls-1-7
15:43
Integrated -autoservername feature (addresses [0d4541b86d]) check-in: 42735119d8 user: rkeene tags: trunk
2016-12-14
16:08
Updated test suite with new error message results Closed-Leaf check-in: 8863101cbe user: rkeene tags: feature-0d4541b86d-autoservername
14:45
Made trunk builds identify as TclTLS 1.8.0 check-in: f625a3272a user: rkeene tags: trunk
Changes

Changes to tests/tlsIO.test.

   258    258   
   259    259   test tlsIO-1.2 {arg parsing for socket command} {socket} {
   260    260       list [catch {tls::socket -server foo} msg] $msg
   261    261   } {1 {wrong # args: should be "tls::socket -server command ?options? port"}}
   262    262   
   263    263   test tlsIO-1.3 {arg parsing for socket command} {socket} {
   264    264       list [catch {tls::socket -myaddr} msg] $msg
   265         -} {1 {wrong # args: should be "tls::socket ?options? host port"}}
          265  +} {1 {"-myaddr" option must be followed by value}}
   266    266   
   267    267   test tlsIO-1.4 {arg parsing for socket command} {socket} {
   268    268       list [catch {tls::socket -myaddr 127.0.0.1} msg] $msg
   269    269   } {1 {wrong # args: should be "tls::socket ?options? host port"}}
   270    270   
   271    271   test tlsIO-1.5 {arg parsing for socket command} {socket} {
   272    272       list [catch {tls::socket -myport} msg] $msg
   273         -} {1 {wrong # args: should be "tls::socket ?options? host port"}}
          273  +} {1 {"-myport" option must be followed by value}}
   274    274   
   275    275   test tlsIO-1.6 {arg parsing for socket command} {socket} {
   276    276       list [catch {tls::socket -myport xxxx} msg] $msg
   277    277   } {1 {wrong # args: should be "tls::socket ?options? host port"}}
   278    278   
   279    279   test tlsIO-1.7 {arg parsing for socket command} {socket} {
   280    280       list [catch {tls::socket -myport 2522} msg] $msg
   281    281   } {1 {wrong # args: should be "tls::socket ?options? host port"}}
   282    282   
   283         -test tlsIO-1.8 {arg parsing for socket command} {socket} {
          283  +test tlsIO-1.8 {arg parsing for socket command} -constraints {socket} -body {
   284    284       list [catch {tls::socket -froboz} msg] $msg
   285         -} {1 {wrong # args: should be "tls::socket ?options? host port"}}
          285  +} -match glob -result {1 {bad option "-froboz": must be one of *}}
   286    286   
   287         -test tlsIO-1.9 {arg parsing for socket command} {socket} {
          287  +test tlsIO-1.9 {arg parsing for socket command} -constraints {socket} -body {
   288    288       list [catch {tls::socket -server foo -myport 2521 3333} msg] $msg
   289         -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}}
          289  +} -match glob -result {1 {bad option "-myport": must be one of *}}
   290    290   
   291    291   test tlsIO-1.10 {arg parsing for socket command} {socket} {
   292    292       list [catch {tls::socket host 2528 -junk} msg] $msg
   293    293   } {1 {wrong # args: should be "tls::socket ?options? host port"}}
   294    294   
   295    295   test tlsIO-1.11 {arg parsing for socket command} {socket} {
   296    296       list [catch {tls::socket -server callback 2520 --} msg] $msg

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>
................................................................................
   396    403   <p>This example uses a sample server.pem provided with the TLS release,
   397    404   courtesy of the <strong>OpenSSL</strong> project.</p>
   398    405   
   399    406   <pre><code>
   400    407   package require http
   401    408   package require tls
   402    409   
   403         -http::register https 443 [list ::tls::socket -require 1 -cafile ./server.pem]
          410  +http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
   404    411   
   405         -set tok [http::geturl https://developer.netscape.com/]
          412  +set tok [http::geturl https://www.tcl.tk/]
   406    413   </code></pre>
   407    414   
   408    415   <h3><a name="SPECIAL CONSIDERATIONS">SPECIAL CONSIDERATIONS</a></h3>
   409    416   
   410    417   <p>The capabilities of this package can vary enormously based
   411    418   upon how your OpenSSL library was configured and built. At the
   412    419   most macro-level OpenSSL supports a &quot;no patents&quot; build,

Changes to tls.tcl.

    13     13       variable srvuid 0
    14     14   
    15     15       # Over-ride this if you are using a different socket command
    16     16       variable socketCmd
    17     17       if {![info exists socketCmd]} {
    18     18           set socketCmd [info command ::socket]
    19     19       }
           20  +
           21  +    # This is the possible arguments to tls::socket and tls::init
           22  +    # The format of this is a list of lists
           23  +    ## Each inner list contains the following elements
           24  +    ### Server (matched against "string match" for 0/1)
           25  +    ### Option name
           26  +    ### Variable to add the option to:
           27  +    #### sopts: [socket] option
           28  +    #### iopts: [tls::import] option
           29  +    ### How many arguments the following the option to consume
           30  +    variable socketOptionRules {
           31  +        {0 -async sopts 0}
           32  +        {* -myaddr sopts 1}
           33  +        {0 -myport sopts 1}
           34  +        {* -type sopts 1}
           35  +        {* -cadir iopts 1}
           36  +        {* -cafile iopts 1}
           37  +        {* -certfile iopts 1}
           38  +        {* -cipher iopts 1}
           39  +        {* -command iopts 1}
           40  +        {* -dhparams iopts 1}
           41  +        {* -keyfile iopts 1}
           42  +        {* -password iopts 1}
           43  +        {* -request iopts 1}
           44  +        {* -require iopts 1}
           45  +        {* -autoservername discardOpts 1}
           46  +        {* -servername iopts 1}
           47  +        {* -ssl2 iopts 1}
           48  +        {* -ssl3 iopts 1}
           49  +        {* -tls1 iopts 1}
           50  +        {* -tls1.1 iopts 1}
           51  +        {* -tls1.2 iopts 1}
           52  +    }
           53  +
           54  +    # tls::socket and tls::init options as a humane readable string
           55  +    variable socketOptionsNoServer
           56  +    variable socketOptionsServer
           57  +
           58  +    # Internal [switch] body to validate options
           59  +    variable socketOptionsSwitchBody
           60  +}
           61  +
           62  +proc tls::_initsocketoptions {} {
           63  +    variable socketOptionRules
           64  +    variable socketOptionsNoServer
           65  +    variable socketOptionsServer
           66  +    variable socketOptionsSwitchBody
           67  +
           68  +    # Do not re-run if we have already been initialized
           69  +    if {[info exists socketOptionsSwitchBody]} {
           70  +        return
           71  +    }
           72  +
           73  +    # Create several structures from our list of options
           74  +    ## 1. options: a text representation of the valid options for the current
           75  +    ##             server type
           76  +    ## 2. argSwitchBody: Switch body for processing arguments
           77  +    set options(0) [list]
           78  +    set options(1) [list]
           79  +    set argSwitchBody [list]
           80  +    foreach optionRule $socketOptionRules {
           81  +        set ruleServer [lindex $optionRule 0]
           82  +        set ruleOption [lindex $optionRule 1]
           83  +        set ruleVarToUpdate [lindex $optionRule 2]
           84  +        set ruleVarArgsToConsume [lindex $optionRule 3]
           85  +
           86  +        foreach server [list 0 1] {
           87  +            if {![string match $ruleServer $server]} {
           88  +                continue
           89  +            }
           90  +
           91  +            lappend options($server) $ruleOption
           92  +        }
           93  +
           94  +        switch -- $ruleVarArgsToConsume {
           95  +            0 {
           96  +                set argToExecute {
           97  +                    lappend @VAR@ $arg
           98  +                    set argsArray($arg) true
           99  +                } 
          100  +            }
          101  +            1 {
          102  +                set argToExecute {
          103  +                    incr idx
          104  +                    if {$idx >= [llength $args]} {
          105  +                        return -code error "\"$arg\" option must be followed by value"
          106  +                    }
          107  +                    set argValue [lindex $args $idx]
          108  +                    lappend @VAR@ $arg $argValue
          109  +                    set argsArray($arg) $argValue
          110  +                }
          111  +            }
          112  +            default {
          113  +                return -code error "Internal argument construction error"
          114  +            }
          115  +        }
          116  +
          117  +        lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
          118  +    }
          119  +
          120  +    # Add in the final options
          121  +    lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
          122  +    lappend argSwitchBody default break
          123  +
          124  +    # Set the final variables
          125  +    set socketOptionsNoServer   [join $options(0) {, }]
          126  +    set socketOptionsServer     [join $options(1) {, }]
          127  +    set socketOptionsSwitchBody $argSwitchBody
    20    128   }
    21    129   
    22    130   proc tls::initlib {dir dll} {
    23    131       # Package index cd's into the package directory for loading.
    24    132       # Irrelevant to unixoids, but for Windows this enables the OS to find
    25    133       # the dependent DLL's in the CWD, where they may be.
    26    134       set cwd [pwd]
................................................................................
    42    150       catch {cd $cwd}
    43    151       if {$res} {
    44    152   	namespace eval [namespace parent] {namespace delete tls}
    45    153   	return -code $res $err
    46    154       }
    47    155       rename tls::initlib {}
    48    156   }
          157  +
    49    158   
    50    159   #
    51    160   # Backwards compatibility, also used to set the default
    52    161   # context options
    53    162   #
    54    163   proc tls::init {args} {
    55    164       variable defaults
          165  +    variable socketOptionsNoServer
          166  +    variable socketOptionsServer
          167  +    variable socketOptionsSwitchBody
    56    168   
    57         -    set defaults $args
          169  +    tls::_initsocketoptions
          170  +
          171  +    # Technically a third option should be used here: Options that are valid
          172  +    # only a both servers and non-servers
          173  +    set server -1
          174  +    set options $socketOptionsServer
          175  +
          176  +    # Validate arguments passed
          177  +    set initialArgs $args
          178  +    set argc [llength $args]
          179  +
          180  +    array set argsArray [list]
          181  +    for {set idx 0} {$idx < $argc} {incr idx} {
          182  +	set arg [lindex $args $idx]
          183  +	switch -glob -- $server,$arg $socketOptionsSwitchBody
          184  +    }
          185  +
          186  +    set defaults $initialArgs
    58    187   }
    59    188   #
    60    189   # Helper function - behaves exactly as the native socket command.
    61    190   #
    62    191   proc tls::socket {args} {
    63    192       variable socketCmd
    64    193       variable defaults
          194  +    variable socketOptionsNoServer
          195  +    variable socketOptionsServer
          196  +    variable socketOptionsSwitchBody
          197  +
          198  +    tls::_initsocketoptions
          199  +
    65    200       set idx [lsearch $args -server]
    66    201       if {$idx != -1} {
    67    202   	set server 1
    68    203   	set callback [lindex $args [expr {$idx+1}]]
    69    204   	set args [lreplace $args $idx [expr {$idx+1}]]
    70    205   
    71    206   	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"
          207  +        set options $socketOptionsServer
    73    208       } else {
    74    209   	set server 0
    75    210   
    76    211   	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"
          212  +        set options $socketOptionsNoServer
    78    213       }
          214  +
          215  +    # Combine defaults with current options
          216  +    set args [concat $defaults $args]
          217  +
    79    218       set argc [llength $args]
    80    219       set sopts {}
    81         -    set iopts [concat [list -server $server] $defaults]	;# Import options
          220  +    set iopts [list -server $server]
    82    221   
          222  +    array set argsArray [list]
    83    223       for {set idx 0} {$idx < $argc} {incr idx} {
    84    224   	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         -	}
          225  +	switch -glob -- $server,$arg $socketOptionsSwitchBody
   109    226       }
          227  +
   110    228       if {$server} {
   111    229   	if {($idx + 1) != $argc} {
   112    230   	    return -code error $usage
   113    231   	}
   114    232   	set uid [incr ::tls::srvuid]
   115    233   
   116    234   	set port [lindex $args [expr {$argc-1}]]
................................................................................
   118    236   	#set sopts [linsert $sopts 0 -server $callback]
   119    237   	set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
   120    238   	#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
   121    239       } else {
   122    240   	if {($idx + 2) != $argc} {
   123    241   	    return -code error $usage
   124    242   	}
          243  +
   125    244   	set host [lindex $args [expr {$argc-2}]]
   126    245   	set port [lindex $args [expr {$argc-1}]]
          246  +
          247  +        # If an "-autoservername" option is found, honor it
          248  +        if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
          249  +            if {![info exists argsArray(-servername)]} {
          250  +                set argsArray(-servername) $host
          251  +                lappend iopts -servername $host
          252  +            }
          253  +        }
          254  +
   127    255   	lappend sopts $host $port
   128    256       }
   129    257       #
   130    258       # Create TCP/IP socket
   131    259       #
   132    260       set chan [eval $socketCmd $sopts]
   133    261       if {!$server && [catch {