Diff

Differences From Artifact [806ff9312a]:

To Artifact [48423522ec]:




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
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


#
# Copyright (C) 1997-2000 Matt Newman <[email protected]>
#
namespace eval tls {
    variable logcmd tclLog
    variable debug 0

    # Default flags passed to tls::import
    variable defaults {}

    # Maps UID to Server Socket
    variable srvmap
    variable srvuid 0

    # Over-ride this if you are using a different socket command
    variable socketCmd
    if {![info exists socketCmd]} {
        set socketCmd [info command ::socket]
    }

    # This is the possible arguments to tls::socket and tls::init
    # The format of this is a list of lists
    ## Each inner list contains the following elements
    ### Server (matched against "string match" for 0/1)
    ### Option name
    ### Variable to add the option to:
    #### sopts: [socket] option
    #### iopts: [tls::import] option
    ### How many arguments the following the option to consume
    variable socketOptionRules {
        {0 -async sopts 0}
        {* -myaddr sopts 1}
        {0 -myport sopts 1}
        {* -type sopts 1}
        {* -alpn iopts 1}
        {* -cadir iopts 1}
        {* -cafile iopts 1}

        {* -cert iopts 1}
        {* -certfile iopts 1}
        {* -cipher iopts 1}
        {* -ciphersuites iopts 1}
        {* -command iopts 1}
        {* -dhparams iopts 1}
        {* -key iopts 1}
        {* -keyfile iopts 1}
        {* -password iopts 1}
        {* -post_handshake iopts 1}
        {* -request iopts 1}
        {* -require iopts 1}
        {* -securitylevel iopts 1}
        {* -autoservername discardOpts 1}
        {* -server iopts 1}
        {* -servername iopts 1}
        {* -session_id iopts 1}
        {* -ssl2 iopts 1}
        {* -ssl3 iopts 1}
        {* -tls1 iopts 1}
        {* -tls1.1 iopts 1}
        {* -tls1.2 iopts 1}
        {* -tls1.3 iopts 1}
        {* -validatecommand iopts 1}
        {* -vcmd iopts 1}
    }

    # tls::socket and tls::init options as a humane readable string
    variable socketOptionsNoServer
    variable socketOptionsServer

    # Internal [switch] body to validate options
    variable socketOptionsSwitchBody
}

proc tls::_initsocketoptions {} {
    variable socketOptionRules
    variable socketOptionsNoServer
    variable socketOptionsServer
    variable socketOptionsSwitchBody

    # Do not re-run if we have already been initialized
    if {[info exists socketOptionsSwitchBody]} {
        return
    }

    # 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(0) [list]
    set options(1) [list]
    set argSwitchBody [list]
    foreach optionRule $socketOptionRules {
        set ruleServer [lindex $optionRule 0]
        set ruleOption [lindex $optionRule 1]
        set ruleVarToUpdate [lindex $optionRule 2]
        set ruleVarArgsToConsume [lindex $optionRule 3]

        foreach server [list 0 1] {
            if {![string match $ruleServer $server]} {
                continue
            }

            lappend options($server) $ruleOption
        }

        switch -- $ruleVarArgsToConsume {
            0 {
                set argToExecute {
                    lappend @VAR@ $arg
                    set argsArray($arg) true
                }
            }
            1 {
                set argToExecute {
                    incr idx
                    if {$idx >= [llength $args]} {
                        return -code error "\"$arg\" option must be followed by value"
                    }
                    set argValue [lindex $args $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]
    }

    # Add in the final options
    lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
    lappend argSwitchBody default break

    # Set the final variables
>
>

















|












|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


















|










|
|
|
|

|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
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
#
# Support functions for the TLS extension
#
# Copyright (C) 1997-2000 Matt Newman <[email protected]>
#
namespace eval tls {
    variable logcmd tclLog
    variable debug 0

    # Default flags passed to tls::import
    variable defaults {}

    # Maps UID to Server Socket
    variable srvmap
    variable srvuid 0

    # Over-ride this if you are using a different socket command
    variable socketCmd
    if {![info exists socketCmd]} {
	set socketCmd [info command ::socket]
    }

    # This is the possible arguments to tls::socket and tls::init
    # The format of this is a list of lists
    ## Each inner list contains the following elements
    ### Server (matched against "string match" for 0/1)
    ### Option name
    ### Variable to add the option to:
    #### sopts: [socket] option
    #### iopts: [tls::import] option
    ### How many arguments the following the option to consume
    variable socketOptionRules {
	{0 -async sopts 0}
	{* -myaddr sopts 1}
	{0 -myport sopts 1}
	{* -type sopts 1}
	{* -alpn iopts 1}
	{* -cadir iopts 1}
	{* -cafile iopts 1}
	{* -castore iopts 1}
	{* -cert iopts 1}
	{* -certfile iopts 1}
	{* -cipher iopts 1}
	{* -ciphersuites iopts 1}
	{* -command iopts 1}
	{* -dhparams iopts 1}
	{* -key iopts 1}
	{* -keyfile iopts 1}
	{* -password iopts 1}
	{* -post_handshake iopts 1}
	{* -request iopts 1}
	{* -require iopts 1}
	{* -securitylevel iopts 1}
	{* -autoservername discardOpts 1}
	{* -server iopts 1}
	{* -servername iopts 1}
	{* -session_id iopts 1}
	{* -ssl2 iopts 1}
	{* -ssl3 iopts 1}
	{* -tls1 iopts 1}
	{* -tls1.1 iopts 1}
	{* -tls1.2 iopts 1}
	{* -tls1.3 iopts 1}
	{* -validatecommand iopts 1}
	{* -vcmd iopts 1}
    }

    # tls::socket and tls::init options as a humane readable string
    variable socketOptionsNoServer
    variable socketOptionsServer

    # Internal [switch] body to validate options
    variable socketOptionsSwitchBody
}

proc tls::_initsocketoptions {} {
    variable socketOptionRules
    variable socketOptionsNoServer
    variable socketOptionsServer
    variable socketOptionsSwitchBody

    # Do not re-run if we have already been initialized
    if {[info exists socketOptionsSwitchBody]} {
	return
    }

    # 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(0) [list]
    set options(1) [list]
    set argSwitchBody [list]
    foreach optionRule $socketOptionRules {
	set ruleServer [lindex $optionRule 0]
	set ruleOption [lindex $optionRule 1]
	set ruleVarToUpdate [lindex $optionRule 2]
	set ruleVarArgsToConsume [lindex $optionRule 3]

	foreach server [list 0 1] {
	    if {![string match $ruleServer $server]} {
		continue
	    }

	    lappend options($server) $ruleOption
	}

	switch -- $ruleVarArgsToConsume {
	    0 {
		set argToExecute {
		    lappend @VAR@ $arg
		    set argsArray($arg) true
		}
	    }
	    1 {
		set argToExecute {
		    incr idx
		    if {$idx >= [llength $args]} {
			return -code error "\"$arg\" option must be followed by value"
		    }
		    set argValue [lindex $args $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]
    }

    # Add in the final options
    lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
    lappend argSwitchBody default break

    # Set the final variables
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
    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 $socketOptionsServer
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
        set options $socketOptionsNoServer
    }

    # Combine defaults with current options
    set args [concat $defaults $args]

    set argc [llength $args]
    set sopts {}







|




|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
    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 $socketOptionsServer
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
	set options $socketOptionsNoServer
    }

    # Combine defaults with current options
    set args [concat $defaults $args]

    set argc [llength $args]
    set sopts {}
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
	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]







|
|
|
|
|
|
|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
	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]
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358




359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432



433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
	error $err $::errorInfo $::errorCode
    } else {
	log 2 "tls::_accept - called \"$callback\" succeeded"
    }
}

#
# Sample callback for hooking: -
#
# error
# verify
# info
#
proc tls::callback {option args} {
    variable debug

    #log 2 [concat $option $args]

    switch -- $option {
	"error" {
	    foreach {chan msg} $args break

	    log 0 "TLS/$chan: error: $msg"
	}
	"info" {
	    # poor man's lassign
	    foreach {chan major minor msg type} $args break

	    if {$msg != ""} {
		append state ": $msg"
	    }
	    # For tracing
	    upvar #0 tls::$chan cb
	    set cb($major) $minor

	    log 2 "TLS/$chan: $major/$minor: $state"
	}
	"message" {
	    # poor man's lassign
	    foreach {chan direction version content_type msg} $args break

	    log 0 "TLS/$chan: info: $direction $msg"
	}
	"session" {
	    foreach {chan session_id ticket lifetime} $args break

	    log 0 "TLS/$chan: session: lifetime $lifetime"
	}




	default	{
	    return -code error "bad option \"$option\":\
		    must be one of error, info, or session"
	}
    }
}

#
# Sample callback when return value is needed
#
proc tls::validate_command {option args} {
    variable debug

    #log 2 [concat $option $args]

    switch -- $option {
	"alpn" {
	    foreach {chan protocol match} $args break

	    log 0 "TLS/$chan: alpn: $protocol $match"
	}
	"hello" {
	    foreach {chan servername} $args break

	    log 0 "TLS/$chan: hello: $servername"
	}
	"sni" {
	    foreach {chan servername} $args break

	    log 0 "TLS/$chan: sni: $servername"
	}
	"verify" {
	    # poor man's lassign
	    foreach {chan depth cert rc err} $args break

	    array set c $cert

	    if {$rc != "1"} {
		log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
	    } else {
		log 2 "TLS/$chan: verify/$depth: $c(subject)"
	    }
	    if {$debug > 0} {
		return 1;	# FORCE OK
	    } else {
		return $rc
	    }
	}
	default	{
	    return -code error "bad option \"$option\":\
		    must be one of alpn, info, or verify"
	}
    }
    return 1
}

proc tls::xhandshake {chan} {
    upvar #0 tls::$chan cb

    if {[info exists cb(handshake)] && \
	$cb(handshake) == "done"} {
	return 1
    }
    while {1} {
	vwait tls::${chan}(handshake)
	if {![info exists cb(handshake)]} {
	    return 0
	}
	if {$cb(handshake) == "done"} {
	    return 1
	}
    }
}




proc tls::password {rwflag size} {
    log 0 "TLS/Password: did you forget to set your passwd!"
    # Return the worlds best kept secret password.
    return "secret"
}

proc tls::log {level msg} {
    variable debug
    variable logcmd

    if {$level > $debug || $logcmd == ""} {
	return
    }
    set cmd $logcmd
    lappend cmd $msg
    uplevel #0 $cmd
}








|

<
<
<
<
|

<
<



|




|
|

|









<
|




|



>
>
>
>


|





|

|


<
<


|




|




|




<
|



|












|









|













>
>
>
|









|







314
315
316
317
318
319
320
321
322




323
324


325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371


372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388

389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
	error $err $::errorInfo $::errorCode
    } else {
	log 2 "tls::_accept - called \"$callback\" succeeded"
    }
}

#
# Sample callback for status data from OpenSSL
#




proc tls::callback {option chan args} {
    variable debug



    switch -- $option {
	"error" {
	    lassign $args msg

	    log 0 "TLS/$chan: error: $msg"
	}
	"info" {
	    set type ""
	    lassign $args major minor msg type

	    if {$msg ne ""} {
		append state ": $msg"
	    }
	    # For tracing
	    upvar #0 tls::$chan cb
	    set cb($major) $minor

	    log 2 "TLS/$chan: $major/$minor: $state"
	}
	"message" {

	    lassign $args direction version content_type msg

	    log 0 "TLS/$chan: info: $direction $msg"
	}
	"session" {
	    lassign $args session_id ticket lifetime

	    log 0 "TLS/$chan: session: lifetime $lifetime"
	}
	"verify" {
	    # Backwards compatible for v1.7
	    return [tls::validate_command $option $chan {*}$args]
	}
	default	{
	    return -code error "bad option \"$option\":\
		    must be one of error, info, message, or session"
	}
    }
}

#
# Sample callback when return value is needed. New for TLS 1.8+.
#
proc tls::validate_command {option chan args} {
    variable debug



    switch -- $option {
	"alpn" {
	    lassign $args protocol match

	    log 0 "TLS/$chan: alpn: $protocol $match"
	}
	"hello" {
	   lassign $args servername

	    log 0 "TLS/$chan: hello: $servername"
	}
	"sni" {
	    lassign $args servername

	    log 0 "TLS/$chan: sni: $servername"
	}
	"verify" {

	    lassign $args depth cert rc err

	    array set c $cert

	    if {$rc ne "1"} {
		log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
	    } else {
		log 2 "TLS/$chan: verify/$depth: $c(subject)"
	    }
	    if {$debug > 0} {
		return 1;	# FORCE OK
	    } else {
		return $rc
	    }
	}
	default	{
	    return -code error "bad option \"$option\":\
		    must be one of alpn, hello, sni, or verify"
	}
    }
    return 1
}

proc tls::xhandshake {chan} {
    upvar #0 tls::$chan cb

    if {[info exists cb(handshake)] && \
	$cb(handshake) eq "done"} {
	return 1
    }
    while {1} {
	vwait tls::${chan}(handshake)
	if {![info exists cb(handshake)]} {
	    return 0
	}
	if {$cb(handshake) == "done"} {
	    return 1
	}
    }
}

#
# Sample callback to get password when needed. Args are new for TLS 1.8+.
#
proc tls::password {{option password} {rwflag 0} {size 0}} {
    log 0 "TLS/Password: did you forget to set your passwd!"
    # Return the worlds best kept secret password.
    return "secret"
}

proc tls::log {level msg} {
    variable debug
    variable logcmd

    if {$level > $debug || $logcmd eq ""} {
	return
    }
    set cmd $logcmd
    lappend cmd $msg
    uplevel #0 $cmd
}