Artifact
97efb072d220bdf48522f2123ec6f3b686ec09609c827ed10b9b2aceb4086184:
0000: 23 21 2f 75 73 72 2f 62 69 6e 2f 65 6e 76 20 74 #!/usr/bin/env t
0010: 63 6c 73 68 0a 0a 70 61 63 6b 61 67 65 20 72 65 clsh..package re
0020: 71 75 69 72 65 20 74 6c 73 0a 0a 73 65 74 20 64 quire tls..set d
0030: 69 72 09 09 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 ir...[file join
0040: 5b 66 69 6c 65 20 64 69 72 6e 61 6d 65 20 5b 69 [file dirname [i
0050: 6e 66 6f 20 73 63 72 69 70 74 5d 5d 20 2e 2e 2f nfo script]] ../
0060: 74 65 73 74 73 2f 63 65 72 74 73 5d 0a 73 65 74 tests/certs].set
0070: 20 4f 50 54 53 28 2d 63 61 66 69 6c 65 29 09 5b OPTS(-cafile).[
0080: 66 69 6c 65 20 6a 6f 69 6e 20 24 64 69 72 20 63 file join $dir c
0090: 61 2e 70 65 6d 5d 0a 73 65 74 20 4f 50 54 53 28 a.pem].set OPTS(
00a0: 2d 63 65 72 74 29 09 09 5b 66 69 6c 65 20 6a 6f -cert)..[file jo
00b0: 69 6e 20 24 64 69 72 20 73 65 72 76 65 72 2e 70 in $dir server.p
00c0: 65 6d 5d 0a 73 65 74 20 4f 50 54 53 28 2d 6b 65 em].set OPTS(-ke
00d0: 79 29 09 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 24 y)..[file join $
00e0: 64 69 72 20 73 65 72 76 65 72 2e 6b 65 79 5d 0a dir server.key].
00f0: 0a 73 65 74 20 4f 50 54 53 28 2d 70 6f 72 74 29 .set OPTS(-port)
0100: 09 32 34 36 38 0a 73 65 74 20 4f 50 54 53 28 2d .2468.set OPTS(-
0110: 64 65 62 75 67 29 20 31 0a 73 65 74 20 4f 50 54 debug) 1.set OPT
0120: 53 28 2d 72 65 71 75 69 72 65 29 20 31 0a 0a 66 S(-require) 1..f
0130: 6f 72 65 61 63 68 20 7b 6b 65 79 20 76 61 6c 7d oreach {key val}
0140: 20 24 61 72 67 76 20 7b 0a 20 20 20 20 69 66 20 $argv {. if
0150: 7b 21 5b 69 6e 66 6f 20 65 78 69 73 74 73 20 4f {![info exists O
0160: 50 54 53 28 24 6b 65 79 29 5d 7d 20 7b 0a 09 70 PTS($key)]} {..p
0170: 75 74 73 20 73 74 64 65 72 72 20 22 55 73 61 67 uts stderr "Usag
0180: 65 3a 20 24 61 72 67 76 30 20 3f 6f 70 74 69 6f e: $argv0 ?optio
0190: 6e 73 3f 5c 0a 09 09 5c 6e 5c 74 2d 64 65 62 75 ns?\...\n\t-debu
01a0: 67 20 20 20 20 62 6f 6f 6c 65 61 6e 20 20 44 65 g boolean De
01b0: 62 75 67 67 69 6e 67 20 6f 6e 20 6f 72 20 6f 66 bugging on or of
01c0: 66 20 28 24 4f 50 54 53 28 2d 64 65 62 75 67 29 f ($OPTS(-debug)
01d0: 29 5c 0a 09 09 5c 6e 5c 74 2d 63 61 66 69 6c 65 )\...\n\t-cafile
01e0: 20 20 20 66 69 6c 65 20 20 20 20 20 43 65 72 74 file Cert
01f0: 2e 20 41 75 74 68 2e 20 46 69 6c 65 20 28 24 4f . Auth. File ($O
0200: 50 54 53 28 2d 63 61 66 69 6c 65 29 29 5c 0a 09 PTS(-cafile))\..
0210: 09 5c 6e 5c 74 2d 63 65 72 74 20 20 20 20 20 66 .\n\t-cert f
0220: 69 6c 65 20 20 20 20 20 53 65 72 76 65 72 20 43 ile Server C
0230: 65 72 74 20 28 24 4f 50 54 53 28 2d 63 65 72 74 ert ($OPTS(-cert
0240: 29 29 5c 0a 09 09 5c 6e 5c 74 2d 6b 65 79 20 20 ))\...\n\t-key
0250: 20 20 20 20 66 69 6c 65 20 20 20 20 20 53 65 72 file Ser
0260: 76 65 72 20 4b 65 79 20 28 24 4f 50 54 53 28 2d ver Key ($OPTS(-
0270: 6b 65 79 29 29 5c 0a 09 09 5c 6e 5c 74 2d 72 65 key))\...\n\t-re
0280: 71 75 69 72 65 20 20 62 6f 6f 6c 65 61 6e 20 20 quire boolean
0290: 52 65 71 75 69 72 65 20 43 65 72 74 69 66 69 63 Require Certific
02a0: 61 74 65 20 28 24 4f 50 54 53 28 2d 72 65 71 75 ate ($OPTS(-requ
02b0: 69 72 65 29 29 5c 0a 09 09 5c 6e 5c 74 2d 70 6f ire))\...\n\t-po
02c0: 72 74 20 20 20 20 20 6e 75 6d 20 20 20 20 20 20 rt num
02d0: 50 6f 72 74 20 74 6f 20 6c 69 73 74 65 6e 20 6f Port to listen o
02e0: 6e 20 28 24 4f 50 54 53 28 2d 70 6f 72 74 29 29 n ($OPTS(-port))
02f0: 22 0a 09 65 78 69 74 0a 20 20 20 20 7d 0a 20 20 "..exit. }.
0300: 20 20 73 65 74 20 4f 50 54 53 28 24 6b 65 79 29 set OPTS($key)
0310: 20 24 76 61 6c 0a 7d 0a 0a 23 20 43 61 74 63 68 $val.}..# Catch
0320: 20 20 61 6e 79 20 62 61 63 6b 67 72 6f 75 6e 64 any background
0330: 20 65 72 72 6f 72 73 2e 0a 70 72 6f 63 20 62 67 errors..proc bg
0340: 65 72 72 6f 72 20 7b 6d 73 67 7d 20 7b 20 70 75 error {msg} { pu
0350: 74 73 20 73 74 64 65 72 72 20 22 42 47 45 52 52 ts stderr "BGERR
0360: 4f 52 3a 20 24 6d 73 67 22 20 7d 0a 0a 23 20 64 OR: $msg" }..# d
0370: 65 62 75 67 67 69 6e 67 20 68 65 6c 70 65 72 20 ebugging helper
0380: 63 6f 64 65 0a 70 72 6f 63 20 73 68 6f 72 74 73 code.proc shorts
0390: 74 72 20 7b 73 74 72 7d 20 7b 0a 20 20 20 20 72 tr {str} {. r
03a0: 65 74 75 72 6e 20 22 5b 73 74 72 69 6e 67 20 72 eturn "[string r
03b0: 65 70 6c 61 63 65 20 24 73 74 72 20 31 30 20 65 eplace $str 10 e
03c0: 6e 64 20 2e 2e 2e 5d 20 5b 73 74 72 69 6e 67 20 nd ...] [string
03d0: 6c 65 6e 67 74 68 20 24 73 74 72 5d 62 22 0a 7d length $str]b".}
03e0: 0a 70 72 6f 63 20 64 70 75 74 73 20 7b 6d 73 67 .proc dputs {msg
03f0: 7d 20 7b 20 69 66 20 7b 24 3a 3a 4f 50 54 53 28 } { if {$::OPTS(
0400: 2d 64 65 62 75 67 29 7d 20 7b 20 70 75 74 73 20 -debug)} { puts
0410: 73 74 64 65 72 72 20 24 6d 73 67 20 3b 20 66 6c stderr $msg ; fl
0420: 75 73 68 20 73 74 64 65 72 72 20 7d 20 7d 0a 0a ush stderr } }..
0430: 23 20 41 73 20 61 20 72 65 73 70 6f 6e 73 65 20 # As a response
0440: 77 65 20 6a 75 73 74 20 65 63 68 6f 20 74 68 65 we just echo the
0450: 20 64 61 74 61 20 73 65 6e 74 20 74 6f 20 75 73 data sent to us
0460: 2e 0a 23 0a 70 72 6f 63 20 72 65 73 70 6f 6e 64 ..#.proc respond
0470: 20 7b 63 68 61 6e 7d 20 7b 0a 20 20 20 20 69 66 {chan} {. if
0480: 20 7b 5b 63 61 74 63 68 20 7b 72 65 61 64 20 24 {[catch {read $
0490: 63 68 61 6e 7d 20 64 61 74 61 5d 7d 20 7b 0a 09 chan} data]} {..
04a0: 23 64 70 75 74 73 20 22 45 4f 46 20 24 63 68 61 #dputs "EOF $cha
04b0: 6e 20 28 5b 73 68 6f 72 74 73 74 72 20 24 64 61 n ([shortstr $da
04c0: 74 61 29 22 0a 09 63 61 74 63 68 20 7b 63 6c 6f ta)"..catch {clo
04d0: 73 65 20 24 63 68 61 6e 7d 0a 09 72 65 74 75 72 se $chan}..retur
04e0: 6e 0a 20 20 20 20 7d 0a 20 20 20 20 23 69 66 20 n. }. #if
04f0: 7b 24 64 61 74 61 20 6e 65 20 22 22 7d 20 7b 20 {$data ne ""} {
0500: 64 70 75 74 73 20 22 67 6f 74 20 24 63 68 61 6e dputs "got $chan
0510: 20 28 5b 73 68 6f 72 74 73 74 72 20 24 64 61 74 ([shortstr $dat
0520: 61 5d 29 22 20 7d 0a 20 20 20 20 69 66 20 7b 5b a])" }. if {[
0530: 65 6f 66 20 24 63 68 61 6e 5d 7d 20 7b 0a 09 23 eof $chan]} {..#
0540: 20 63 6c 69 65 6e 74 20 67 6f 6e 65 20 6f 72 20 client gone or
0550: 66 69 6e 69 73 68 65 64 0a 09 64 70 75 74 73 20 finished..dputs
0560: 22 45 4f 46 20 24 63 68 61 6e 22 0a 09 63 6c 6f "EOF $chan"..clo
0570: 73 65 20 24 63 68 61 6e 09 09 3b 23 20 20 72 65 se $chan..;# re
0580: 6c 65 61 73 65 20 74 68 65 20 70 6f 72 74 0a 09 lease the port..
0590: 72 65 74 75 72 6e 0a 20 20 20 20 7d 0a 20 20 20 return. }.
05a0: 20 70 75 74 73 20 2d 6e 6f 6e 65 77 6c 69 6e 65 puts -nonewline
05b0: 20 24 63 68 61 6e 20 24 64 61 74 61 0a 20 20 20 $chan $data.
05c0: 20 66 6c 75 73 68 20 24 63 68 61 6e 0a 20 20 20 flush $chan.
05d0: 20 23 64 70 75 74 73 20 22 73 65 6e 74 20 24 63 #dputs "sent $c
05e0: 68 61 6e 20 28 5b 73 68 6f 72 74 73 74 72 20 24 han ([shortstr $
05f0: 64 61 74 61 5d 29 22 0a 7d 0a 0a 23 20 4f 6e 63 data])".}..# Onc
0600: 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 73 20 e connection is
0610: 65 73 74 61 62 6c 69 73 68 65 64 2c 20 77 65 20 established, we
0620: 6e 65 65 64 20 74 6f 20 65 6e 73 75 72 65 20 68 need to ensure h
0630: 61 6e 64 73 68 61 6b 65 2e 0a 23 0a 70 72 6f 63 andshake..#.proc
0640: 20 68 61 6e 64 73 68 61 6b 65 20 7b 73 20 63 6d handshake {s cm
0650: 64 7d 20 7b 0a 20 20 20 20 69 66 20 7b 5b 65 6f d} {. if {[eo
0660: 66 20 24 73 5d 7d 20 7b 0a 09 64 70 75 74 73 20 f $s]} {..dputs
0670: 22 68 61 6e 64 73 68 61 6b 65 20 65 6f 66 20 24 "handshake eof $
0680: 73 22 0a 09 63 6c 6f 73 65 20 24 73 0a 20 20 20 s"..close $s.
0690: 20 7d 20 65 6c 73 65 69 66 20 7b 5b 63 61 74 63 } elseif {[catc
06a0: 68 20 7b 74 6c 73 3a 3a 68 61 6e 64 73 68 61 6b h {tls::handshak
06b0: 65 20 24 73 7d 20 72 65 73 75 6c 74 5d 7d 20 7b e $s} result]} {
06c0: 0a 09 23 20 53 6f 6d 65 20 65 72 72 6f 72 73 20 ..# Some errors
06d0: 61 72 65 20 6e 6f 72 6d 61 6c 2e 20 20 53 70 65 are normal. Spe
06e0: 63 69 66 69 63 61 6c 6c 79 2c 20 49 20 28 68 6f cifically, I (ho
06f0: 62 62 73 29 20 62 65 6c 69 65 76 65 20 74 68 61 bbs) believe tha
0700: 74 0a 09 23 20 54 4c 53 20 74 68 72 6f 77 73 20 t..# TLS throws
0710: 45 41 47 41 49 4e 73 20 77 68 65 6e 20 69 74 20 EAGAINs when it
0720: 6d 61 79 20 6e 6f 74 20 6e 65 65 64 20 74 6f 20 may not need to
0730: 28 6f 72 20 69 73 20 69 6e 61 70 70 72 6f 70 72 (or is inappropr
0740: 69 61 74 65 29 2e 0a 09 64 70 75 74 73 20 22 68 iate)...dputs "h
0750: 61 6e 64 73 68 61 6b 65 20 65 72 72 6f 72 20 24 andshake error $
0760: 73 3a 20 24 72 65 73 75 6c 74 22 0a 20 20 20 20 s: $result".
0770: 7d 20 65 6c 73 65 69 66 20 7b 24 72 65 73 75 6c } elseif {$resul
0780: 74 20 3d 3d 20 31 7d 20 7b 0a 09 23 20 48 61 6e t == 1} {..# Han
0790: 64 73 68 61 6b 65 20 63 6f 6d 70 6c 65 74 65 0a dshake complete.
07a0: 09 64 70 75 74 73 20 22 68 61 6e 64 73 68 61 6b .dputs "handshak
07b0: 65 20 63 6f 6d 70 6c 65 74 65 20 24 73 22 0a 09 e complete $s"..
07c0: 66 69 6c 65 65 76 65 6e 74 20 24 73 20 72 65 61 fileevent $s rea
07d0: 64 61 62 6c 65 20 5b 6c 69 73 74 20 24 63 6d 64 dable [list $cmd
07e0: 20 24 73 5d 0a 20 20 20 20 7d 0a 7d 0a 0a 23 20 $s]. }.}..#
07f0: 43 61 6c 6c 62 61 63 6b 20 70 72 6f 63 20 74 6f Callback proc to
0800: 20 61 63 63 65 70 74 20 61 20 63 6f 6e 6e 65 63 accept a connec
0810: 74 69 6f 6e 20 66 72 6f 6d 20 61 20 63 6c 69 65 tion from a clie
0820: 6e 74 2e 0a 23 0a 70 72 6f 63 20 61 63 63 65 70 nt..#.proc accep
0830: 74 20 7b 20 63 68 61 6e 20 69 70 20 70 6f 72 74 t { chan ip port
0840: 20 7d 20 7b 0a 20 20 20 20 64 70 75 74 73 20 22 } {. dputs "
0850: 5b 69 6e 66 6f 20 6c 65 76 65 6c 20 30 5d 20 5b [info level 0] [
0860: 66 63 6f 6e 66 69 67 75 72 65 20 24 63 68 61 6e fconfigure $chan
0870: 5d 22 0a 20 20 20 20 66 63 6f 6e 66 69 67 75 72 ]". fconfigur
0880: 65 20 24 63 68 61 6e 20 2d 62 6c 6f 63 6b 69 6e e $chan -blockin
0890: 67 20 30 0a 20 20 20 20 66 69 6c 65 65 76 65 6e g 0. fileeven
08a0: 74 20 24 63 68 61 6e 20 72 65 61 64 61 62 6c 65 t $chan readable
08b0: 20 5b 6c 69 73 74 20 68 61 6e 64 73 68 61 6b 65 [list handshake
08c0: 20 24 63 68 61 6e 20 72 65 73 70 6f 6e 64 5d 0a $chan respond].
08d0: 7d 0a 0a 74 6c 73 3a 3a 69 6e 69 74 20 2d 63 61 }..tls::init -ca
08e0: 66 69 6c 65 20 24 4f 50 54 53 28 2d 63 61 66 69 file $OPTS(-cafi
08f0: 6c 65 29 20 2d 63 65 72 74 66 69 6c 65 20 24 4f le) -certfile $O
0900: 50 54 53 28 2d 63 65 72 74 29 20 2d 6b 65 79 66 PTS(-cert) -keyf
0910: 69 6c 65 20 24 4f 50 54 53 28 2d 6b 65 79 29 0a ile $OPTS(-key).
0920: 73 65 74 20 63 68 61 6e 20 5b 74 6c 73 3a 3a 73 set chan [tls::s
0930: 6f 63 6b 65 74 20 2d 73 65 72 76 65 72 20 61 63 ocket -server ac
0940: 63 65 70 74 20 2d 72 65 71 75 69 72 65 20 24 4f cept -require $O
0950: 50 54 53 28 2d 72 65 71 75 69 72 65 29 20 24 4f PTS(-require) $O
0960: 50 54 53 28 2d 70 6f 72 74 29 5d 0a 0a 70 75 74 PTS(-port)]..put
0970: 73 20 22 53 65 72 76 65 72 20 77 61 69 74 69 6e s "Server waitin
0980: 67 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 6f 6e 20 g connection on
0990: 24 63 68 61 6e 20 28 24 4f 50 54 53 28 2d 70 6f $chan ($OPTS(-po
09a0: 72 74 29 29 22 0a 70 75 74 73 20 5b 66 63 6f 6e rt))".puts [fcon
09b0: 66 69 67 75 72 65 20 24 63 68 61 6e 5d 0a 0a 76 figure $chan]..v
09c0: 77 61 69 74 20 5f 5f 66 6f 72 65 76 65 72 5f 5f wait __forever__
09d0: 0a .