Artifact
ee125cf7398c4c4e1d235d53ccc7ad7fac54f031
File
tls.tcl
— part of check-in
[977988aed6]
at
2000-07-21 05:32:56
on branch tls-1-3-io-rewrite
— * tests/tlsIO.test: corrected various tests to be correct for TLS
stacked channels (as opposed to the standard sockets the test
suite was adopted from). Key differences are that TLS cannot
operate in one process without all channels being non-blocking, or
the handshake will block, and handshaking must be forced in some
cases. Also, handshakes don't seem to complete unless the client
has placed at least one byte for the server to read in the channel.
* tests/remote.tcl: corrected the finding of tests certificates
* tlsIO.c (TlsCloseProc): removed deleting of timer handler as
that is handled by Tls_Clean.
* tls.tcl (tls::_accept): corrected the internal _accept to
trickle callback errors to the user.
* Makefile.in: made the install-binaries target regenerate the
pkgIndex.tcl correctly. The test target probably shouldn't screw
it up, but this is to be on the safe side.
(user:
hobbs ,
size: 5267)
[annotate]
[blame]
[check-ins using]
0000: 23 0a 23 20 43 6f 70 79 72 69 67 68 74 20 28 43 #.# Copyright (C
0010: 29 20 31 39 39 37 2d 32 30 30 30 20 4d 61 74 74 ) 1997-2000 Matt
0020: 20 4e 65 77 6d 61 6e 20 3c 6d 61 74 74 40 6e 6f Newman <matt@no
0030: 76 61 64 69 67 6d 2e 63 6f 6d 3e 0a 23 0a 23 20 vadigm.com>.#.#
0040: 24 48 65 61 64 65 72 3a 20 2f 68 6f 6d 65 2f 72 $Header: /home/r
0050: 6b 65 65 6e 65 2f 74 6d 70 2f 63 76 73 32 66 6f keene/tmp/cvs2fo
0060: 73 73 69 6c 2f 2e 2e 2f 74 63 6c 74 6c 73 2f 74 ssil/../tcltls/t
0070: 6c 73 2f 74 6c 73 2f 74 6c 73 2e 74 63 6c 2c 76 ls/tls/tls.tcl,v
0080: 20 31 2e 32 2e 32 2e 31 20 32 30 30 30 2f 30 37 1.2.2.1 2000/07
0090: 2f 32 31 20 30 35 3a 33 32 3a 35 36 20 68 6f 62 /21 05:32:56 hob
00a0: 62 73 20 45 78 70 20 24 0a 23 0a 6e 61 6d 65 73 bs Exp $.#.names
00b0: 70 61 63 65 20 65 76 61 6c 20 74 6c 73 20 7b 0a pace eval tls {.
00c0: 20 20 20 20 76 61 72 69 61 62 6c 65 20 6c 6f 67 variable log
00d0: 63 6d 64 20 74 63 6c 4c 6f 67 0a 20 20 20 20 76 cmd tclLog. v
00e0: 61 72 69 61 62 6c 65 20 64 65 62 75 67 20 30 0a ariable debug 0.
00f0: 20 0a 20 20 20 20 23 20 44 65 66 61 75 6c 74 20 . # Default
0100: 66 6c 61 67 73 20 70 61 73 73 65 64 20 74 6f 20 flags passed to
0110: 74 6c 73 3a 3a 69 6d 70 6f 72 74 0a 20 20 20 20 tls::import.
0120: 76 61 72 69 61 62 6c 65 20 64 65 66 61 75 6c 74 variable default
0130: 73 20 7b 7d 0a 0a 20 20 20 20 23 20 4d 61 70 73 s {}.. # Maps
0140: 20 55 49 44 20 74 6f 20 53 65 72 76 65 72 20 53 UID to Server S
0150: 6f 63 6b 65 74 0a 20 20 20 20 76 61 72 69 61 62 ocket. variab
0160: 6c 65 20 73 72 76 6d 61 70 0a 20 20 20 20 76 61 le srvmap. va
0170: 72 69 61 62 6c 65 20 73 72 76 75 69 64 20 30 0a riable srvuid 0.
0180: 7d 0a 23 0a 23 20 42 61 63 6b 77 61 72 64 73 20 }.#.# Backwards
0190: 63 6f 6d 70 61 74 69 62 69 6c 69 74 79 2c 20 61 compatibility, a
01a0: 6c 73 6f 20 75 73 65 64 20 74 6f 20 73 65 74 20 lso used to set
01b0: 74 68 65 20 64 65 66 61 75 6c 74 0a 23 20 63 6f the default.# co
01c0: 6e 74 65 78 74 20 6f 70 74 69 6f 6e 73 0a 23 0a ntext options.#.
01d0: 70 72 6f 63 20 74 6c 73 3a 3a 69 6e 69 74 20 7b proc tls::init {
01e0: 61 72 67 73 7d 20 7b 0a 20 20 20 20 76 61 72 69 args} {. vari
01f0: 61 62 6c 65 20 64 65 66 61 75 6c 74 73 0a 0a 20 able defaults..
0200: 20 20 20 73 65 74 20 64 65 66 61 75 6c 74 73 20 set defaults
0210: 24 61 72 67 73 0a 7d 0a 23 0a 23 20 48 65 6c 70 $args.}.#.# Help
0220: 65 72 20 66 75 6e 63 74 69 6f 6e 20 2d 20 62 65 er function - be
0230: 68 61 76 65 73 20 65 78 61 63 74 6c 79 20 61 73 haves exactly as
0240: 20 74 68 65 20 6e 61 74 69 76 65 20 73 6f 63 6b the native sock
0250: 65 74 20 63 6f 6d 6d 61 6e 64 2e 0a 23 0a 70 72 et command..#.pr
0260: 6f 63 20 74 6c 73 3a 3a 73 6f 63 6b 65 74 20 7b oc tls::socket {
0270: 61 72 67 73 7d 20 7b 0a 20 20 20 20 73 65 74 20 args} {. set
0280: 69 64 78 20 5b 6c 73 65 61 72 63 68 20 24 61 72 idx [lsearch $ar
0290: 67 73 20 2d 73 65 72 76 65 72 5d 0a 20 20 20 20 gs -server].
02a0: 69 66 20 7b 24 69 64 78 20 21 3d 20 2d 31 7d 20 if {$idx != -1}
02b0: 7b 0a 09 73 65 74 20 73 65 72 76 65 72 20 31 0a {..set server 1.
02c0: 09 73 65 74 20 63 61 6c 6c 62 61 63 6b 20 5b 6c .set callback [l
02d0: 69 6e 64 65 78 20 24 61 72 67 73 20 5b 65 78 70 index $args [exp
02e0: 72 20 7b 24 69 64 78 2b 31 7d 5d 5d 0a 09 73 65 r {$idx+1}]]..se
02f0: 74 20 61 72 67 73 20 5b 6c 72 65 70 6c 61 63 65 t args [lreplace
0300: 20 24 61 72 67 73 20 24 69 64 78 20 5b 65 78 70 $args $idx [exp
0310: 72 20 7b 24 69 64 78 2b 31 7d 5d 5d 0a 0a 09 73 r {$idx+1}]]...s
0320: 65 74 20 75 73 61 67 65 20 22 77 72 6f 6e 67 20 et usage "wrong
0330: 23 20 61 72 67 73 3a 20 73 68 6f 75 6c 64 20 62 # args: should b
0340: 65 20 5c 22 74 6c 73 3a 3a 73 6f 63 6b 65 74 20 e \"tls::socket
0350: 2d 73 65 72 76 65 72 20 63 6f 6d 6d 61 6e 64 20 -server command
0360: 3f 6f 70 74 69 6f 6e 73 3f 20 70 6f 72 74 5c 22 ?options? port\"
0370: 22 0a 09 73 65 74 20 6f 70 74 69 6f 6e 73 20 22 "..set options "
0380: 2d 63 61 64 69 72 2c 20 2d 63 61 66 69 6c 65 2c -cadir, -cafile,
0390: 20 2d 63 65 72 74 66 69 6c 65 2c 20 2d 63 69 70 -certfile, -cip
03a0: 68 65 72 2c 20 2d 6b 65 79 66 69 6c 65 2c 20 2d her, -keyfile, -
03b0: 6d 79 61 64 64 72 2c 20 2d 72 65 71 75 65 73 74 myaddr, -request
03c0: 2c 20 2d 72 65 71 75 69 72 65 2c 20 2d 73 73 6c , -require, -ssl
03d0: 32 2c 20 2d 73 73 6c 33 2c 20 6f 72 20 2d 74 6c 2, -ssl3, or -tl
03e0: 73 31 22 0a 20 20 20 20 7d 20 65 6c 73 65 20 7b s1". } else {
03f0: 0a 09 73 65 74 20 73 65 72 76 65 72 20 30 0a 0a ..set server 0..
0400: 09 73 65 74 20 75 73 61 67 65 20 22 77 72 6f 6e .set usage "wron
0410: 67 20 23 20 61 72 67 73 3a 20 73 68 6f 75 6c 64 g # args: should
0420: 20 62 65 20 5c 22 74 6c 73 3a 3a 73 6f 63 6b 65 be \"tls::socke
0430: 74 20 3f 6f 70 74 69 6f 6e 73 3f 20 68 6f 73 74 t ?options? host
0440: 20 70 6f 72 74 5c 22 22 0a 09 73 65 74 20 6f 70 port\""..set op
0450: 74 69 6f 6e 73 20 22 2d 61 73 79 6e 63 2c 20 2d tions "-async, -
0460: 63 61 64 69 72 2c 20 2d 63 61 66 69 6c 65 2c 20 cadir, -cafile,
0470: 2d 63 65 72 74 66 69 6c 65 2c 20 2d 63 69 70 68 -certfile, -ciph
0480: 65 72 2c 20 2d 6b 65 79 66 69 6c 65 2c 20 2d 6d er, -keyfile, -m
0490: 79 61 64 64 72 2c 20 2d 6d 79 70 6f 72 74 2c 20 yaddr, -myport,
04a0: 2d 72 65 71 75 65 73 74 2c 20 2d 72 65 71 75 69 -request, -requi
04b0: 72 65 2c 20 2d 73 73 6c 32 2c 20 2d 73 73 6c 33 re, -ssl2, -ssl3
04c0: 2c 20 6f 72 20 2d 74 6c 73 31 22 0a 20 20 20 20 , or -tls1".
04d0: 7d 0a 20 20 20 20 73 65 74 20 61 72 67 63 20 5b }. set argc [
04e0: 6c 6c 65 6e 67 74 68 20 24 61 72 67 73 5d 0a 20 llength $args].
04f0: 20 20 20 73 65 74 20 73 6f 70 74 73 20 7b 7d 0a set sopts {}.
0500: 20 20 20 20 73 65 74 20 69 6f 70 74 73 20 5b 63 set iopts [c
0510: 6f 6e 63 61 74 20 5b 6c 69 73 74 20 2d 73 65 72 oncat [list -ser
0520: 76 65 72 20 24 73 65 72 76 65 72 5d 20 24 7b 74 ver $server] ${t
0530: 6c 73 3a 3a 64 65 66 61 75 6c 74 73 7d 5d 09 3b ls::defaults}].;
0540: 23 20 49 6d 70 6f 72 74 20 6f 70 74 69 6f 6e 73 # Import options
0550: 0a 0a 20 20 20 20 66 6f 72 20 7b 73 65 74 20 69 .. for {set i
0560: 64 78 20 30 7d 20 7b 24 69 64 78 20 3c 20 24 61 dx 0} {$idx < $a
0570: 72 67 63 7d 20 7b 69 6e 63 72 20 69 64 78 7d 20 rgc} {incr idx}
0580: 7b 0a 09 73 65 74 20 61 72 67 20 5b 6c 69 6e 64 {..set arg [lind
0590: 65 78 20 24 61 72 67 73 20 24 69 64 78 5d 0a 09 ex $args $idx]..
05a0: 73 77 69 74 63 68 20 2d 67 6c 6f 62 20 2d 2d 20 switch -glob --
05b0: 24 73 65 72 76 65 72 2c 24 61 72 67 20 7b 0a 09 $server,$arg {..
05c0: 20 20 20 20 30 2c 2d 6d 79 70 6f 72 74 09 2d 0a 0,-myport.-.
05d0: 09 20 20 20 20 2a 2c 2d 6d 79 61 64 64 72 09 7b . *,-myaddr.{
05e0: 6c 61 70 70 65 6e 64 20 73 6f 70 74 73 20 24 61 lappend sopts $a
05f0: 72 67 20 5b 6c 69 6e 64 65 78 20 24 61 72 67 73 rg [lindex $args
0600: 20 5b 69 6e 63 72 20 69 64 78 5d 5d 7d 0a 09 20 [incr idx]]}..
0610: 20 20 20 30 2c 2d 61 73 79 6e 63 09 7b 6c 61 70 0,-async.{lap
0620: 70 65 6e 64 20 73 6f 70 74 73 20 24 61 72 67 7d pend sopts $arg}
0630: 0a 09 20 20 20 20 2a 2c 2d 63 69 70 68 65 72 09 .. *,-cipher.
0640: 2d 0a 09 20 20 20 20 2a 2c 2d 63 61 64 69 72 09 -.. *,-cadir.
0650: 2d 0a 09 20 20 20 20 2a 2c 2d 63 61 66 69 6c 65 -.. *,-cafile
0660: 09 2d 0a 09 20 20 20 20 2a 2c 2d 63 65 72 74 66 .-.. *,-certf
0670: 69 6c 65 09 2d 0a 09 20 20 20 20 2a 2c 2d 6b 65 ile.-.. *,-ke
0680: 79 66 69 6c 65 09 2d 0a 09 20 20 20 20 2a 2c 2d yfile.-.. *,-
0690: 63 6f 6d 6d 61 6e 64 09 2d 0a 09 20 20 20 20 2a command.-.. *
06a0: 2c 2d 72 65 71 75 65 73 74 09 2d 0a 09 20 20 20 ,-request.-..
06b0: 20 2a 2c 2d 72 65 71 75 69 72 65 09 2d 0a 09 20 *,-require.-..
06c0: 20 20 20 2a 2c 2d 73 73 6c 32 09 2d 0a 09 20 20 *,-ssl2.-..
06d0: 20 20 2a 2c 2d 73 73 6c 33 09 2d 0a 09 20 20 20 *,-ssl3.-..
06e0: 20 2a 2c 2d 74 6c 73 31 09 7b 6c 61 70 70 65 6e *,-tls1.{lappen
06f0: 64 20 69 6f 70 74 73 20 24 61 72 67 20 5b 6c 69 d iopts $arg [li
0700: 6e 64 65 78 20 24 61 72 67 73 20 5b 69 6e 63 72 ndex $args [incr
0710: 20 69 64 78 5d 5d 7d 0a 09 20 20 20 20 2d 2a 09 idx]]}.. -*.
0720: 09 7b 72 65 74 75 72 6e 20 2d 63 6f 64 65 20 65 .{return -code e
0730: 72 72 6f 72 20 22 62 61 64 20 6f 70 74 69 6f 6e rror "bad option
0740: 20 5c 22 24 61 72 67 5c 22 3a 20 6d 75 73 74 20 \"$arg\": must
0750: 62 65 20 6f 6e 65 20 6f 66 20 24 6f 70 74 69 6f be one of $optio
0760: 6e 73 22 7d 0a 09 20 20 20 20 64 65 66 61 75 6c ns"}.. defaul
0770: 74 09 7b 62 72 65 61 6b 7d 0a 09 7d 0a 20 20 20 t.{break}..}.
0780: 20 7d 0a 20 20 20 20 69 66 20 7b 24 73 65 72 76 }. if {$serv
0790: 65 72 7d 20 7b 0a 09 69 66 20 7b 28 24 69 64 78 er} {..if {($idx
07a0: 20 2b 20 31 29 20 21 3d 20 24 61 72 67 63 7d 20 + 1) != $argc}
07b0: 7b 0a 09 20 20 20 20 72 65 74 75 72 6e 20 2d 63 {.. return -c
07c0: 6f 64 65 20 65 72 72 6f 72 20 24 75 73 61 67 65 ode error $usage
07d0: 0a 09 7d 0a 09 73 65 74 20 75 69 64 20 5b 69 6e ..}..set uid [in
07e0: 63 72 20 3a 3a 74 6c 73 3a 3a 73 72 76 75 69 64 cr ::tls::srvuid
07f0: 5d 0a 0a 09 73 65 74 20 70 6f 72 74 20 5b 6c 69 ]...set port [li
0800: 6e 64 65 78 20 24 61 72 67 73 20 5b 65 78 70 72 ndex $args [expr
0810: 20 7b 24 61 72 67 63 2d 31 7d 5d 5d 0a 09 6c 61 {$argc-1}]]..la
0820: 70 70 65 6e 64 20 73 6f 70 74 73 20 24 70 6f 72 ppend sopts $por
0830: 74 0a 09 23 73 65 74 20 73 6f 70 74 73 20 5b 6c t..#set sopts [l
0840: 69 6e 73 65 72 74 20 24 73 6f 70 74 73 20 30 20 insert $sopts 0
0850: 2d 73 65 72 76 65 72 20 24 63 61 6c 6c 62 61 63 -server $callbac
0860: 6b 5d 0a 09 73 65 74 20 73 6f 70 74 73 20 5b 6c k]..set sopts [l
0870: 69 6e 73 65 72 74 20 24 73 6f 70 74 73 20 30 20 insert $sopts 0
0880: 2d 73 65 72 76 65 72 20 5b 6c 69 73 74 20 74 6c -server [list tl
0890: 73 3a 3a 5f 61 63 63 65 70 74 20 24 69 6f 70 74 s::_accept $iopt
08a0: 73 20 24 63 61 6c 6c 62 61 63 6b 5d 5d 0a 09 23 s $callback]]..#
08b0: 73 65 74 20 73 6f 70 74 73 20 5b 6c 69 6e 73 65 set sopts [linse
08c0: 72 74 20 24 73 6f 70 74 73 20 30 20 2d 73 65 72 rt $sopts 0 -ser
08d0: 76 65 72 20 5b 6c 69 73 74 20 74 6c 73 3a 3a 5f ver [list tls::_
08e0: 61 63 63 65 70 74 20 24 75 69 64 20 24 63 61 6c accept $uid $cal
08f0: 6c 62 61 63 6b 5d 5d 0a 20 20 20 20 7d 20 65 6c lback]]. } el
0900: 73 65 20 7b 0a 09 69 66 20 7b 28 24 69 64 78 20 se {..if {($idx
0910: 2b 20 32 29 20 21 3d 20 24 61 72 67 63 7d 20 7b + 2) != $argc} {
0920: 0a 09 20 20 20 20 72 65 74 75 72 6e 20 2d 63 6f .. return -co
0930: 64 65 20 65 72 72 6f 72 20 24 75 73 61 67 65 0a de error $usage.
0940: 09 7d 0a 09 73 65 74 20 68 6f 73 74 20 5b 6c 69 .}..set host [li
0950: 6e 64 65 78 20 24 61 72 67 73 20 5b 65 78 70 72 ndex $args [expr
0960: 20 7b 24 61 72 67 63 2d 32 7d 5d 5d 0a 09 73 65 {$argc-2}]]..se
0970: 74 20 70 6f 72 74 20 5b 6c 69 6e 64 65 78 20 24 t port [lindex $
0980: 61 72 67 73 20 5b 65 78 70 72 20 7b 24 61 72 67 args [expr {$arg
0990: 63 2d 31 7d 5d 5d 0a 09 6c 61 70 70 65 6e 64 20 c-1}]]..lappend
09a0: 73 6f 70 74 73 20 24 68 6f 73 74 20 24 70 6f 72 sopts $host $por
09b0: 74 0a 20 20 20 20 7d 0a 20 20 20 20 23 0a 20 20 t. }. #.
09c0: 20 20 23 20 43 72 65 61 74 65 20 54 43 50 2f 49 # Create TCP/I
09d0: 50 20 73 6f 63 6b 65 74 0a 20 20 20 20 23 0a 20 P socket. #.
09e0: 20 20 20 73 65 74 20 63 68 61 6e 20 5b 65 76 61 set chan [eva
09f0: 6c 20 3a 3a 73 6f 63 6b 65 74 20 24 73 6f 70 74 l ::socket $sopt
0a00: 73 5d 0a 20 20 20 20 69 66 20 7b 21 24 73 65 72 s]. if {!$ser
0a10: 76 65 72 20 26 26 20 5b 63 61 74 63 68 20 7b 0a ver && [catch {.
0a20: 09 23 0a 09 23 20 50 75 73 68 20 53 53 4c 20 6c .#..# Push SSL l
0a30: 61 79 65 72 20 6f 6e 74 6f 20 73 6f 63 6b 65 74 ayer onto socket
0a40: 0a 09 23 0a 09 65 76 61 6c 20 5b 6c 69 73 74 20 ..#..eval [list
0a50: 74 6c 73 3a 3a 69 6d 70 6f 72 74 5d 20 24 63 68 tls::import] $ch
0a60: 61 6e 20 24 69 6f 70 74 73 0a 20 20 20 20 7d 20 an $iopts. }
0a70: 65 72 72 5d 7d 20 7b 0a 09 73 65 74 20 69 6e 66 err]} {..set inf
0a80: 6f 20 24 7b 3a 3a 65 72 72 6f 72 49 6e 66 6f 7d o ${::errorInfo}
0a90: 0a 09 63 61 74 63 68 20 7b 63 6c 6f 73 65 20 24 ..catch {close $
0aa0: 63 68 61 6e 7d 0a 09 72 65 74 75 72 6e 20 2d 63 chan}..return -c
0ab0: 6f 64 65 20 65 72 72 6f 72 20 2d 65 72 72 6f 72 ode error -error
0ac0: 69 6e 66 6f 20 24 69 6e 66 6f 20 24 65 72 72 0a info $info $err.
0ad0: 20 20 20 20 7d 0a 20 20 20 20 72 65 74 75 72 6e }. return
0ae0: 20 24 63 68 61 6e 0a 7d 0a 0a 23 20 74 6c 73 3a $chan.}..# tls:
0af0: 3a 5f 61 63 63 65 70 74 20 2d 2d 0a 23 0a 23 20 :_accept --.#.#
0b00: 20 20 54 68 69 73 20 69 73 20 74 68 65 20 61 63 This is the ac
0b10: 74 75 61 6c 20 61 63 63 65 70 74 20 74 68 61 74 tual accept that
0b20: 20 54 4c 53 20 73 6f 63 6b 65 74 73 20 75 73 65 TLS sockets use
0b30: 2c 20 77 68 69 63 68 20 74 68 65 6e 20 63 61 6c , which then cal
0b40: 6c 73 0a 23 20 20 20 74 68 65 20 63 61 6c 6c 62 ls.# the callb
0b50: 61 63 6b 20 72 65 67 69 73 74 65 72 65 64 20 62 ack registered b
0b60: 79 20 74 6c 73 3a 3a 73 6f 63 6b 65 74 2e 0a 23 y tls::socket..#
0b70: 0a 23 20 41 72 67 75 6d 65 6e 74 73 3a 0a 23 20 .# Arguments:.#
0b80: 20 20 69 6f 70 74 73 09 74 6c 73 3a 3a 69 6d 70 iopts.tls::imp
0b90: 6f 72 74 20 6f 70 74 73 0a 23 20 20 20 63 61 6c ort opts.# cal
0ba0: 6c 62 61 63 6b 09 73 65 72 76 65 72 20 63 61 6c lback.server cal
0bb0: 6c 62 61 63 6b 20 74 6f 20 69 6e 76 6f 6b 65 0a lback to invoke.
0bc0: 23 20 20 20 63 68 61 6e 09 73 6f 63 6b 65 74 20 # chan.socket
0bd0: 63 68 61 6e 6e 65 6c 20 74 6f 20 61 63 63 65 70 channel to accep
0be0: 74 2f 64 65 6e 79 0a 23 20 20 20 69 70 61 64 64 t/deny.# ipadd
0bf0: 72 09 63 61 6c 6c 69 6e 67 20 49 50 20 61 64 64 r.calling IP add
0c00: 72 65 73 73 0a 23 20 20 20 70 6f 72 74 09 63 61 ress.# port.ca
0c10: 6c 6c 69 6e 67 20 70 6f 72 74 0a 23 0a 23 20 52 lling port.#.# R
0c20: 65 73 75 6c 74 73 3a 0a 23 20 20 20 52 65 74 75 esults:.# Retu
0c30: 72 6e 73 20 61 6e 20 65 72 72 6f 72 20 69 66 20 rns an error if
0c40: 74 68 65 20 63 61 6c 6c 62 61 63 6b 20 74 68 72 the callback thr
0c50: 6f 77 73 20 6f 6e 65 2e 0a 23 0a 70 72 6f 63 20 ows one..#.proc
0c60: 74 6c 73 3a 3a 5f 61 63 63 65 70 74 20 7b 20 69 tls::_accept { i
0c70: 6f 70 74 73 20 63 61 6c 6c 62 61 63 6b 20 63 68 opts callback ch
0c80: 61 6e 20 69 70 61 64 64 72 20 70 6f 72 74 20 7d an ipaddr port }
0c90: 20 7b 0a 20 20 20 20 6c 6f 67 20 32 20 5b 6c 69 {. log 2 [li
0ca0: 73 74 20 74 6c 73 3a 3a 5f 61 63 63 65 70 74 20 st tls::_accept
0cb0: 24 69 6f 70 74 73 20 24 63 61 6c 6c 62 61 63 6b $iopts $callback
0cc0: 20 24 63 68 61 6e 20 24 69 70 61 64 64 72 20 24 $chan $ipaddr $
0cd0: 70 6f 72 74 5d 0a 0a 20 20 20 20 73 65 74 20 63 port].. set c
0ce0: 68 61 6e 20 5b 65 76 61 6c 20 5b 6c 69 73 74 20 han [eval [list
0cf0: 74 6c 73 3a 3a 69 6d 70 6f 72 74 20 24 63 68 61 tls::import $cha
0d00: 6e 5d 20 24 69 6f 70 74 73 5d 0a 0a 20 20 20 20 n] $iopts]..
0d10: 6c 61 70 70 65 6e 64 20 63 61 6c 6c 62 61 63 6b lappend callback
0d20: 20 24 63 68 61 6e 20 24 69 70 61 64 64 72 20 24 $chan $ipaddr $
0d30: 70 6f 72 74 0a 20 20 20 20 69 66 20 7b 5b 63 61 port. if {[ca
0d40: 74 63 68 20 7b 0a 09 75 70 6c 65 76 65 6c 20 23 tch {..uplevel #
0d50: 30 20 24 63 61 6c 6c 62 61 63 6b 0a 20 20 20 20 0 $callback.
0d60: 7d 20 65 72 72 5d 7d 20 7b 0a 09 6c 6f 67 20 31 } err]} {..log 1
0d70: 20 22 74 6c 73 3a 3a 5f 61 63 63 65 70 74 20 65 "tls::_accept e
0d80: 72 72 6f 72 3a 20 24 7b 3a 3a 65 72 72 6f 72 49 rror: ${::errorI
0d90: 6e 66 6f 7d 22 0a 09 63 6c 6f 73 65 20 24 63 68 nfo}"..close $ch
0da0: 61 6e 0a 09 65 72 72 6f 72 20 24 65 72 72 20 24 an..error $err $
0db0: 3a 3a 65 72 72 6f 72 49 6e 66 6f 20 24 3a 3a 65 ::errorInfo $::e
0dc0: 72 72 6f 72 43 6f 64 65 0a 20 20 20 20 7d 20 65 rrorCode. } e
0dd0: 6c 73 65 20 7b 0a 09 6c 6f 67 20 32 20 22 74 6c lse {..log 2 "tl
0de0: 73 3a 3a 5f 61 63 63 65 70 74 20 2d 20 63 61 6c s::_accept - cal
0df0: 6c 65 64 20 5c 22 24 63 61 6c 6c 62 61 63 6b 5c led \"$callback\
0e00: 22 20 73 75 63 63 65 65 64 65 64 22 0a 20 20 20 " succeeded".
0e10: 20 7d 0a 7d 0a 23 0a 23 20 53 61 6d 70 6c 65 20 }.}.#.# Sample
0e20: 63 61 6c 6c 62 61 63 6b 20 66 6f 72 20 68 6f 6f callback for hoo
0e30: 6b 69 6e 67 3a 20 2d 0a 23 0a 23 20 65 72 72 6f king: -.#.# erro
0e40: 72 0a 23 20 69 6e 66 6f 0a 23 20 70 61 73 73 77 r.# info.# passw
0e50: 6f 72 64 0a 23 20 76 65 72 69 66 79 0a 23 0a 70 ord.# verify.#.p
0e60: 72 6f 63 20 74 6c 73 3a 3a 63 61 6c 6c 62 61 63 roc tls::callbac
0e70: 6b 20 7b 6f 70 74 69 6f 6e 20 61 72 67 73 7d 20 k {option args}
0e80: 7b 0a 20 20 20 20 76 61 72 69 61 62 6c 65 20 64 {. variable d
0e90: 65 62 75 67 0a 0a 20 20 20 20 23 6c 6f 67 20 32 ebug.. #log 2
0ea0: 20 5b 63 6f 6e 63 61 74 20 24 6f 70 74 69 6f 6e [concat $option
0eb0: 20 24 61 72 67 73 5d 0a 0a 20 20 20 20 73 77 69 $args].. swi
0ec0: 74 63 68 20 2d 2d 20 24 6f 70 74 69 6f 6e 20 7b tch -- $option {
0ed0: 0a 09 22 65 72 72 6f 72 22 09 7b 0a 09 20 20 20 .."error".{..
0ee0: 20 66 6f 72 65 61 63 68 20 7b 63 68 61 6e 20 6d foreach {chan m
0ef0: 73 67 7d 20 24 61 72 67 73 20 62 72 65 61 6b 0a sg} $args break.
0f00: 0a 09 20 20 20 20 6c 6f 67 20 30 20 22 54 4c 53 .. log 0 "TLS
0f10: 2f 24 63 68 61 6e 3a 20 65 72 72 6f 72 3a 20 24 /$chan: error: $
0f20: 6d 73 67 22 0a 09 7d 0a 09 22 76 65 72 69 66 79 msg"..}.."verify
0f30: 22 09 7b 0a 09 20 20 20 20 23 20 70 6f 6f 72 20 ".{.. # poor
0f40: 6d 61 6e 27 73 20 6c 61 73 73 69 67 6e 0a 09 20 man's lassign..
0f50: 20 20 20 66 6f 72 65 61 63 68 20 7b 63 68 61 6e foreach {chan
0f60: 20 64 65 70 74 68 20 63 65 72 74 20 72 63 20 65 depth cert rc e
0f70: 72 72 7d 20 24 61 72 67 73 20 62 72 65 61 6b 0a rr} $args break.
0f80: 0a 09 20 20 20 20 61 72 72 61 79 20 73 65 74 20 .. array set
0f90: 63 20 24 63 65 72 74 0a 0a 09 20 20 20 20 69 66 c $cert... if
0fa0: 20 7b 24 72 63 20 21 3d 20 22 31 22 7d 20 7b 0a {$rc != "1"} {.
0fb0: 09 09 6c 6f 67 20 31 20 22 54 4c 53 2f 24 63 68 ..log 1 "TLS/$ch
0fc0: 61 6e 3a 20 76 65 72 69 66 79 2f 24 64 65 70 74 an: verify/$dept
0fd0: 68 3a 20 42 61 64 20 43 65 72 74 3a 20 24 65 72 h: Bad Cert: $er
0fe0: 72 20 28 72 63 20 3d 20 24 72 63 29 22 0a 09 20 r (rc = $rc)"..
0ff0: 20 20 20 7d 20 65 6c 73 65 20 7b 0a 09 09 6c 6f } else {...lo
1000: 67 20 32 20 22 54 4c 53 2f 24 63 68 61 6e 3a 20 g 2 "TLS/$chan:
1010: 76 65 72 69 66 79 2f 24 64 65 70 74 68 3a 20 24 verify/$depth: $
1020: 63 28 73 75 62 6a 65 63 74 29 22 0a 09 20 20 20 c(subject)"..
1030: 20 7d 0a 09 20 20 20 20 69 66 20 7b 24 64 65 62 }.. if {$deb
1040: 75 67 20 3e 20 30 7d 20 7b 0a 09 09 72 65 74 75 ug > 0} {...retu
1050: 72 6e 20 31 3b 09 23 20 46 4f 52 43 45 20 4f 4b rn 1;.# FORCE OK
1060: 0a 09 20 20 20 20 7d 20 65 6c 73 65 20 7b 0a 09 .. } else {..
1070: 09 72 65 74 75 72 6e 20 24 72 63 0a 09 20 20 20 .return $rc..
1080: 20 7d 0a 09 7d 0a 09 22 69 6e 66 6f 22 09 7b 0a }..}.."info".{.
1090: 09 20 20 20 20 23 20 70 6f 6f 72 20 6d 61 6e 27 . # poor man'
10a0: 73 20 6c 61 73 73 69 67 6e 0a 09 20 20 20 20 66 s lassign.. f
10b0: 6f 72 65 61 63 68 20 7b 63 68 61 6e 20 6d 61 6a oreach {chan maj
10c0: 6f 72 20 6d 69 6e 6f 72 20 73 74 61 74 65 20 6d or minor state m
10d0: 73 67 7d 20 24 61 72 67 73 20 62 72 65 61 6b 0a sg} $args break.
10e0: 0a 09 20 20 20 20 69 66 20 7b 24 6d 73 67 20 21 .. if {$msg !
10f0: 3d 20 22 22 7d 20 7b 0a 09 09 61 70 70 65 6e 64 = ""} {...append
1100: 20 73 74 61 74 65 20 22 3a 20 24 6d 73 67 22 0a state ": $msg".
1110: 09 20 20 20 20 7d 0a 09 20 20 20 20 23 20 46 6f . }.. # Fo
1120: 72 20 74 72 61 63 69 6e 67 0a 09 20 20 20 20 75 r tracing.. u
1130: 70 76 61 72 20 23 30 20 74 6c 73 3a 3a 24 63 68 pvar #0 tls::$ch
1140: 61 6e 20 63 62 0a 09 20 20 20 20 73 65 74 20 63 an cb.. set c
1150: 62 28 24 6d 61 6a 6f 72 29 20 24 6d 69 6e 6f 72 b($major) $minor
1160: 0a 0a 09 20 20 20 20 6c 6f 67 20 32 20 22 54 4c ... log 2 "TL
1170: 53 2f 24 63 68 61 6e 3a 20 24 6d 61 6a 6f 72 2f S/$chan: $major/
1180: 24 6d 69 6e 6f 72 3a 20 24 73 74 61 74 65 22 0a $minor: $state".
1190: 09 7d 0a 09 64 65 66 61 75 6c 74 09 7b 0a 09 20 .}..default.{..
11a0: 20 20 20 72 65 74 75 72 6e 20 2d 63 6f 64 65 20 return -code
11b0: 65 72 72 6f 72 20 22 62 61 64 20 6f 70 74 69 6f error "bad optio
11c0: 6e 20 5c 22 24 6f 70 74 69 6f 6e 5c 22 3a 5c 0a n \"$option\":\.
11d0: 09 09 20 20 20 20 6d 75 73 74 20 62 65 20 6f 6e .. must be on
11e0: 65 20 6f 66 20 65 72 72 6f 72 2c 20 69 6e 66 6f e of error, info
11f0: 2c 20 6f 72 20 76 65 72 69 66 79 22 0a 09 7d 0a , or verify"..}.
1200: 20 20 20 20 7d 0a 7d 0a 0a 70 72 6f 63 20 74 6c }.}..proc tl
1210: 73 3a 3a 78 68 61 6e 64 73 68 61 6b 65 20 7b 63 s::xhandshake {c
1220: 68 61 6e 7d 20 7b 0a 20 20 20 20 75 70 76 61 72 han} {. upvar
1230: 20 23 30 20 74 6c 73 3a 3a 24 63 68 61 6e 20 63 #0 tls::$chan c
1240: 62 0a 0a 20 20 20 20 69 66 20 7b 5b 69 6e 66 6f b.. if {[info
1250: 20 65 78 69 73 74 73 20 63 62 28 68 61 6e 64 73 exists cb(hands
1260: 68 61 6b 65 29 5d 20 26 26 20 5c 0a 09 24 63 62 hake)] && \..$cb
1270: 28 68 61 6e 64 73 68 61 6b 65 29 20 3d 3d 20 22 (handshake) == "
1280: 64 6f 6e 65 22 7d 20 7b 0a 09 72 65 74 75 72 6e done"} {..return
1290: 20 31 0a 20 20 20 20 7d 0a 20 20 20 20 77 68 69 1. }. whi
12a0: 6c 65 20 7b 31 7d 20 7b 0a 09 76 77 61 69 74 20 le {1} {..vwait
12b0: 74 6c 73 3a 3a 24 7b 63 68 61 6e 7d 28 68 61 6e tls::${chan}(han
12c0: 64 73 68 61 6b 65 29 0a 09 69 66 20 7b 21 5b 69 dshake)..if {![i
12d0: 6e 66 6f 20 65 78 69 73 74 73 20 63 62 28 68 61 nfo exists cb(ha
12e0: 6e 64 73 68 61 6b 65 29 5d 7d 20 7b 0a 09 20 20 ndshake)]} {..
12f0: 20 20 72 65 74 75 72 6e 20 30 0a 09 7d 0a 09 69 return 0..}..i
1300: 66 20 7b 24 63 62 28 68 61 6e 64 73 68 61 6b 65 f {$cb(handshake
1310: 29 20 3d 3d 20 22 64 6f 6e 65 22 7d 20 7b 0a 09 ) == "done"} {..
1320: 20 20 20 20 72 65 74 75 72 6e 20 31 0a 09 7d 0a return 1..}.
1330: 20 20 20 20 7d 0a 7d 0a 70 72 6f 63 20 74 6c 73 }.}.proc tls
1340: 3a 3a 70 61 73 73 77 6f 72 64 20 7b 7d 20 7b 0a ::password {} {.
1350: 20 20 20 20 6c 6f 67 20 30 20 22 54 4c 53 2f 50 log 0 "TLS/P
1360: 61 73 73 77 6f 72 64 3a 20 64 69 64 20 79 6f 75 assword: did you
1370: 20 66 6f 72 67 65 74 20 74 6f 20 73 65 74 20 79 forget to set y
1380: 6f 75 72 20 70 61 73 73 77 64 21 22 0a 20 20 20 our passwd!".
1390: 20 23 20 52 65 74 75 72 6e 20 74 68 65 20 77 6f # Return the wo
13a0: 72 6c 64 73 20 62 65 73 74 20 6b 65 70 74 20 73 rlds best kept s
13b0: 65 63 72 65 74 20 70 61 73 73 77 6f 72 64 2e 0a ecret password..
13c0: 20 20 20 20 72 65 74 75 72 6e 20 22 73 65 63 72 return "secr
13d0: 65 74 22 0a 7d 0a 70 72 6f 63 20 74 6c 73 3a 3a et".}.proc tls::
13e0: 6c 6f 67 20 7b 6c 65 76 65 6c 20 6d 73 67 7d 20 log {level msg}
13f0: 7b 0a 20 20 20 20 76 61 72 69 61 62 6c 65 20 64 {. variable d
1400: 65 62 75 67 0a 20 20 20 20 76 61 72 69 61 62 6c ebug. variabl
1410: 65 20 6c 6f 67 63 6d 64 0a 0a 20 20 20 20 69 66 e logcmd.. if
1420: 20 7b 24 6c 65 76 65 6c 20 3e 20 24 64 65 62 75 {$level > $debu
1430: 67 20 7c 7c 20 24 6c 6f 67 63 6d 64 20 3d 3d 20 g || $logcmd ==
1440: 22 22 7d 20 7b 0a 09 72 65 74 75 72 6e 0a 20 20 ""} {..return.
1450: 20 20 7d 0a 20 20 20 20 73 65 74 20 63 6d 64 20 }. set cmd
1460: 24 6c 6f 67 63 6d 64 0a 20 20 20 20 6c 61 70 70 $logcmd. lapp
1470: 65 6e 64 20 63 6d 64 20 24 6d 73 67 0a 20 20 20 end cmd $msg.
1480: 20 75 70 6c 65 76 65 6c 20 23 30 20 24 63 6d 64 uplevel #0 $cmd
1490: 0a 7d 0a .}.