Artifact
581f14df70014455cb0be6a7c476247bcc7d097a368d2b0884c991728f5904be:
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 70 72 clsh..package pr
0020: 65 66 65 72 20 6c 61 74 65 73 74 0a 70 61 63 6b efer latest.pack
0030: 61 67 65 20 72 65 71 75 69 72 65 20 74 6c 73 0a age require tls.
0040: 0a 73 65 74 20 64 69 72 09 09 09 5b 66 69 6c 65 .set dir...[file
0050: 20 6a 6f 69 6e 20 5b 66 69 6c 65 20 64 69 72 6e join [file dirn
0060: 61 6d 65 20 5b 69 6e 66 6f 20 73 63 72 69 70 74 ame [info script
0070: 5d 5d 20 2e 2e 2f 74 65 73 74 73 2f 63 65 72 74 ]] ../tests/cert
0080: 73 5d 0a 73 65 74 20 4f 50 54 53 28 2d 63 61 66 s].set OPTS(-caf
0090: 69 6c 65 29 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 ile).[file join
00a0: 24 64 69 72 20 63 61 2e 70 65 6d 5d 0a 73 65 74 $dir ca.pem].set
00b0: 20 4f 50 54 53 28 2d 63 65 72 74 29 09 09 5b 66 OPTS(-cert)..[f
00c0: 69 6c 65 20 6a 6f 69 6e 20 24 64 69 72 20 73 65 ile join $dir se
00d0: 72 76 65 72 2e 70 65 6d 5d 0a 73 65 74 20 4f 50 rver.pem].set OP
00e0: 54 53 28 2d 6b 65 79 29 09 09 5b 66 69 6c 65 20 TS(-key)..[file
00f0: 6a 6f 69 6e 20 24 64 69 72 20 73 65 72 76 65 72 join $dir server
0100: 2e 6b 65 79 5d 0a 0a 73 65 74 20 4f 50 54 53 28 .key]..set OPTS(
0110: 2d 70 6f 72 74 29 09 32 34 36 38 0a 73 65 74 20 -port).2468.set
0120: 4f 50 54 53 28 2d 64 65 62 75 67 29 20 31 0a 73 OPTS(-debug) 1.s
0130: 65 74 20 4f 50 54 53 28 2d 72 65 71 75 69 72 65 et OPTS(-require
0140: 29 20 31 0a 0a 66 6f 72 65 61 63 68 20 7b 6b 65 ) 1..foreach {ke
0150: 79 20 76 61 6c 7d 20 24 61 72 67 76 20 7b 0a 20 y val} $argv {.
0160: 20 20 20 69 66 20 7b 21 5b 69 6e 66 6f 20 65 78 if {![info ex
0170: 69 73 74 73 20 4f 50 54 53 28 24 6b 65 79 29 5d ists OPTS($key)]
0180: 7d 20 7b 0a 09 70 75 74 73 20 73 74 64 65 72 72 } {..puts stderr
0190: 20 22 55 73 61 67 65 3a 20 24 61 72 67 76 30 20 "Usage: $argv0
01a0: 3f 6f 70 74 69 6f 6e 73 3f 5c 0a 09 09 5c 6e 5c ?options?\...\n\
01b0: 74 2d 64 65 62 75 67 20 20 20 20 62 6f 6f 6c 65 t-debug boole
01c0: 61 6e 20 20 44 65 62 75 67 67 69 6e 67 20 6f 6e an Debugging on
01d0: 20 6f 72 20 6f 66 66 20 28 24 4f 50 54 53 28 2d or off ($OPTS(-
01e0: 64 65 62 75 67 29 29 5c 0a 09 09 5c 6e 5c 74 2d debug))\...\n\t-
01f0: 63 61 66 69 6c 65 20 20 20 66 69 6c 65 20 20 20 cafile file
0200: 20 20 43 65 72 74 2e 20 41 75 74 68 2e 20 46 69 Cert. Auth. Fi
0210: 6c 65 20 28 24 4f 50 54 53 28 2d 63 61 66 69 6c le ($OPTS(-cafil
0220: 65 29 29 5c 0a 09 09 5c 6e 5c 74 2d 63 65 72 74 e))\...\n\t-cert
0230: 20 20 20 20 20 66 69 6c 65 20 20 20 20 20 53 65 file Se
0240: 72 76 65 72 20 43 65 72 74 20 28 24 4f 50 54 53 rver Cert ($OPTS
0250: 28 2d 63 65 72 74 29 29 5c 0a 09 09 5c 6e 5c 74 (-cert))\...\n\t
0260: 2d 6b 65 79 20 20 20 20 20 20 66 69 6c 65 20 20 -key file
0270: 20 20 20 53 65 72 76 65 72 20 4b 65 79 20 28 24 Server Key ($
0280: 4f 50 54 53 28 2d 6b 65 79 29 29 5c 0a 09 09 5c OPTS(-key))\...\
0290: 6e 5c 74 2d 72 65 71 75 69 72 65 20 20 62 6f 6f n\t-require boo
02a0: 6c 65 61 6e 20 20 52 65 71 75 69 72 65 20 43 65 lean Require Ce
02b0: 72 74 69 66 69 63 61 74 65 20 28 24 4f 50 54 53 rtificate ($OPTS
02c0: 28 2d 72 65 71 75 69 72 65 29 29 5c 0a 09 09 5c (-require))\...\
02d0: 6e 5c 74 2d 70 6f 72 74 20 20 20 20 20 6e 75 6d n\t-port num
02e0: 20 20 20 20 20 20 50 6f 72 74 20 74 6f 20 6c 69 Port to li
02f0: 73 74 65 6e 20 6f 6e 20 28 24 4f 50 54 53 28 2d sten on ($OPTS(-
0300: 70 6f 72 74 29 29 22 0a 09 65 78 69 74 0a 20 20 port))"..exit.
0310: 20 20 7d 0a 20 20 20 20 73 65 74 20 4f 50 54 53 }. set OPTS
0320: 28 24 6b 65 79 29 20 24 76 61 6c 0a 7d 0a 0a 23 ($key) $val.}..#
0330: 20 43 61 74 63 68 20 20 61 6e 79 20 62 61 63 6b Catch any back
0340: 67 72 6f 75 6e 64 20 65 72 72 6f 72 73 2e 0a 70 ground errors..p
0350: 72 6f 63 20 62 67 65 72 72 6f 72 20 7b 6d 73 67 roc bgerror {msg
0360: 7d 20 7b 20 70 75 74 73 20 73 74 64 65 72 72 20 } { puts stderr
0370: 22 42 47 45 52 52 4f 52 3a 20 24 6d 73 67 22 20 "BGERROR: $msg"
0380: 7d 0a 0a 23 20 64 65 62 75 67 67 69 6e 67 20 68 }..# debugging h
0390: 65 6c 70 65 72 20 63 6f 64 65 0a 70 72 6f 63 20 elper code.proc
03a0: 73 68 6f 72 74 73 74 72 20 7b 73 74 72 7d 20 7b shortstr {str} {
03b0: 0a 20 20 20 20 72 65 74 75 72 6e 20 22 5b 73 74 . return "[st
03c0: 72 69 6e 67 20 72 65 70 6c 61 63 65 20 24 73 74 ring replace $st
03d0: 72 20 31 30 20 65 6e 64 20 2e 2e 2e 5d 20 5b 73 r 10 end ...] [s
03e0: 74 72 69 6e 67 20 6c 65 6e 67 74 68 20 24 73 74 tring length $st
03f0: 72 5d 62 22 0a 7d 0a 70 72 6f 63 20 64 70 75 74 r]b".}.proc dput
0400: 73 20 7b 6d 73 67 7d 20 7b 20 69 66 20 7b 24 3a s {msg} { if {$:
0410: 3a 4f 50 54 53 28 2d 64 65 62 75 67 29 7d 20 7b :OPTS(-debug)} {
0420: 20 70 75 74 73 20 73 74 64 65 72 72 20 24 6d 73 puts stderr $ms
0430: 67 20 3b 20 66 6c 75 73 68 20 73 74 64 65 72 72 g ; flush stderr
0440: 20 7d 20 7d 0a 0a 23 20 41 73 20 61 20 72 65 73 } }..# As a res
0450: 70 6f 6e 73 65 20 77 65 20 6a 75 73 74 20 65 63 ponse we just ec
0460: 68 6f 20 74 68 65 20 64 61 74 61 20 73 65 6e 74 ho the data sent
0470: 20 74 6f 20 75 73 2e 0a 23 0a 70 72 6f 63 20 72 to us..#.proc r
0480: 65 73 70 6f 6e 64 20 7b 63 68 61 6e 7d 20 7b 0a espond {chan} {.
0490: 20 20 20 20 69 66 20 7b 5b 63 61 74 63 68 20 7b if {[catch {
04a0: 72 65 61 64 20 24 63 68 61 6e 7d 20 64 61 74 61 read $chan} data
04b0: 5d 7d 20 7b 0a 09 23 64 70 75 74 73 20 22 45 4f ]} {..#dputs "EO
04c0: 46 20 24 63 68 61 6e 20 28 5b 73 68 6f 72 74 73 F $chan ([shorts
04d0: 74 72 20 24 64 61 74 61 29 22 0a 09 63 61 74 63 tr $data)"..catc
04e0: 68 20 7b 63 6c 6f 73 65 20 24 63 68 61 6e 7d 0a h {close $chan}.
04f0: 09 72 65 74 75 72 6e 0a 20 20 20 20 7d 0a 20 20 .return. }.
0500: 20 20 23 69 66 20 7b 24 64 61 74 61 20 6e 65 20 #if {$data ne
0510: 22 22 7d 20 7b 20 64 70 75 74 73 20 22 67 6f 74 ""} { dputs "got
0520: 20 24 63 68 61 6e 20 28 5b 73 68 6f 72 74 73 74 $chan ([shortst
0530: 72 20 24 64 61 74 61 5d 29 22 20 7d 0a 20 20 20 r $data])" }.
0540: 20 69 66 20 7b 5b 65 6f 66 20 24 63 68 61 6e 5d if {[eof $chan]
0550: 7d 20 7b 0a 09 23 20 63 6c 69 65 6e 74 20 67 6f } {..# client go
0560: 6e 65 20 6f 72 20 66 69 6e 69 73 68 65 64 0a 09 ne or finished..
0570: 64 70 75 74 73 20 22 45 4f 46 20 24 63 68 61 6e dputs "EOF $chan
0580: 22 0a 09 63 6c 6f 73 65 20 24 63 68 61 6e 09 09 "..close $chan..
0590: 3b 23 20 20 72 65 6c 65 61 73 65 20 74 68 65 20 ;# release the
05a0: 70 6f 72 74 0a 09 72 65 74 75 72 6e 0a 20 20 20 port..return.
05b0: 20 7d 0a 20 20 20 20 70 75 74 73 20 2d 6e 6f 6e }. puts -non
05c0: 65 77 6c 69 6e 65 20 24 63 68 61 6e 20 24 64 61 ewline $chan $da
05d0: 74 61 0a 20 20 20 20 66 6c 75 73 68 20 24 63 68 ta. flush $ch
05e0: 61 6e 0a 20 20 20 20 23 64 70 75 74 73 20 22 73 an. #dputs "s
05f0: 65 6e 74 20 24 63 68 61 6e 20 28 5b 73 68 6f 72 ent $chan ([shor
0600: 74 73 74 72 20 24 64 61 74 61 5d 29 22 0a 7d 0a tstr $data])".}.
0610: 0a 23 20 4f 6e 63 65 20 63 6f 6e 6e 65 63 74 69 .# Once connecti
0620: 6f 6e 20 69 73 20 65 73 74 61 62 6c 69 73 68 65 on is establishe
0630: 64 2c 20 77 65 20 6e 65 65 64 20 74 6f 20 65 6e d, we need to en
0640: 73 75 72 65 20 68 61 6e 64 73 68 61 6b 65 2e 0a sure handshake..
0650: 23 0a 70 72 6f 63 20 68 61 6e 64 73 68 61 6b 65 #.proc handshake
0660: 20 7b 73 20 63 6d 64 7d 20 7b 0a 20 20 20 20 69 {s cmd} {. i
0670: 66 20 7b 5b 65 6f 66 20 24 73 5d 7d 20 7b 0a 09 f {[eof $s]} {..
0680: 64 70 75 74 73 20 22 68 61 6e 64 73 68 61 6b 65 dputs "handshake
0690: 20 65 6f 66 20 24 73 22 0a 09 63 6c 6f 73 65 20 eof $s"..close
06a0: 24 73 0a 20 20 20 20 7d 20 65 6c 73 65 69 66 20 $s. } elseif
06b0: 7b 5b 63 61 74 63 68 20 7b 74 6c 73 3a 3a 68 61 {[catch {tls::ha
06c0: 6e 64 73 68 61 6b 65 20 24 73 7d 20 72 65 73 75 ndshake $s} resu
06d0: 6c 74 5d 7d 20 7b 0a 09 23 20 53 6f 6d 65 20 65 lt]} {..# Some e
06e0: 72 72 6f 72 73 20 61 72 65 20 6e 6f 72 6d 61 6c rrors are normal
06f0: 2e 20 20 53 70 65 63 69 66 69 63 61 6c 6c 79 2c . Specifically,
0700: 20 49 20 28 68 6f 62 62 73 29 20 62 65 6c 69 65 I (hobbs) belie
0710: 76 65 20 74 68 61 74 0a 09 23 20 54 4c 53 20 74 ve that..# TLS t
0720: 68 72 6f 77 73 20 45 41 47 41 49 4e 73 20 77 68 hrows EAGAINs wh
0730: 65 6e 20 69 74 20 6d 61 79 20 6e 6f 74 20 6e 65 en it may not ne
0740: 65 64 20 74 6f 20 28 6f 72 20 69 73 20 69 6e 61 ed to (or is ina
0750: 70 70 72 6f 70 72 69 61 74 65 29 2e 0a 09 64 70 ppropriate)...dp
0760: 75 74 73 20 22 68 61 6e 64 73 68 61 6b 65 20 65 uts "handshake e
0770: 72 72 6f 72 20 24 73 3a 20 24 72 65 73 75 6c 74 rror $s: $result
0780: 22 0a 20 20 20 20 7d 20 65 6c 73 65 69 66 20 7b ". } elseif {
0790: 24 72 65 73 75 6c 74 20 3d 3d 20 31 7d 20 7b 0a $result == 1} {.
07a0: 09 23 20 48 61 6e 64 73 68 61 6b 65 20 63 6f 6d .# Handshake com
07b0: 70 6c 65 74 65 0a 09 64 70 75 74 73 20 22 68 61 plete..dputs "ha
07c0: 6e 64 73 68 61 6b 65 20 63 6f 6d 70 6c 65 74 65 ndshake complete
07d0: 20 24 73 22 0a 09 66 69 6c 65 65 76 65 6e 74 20 $s"..fileevent
07e0: 24 73 20 72 65 61 64 61 62 6c 65 20 5b 6c 69 73 $s readable [lis
07f0: 74 20 24 63 6d 64 20 24 73 5d 0a 20 20 20 20 7d t $cmd $s]. }
0800: 0a 7d 0a 0a 23 20 43 61 6c 6c 62 61 63 6b 20 70 .}..# Callback p
0810: 72 6f 63 20 74 6f 20 61 63 63 65 70 74 20 61 20 roc to accept a
0820: 63 6f 6e 6e 65 63 74 69 6f 6e 20 66 72 6f 6d 20 connection from
0830: 61 20 63 6c 69 65 6e 74 2e 0a 23 0a 70 72 6f 63 a client..#.proc
0840: 20 61 63 63 65 70 74 20 7b 20 63 68 61 6e 20 69 accept { chan i
0850: 70 20 70 6f 72 74 20 7d 20 7b 0a 20 20 20 20 64 p port } {. d
0860: 70 75 74 73 20 22 5b 69 6e 66 6f 20 6c 65 76 65 puts "[info leve
0870: 6c 20 30 5d 20 5b 66 63 6f 6e 66 69 67 75 72 65 l 0] [fconfigure
0880: 20 24 63 68 61 6e 5d 22 0a 20 20 20 20 66 63 6f $chan]". fco
0890: 6e 66 69 67 75 72 65 20 24 63 68 61 6e 20 2d 62 nfigure $chan -b
08a0: 6c 6f 63 6b 69 6e 67 20 30 0a 20 20 20 20 66 69 locking 0. fi
08b0: 6c 65 65 76 65 6e 74 20 24 63 68 61 6e 20 72 65 leevent $chan re
08c0: 61 64 61 62 6c 65 20 5b 6c 69 73 74 20 68 61 6e adable [list han
08d0: 64 73 68 61 6b 65 20 24 63 68 61 6e 20 72 65 73 dshake $chan res
08e0: 70 6f 6e 64 5d 0a 7d 0a 0a 74 6c 73 3a 3a 69 6e pond].}..tls::in
08f0: 69 74 20 2d 63 61 66 69 6c 65 20 24 4f 50 54 53 it -cafile $OPTS
0900: 28 2d 63 61 66 69 6c 65 29 20 2d 63 65 72 74 66 (-cafile) -certf
0910: 69 6c 65 20 24 4f 50 54 53 28 2d 63 65 72 74 29 ile $OPTS(-cert)
0920: 20 2d 6b 65 79 66 69 6c 65 20 24 4f 50 54 53 28 -keyfile $OPTS(
0930: 2d 6b 65 79 29 0a 73 65 74 20 63 68 61 6e 20 5b -key).set chan [
0940: 74 6c 73 3a 3a 73 6f 63 6b 65 74 20 2d 73 65 72 tls::socket -ser
0950: 76 65 72 20 61 63 63 65 70 74 20 2d 72 65 71 75 ver accept -requ
0960: 69 72 65 20 24 4f 50 54 53 28 2d 72 65 71 75 69 ire $OPTS(-requi
0970: 72 65 29 20 24 4f 50 54 53 28 2d 70 6f 72 74 29 re) $OPTS(-port)
0980: 5d 0a 0a 70 75 74 73 20 22 53 65 72 76 65 72 20 ]..puts "Server
0990: 77 61 69 74 69 6e 67 20 63 6f 6e 6e 65 63 74 69 waiting connecti
09a0: 6f 6e 20 6f 6e 20 24 63 68 61 6e 20 28 24 4f 50 on on $chan ($OP
09b0: 54 53 28 2d 70 6f 72 74 29 29 22 0a 70 75 74 73 TS(-port))".puts
09c0: 20 5b 66 63 6f 6e 66 69 67 75 72 65 20 24 63 68 [fconfigure $ch
09d0: 61 6e 5d 0a 0a 76 77 61 69 74 20 5f 5f 66 6f 72 an]..vwait __for
09e0: 65 76 65 72 5f 5f 0a ever__.