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
}
|