Artifact
1570c8544f533ae298bb825be0fed451818bb74d36113e136329db2a0391da78:
0000: 23 21 2f 62 69 6e 2f 73 68 0a 23 20 54 68 65 20 #!/bin/sh.# The
0010: 6e 65 78 74 20 6c 69 6e 65 20 69 73 20 65 78 65 next line is exe
0020: 63 75 74 65 64 20 62 79 20 2f 62 69 6e 2f 73 68 cuted by /bin/sh
0030: 2c 20 62 75 74 20 6e 6f 74 20 74 63 6c 20 5c 0a , but not tcl \.
0040: 65 78 65 63 20 74 63 6c 73 68 38 2e 33 20 22 24 exec tclsh8.3 "$
0050: 30 22 20 24 7b 31 2b 22 24 40 22 7d 0a 0a 70 61 0" ${1+"$@"}..pa
0060: 63 6b 61 67 65 20 72 65 71 75 69 72 65 20 74 6c ckage require tl
0070: 73 0a 0a 73 65 74 20 64 69 72 09 09 09 5b 66 69 s..set dir...[fi
0080: 6c 65 20 6a 6f 69 6e 20 5b 66 69 6c 65 20 64 69 le join [file di
0090: 72 6e 61 6d 65 20 5b 69 6e 66 6f 20 73 63 72 69 rname [info scri
00a0: 70 74 5d 5d 20 2e 2e 2f 74 65 73 74 73 2f 63 65 pt]] ../tests/ce
00b0: 72 74 73 5d 0a 73 65 74 20 4f 50 54 53 28 2d 63 rts].set OPTS(-c
00c0: 61 66 69 6c 65 29 09 5b 66 69 6c 65 20 6a 6f 69 afile).[file joi
00d0: 6e 20 24 64 69 72 20 63 61 2e 70 65 6d 5d 0a 73 n $dir ca.pem].s
00e0: 65 74 20 4f 50 54 53 28 2d 63 65 72 74 29 09 09 et OPTS(-cert)..
00f0: 5b 66 69 6c 65 20 6a 6f 69 6e 20 24 64 69 72 20 [file join $dir
0100: 73 65 72 76 65 72 2e 70 65 6d 5d 0a 73 65 74 20 server.pem].set
0110: 4f 50 54 53 28 2d 6b 65 79 29 09 09 5b 66 69 6c OPTS(-key)..[fil
0120: 65 20 6a 6f 69 6e 20 24 64 69 72 20 73 65 72 76 e join $dir serv
0130: 65 72 2e 6b 65 79 5d 0a 0a 73 65 74 20 4f 50 54 er.key]..set OPT
0140: 53 28 2d 70 6f 72 74 29 09 32 34 36 38 0a 73 65 S(-port).2468.se
0150: 74 20 4f 50 54 53 28 2d 64 65 62 75 67 29 20 31 t OPTS(-debug) 1
0160: 0a 73 65 74 20 4f 50 54 53 28 2d 72 65 71 75 69 .set OPTS(-requi
0170: 72 65 29 20 31 0a 0a 66 6f 72 65 61 63 68 20 7b re) 1..foreach {
0180: 6b 65 79 20 76 61 6c 7d 20 24 61 72 67 76 20 7b key val} $argv {
0190: 0a 20 20 20 20 69 66 20 7b 21 5b 69 6e 66 6f 20 . if {![info
01a0: 65 78 69 73 74 73 20 4f 50 54 53 28 24 6b 65 79 exists OPTS($key
01b0: 29 5d 7d 20 7b 0a 09 70 75 74 73 20 73 74 64 65 )]} {..puts stde
01c0: 72 72 20 22 55 73 61 67 65 3a 20 24 61 72 67 76 rr "Usage: $argv
01d0: 30 20 3f 6f 70 74 69 6f 6e 73 3f 5c 0a 09 09 5c 0 ?options?\...\
01e0: 6e 5c 74 2d 64 65 62 75 67 20 20 20 20 62 6f 6f n\t-debug boo
01f0: 6c 65 61 6e 20 20 44 65 62 75 67 67 69 6e 67 20 lean Debugging
0200: 6f 6e 20 6f 72 20 6f 66 66 20 28 24 4f 50 54 53 on or off ($OPTS
0210: 28 2d 64 65 62 75 67 29 29 5c 0a 09 09 5c 6e 5c (-debug))\...\n\
0220: 74 2d 63 61 66 69 6c 65 20 20 20 66 69 6c 65 20 t-cafile file
0230: 20 20 20 20 43 65 72 74 2e 20 41 75 74 68 2e 20 Cert. Auth.
0240: 46 69 6c 65 20 28 24 4f 50 54 53 28 2d 63 61 66 File ($OPTS(-caf
0250: 69 6c 65 29 29 5c 0a 09 09 5c 6e 5c 74 2d 63 65 ile))\...\n\t-ce
0260: 72 74 20 20 20 20 20 66 69 6c 65 20 20 20 20 20 rt file
0270: 53 65 72 76 65 72 20 43 65 72 74 20 28 24 4f 50 Server Cert ($OP
0280: 54 53 28 2d 63 65 72 74 29 29 5c 0a 09 09 5c 6e TS(-cert))\...\n
0290: 5c 74 2d 6b 65 79 20 20 20 20 20 20 66 69 6c 65 \t-key file
02a0: 20 20 20 20 20 53 65 72 76 65 72 20 4b 65 79 20 Server Key
02b0: 28 24 4f 50 54 53 28 2d 6b 65 79 29 29 5c 0a 09 ($OPTS(-key))\..
02c0: 09 5c 6e 5c 74 2d 72 65 71 75 69 72 65 20 20 62 .\n\t-require b
02d0: 6f 6f 6c 65 61 6e 20 20 52 65 71 75 69 72 65 20 oolean Require
02e0: 43 65 72 74 69 66 69 63 61 74 69 6f 6e 20 28 24 Certification ($
02f0: 4f 50 54 53 28 2d 72 65 71 75 69 72 65 29 29 5c OPTS(-require))\
0300: 0a 09 09 5c 6e 5c 74 2d 70 6f 72 74 20 20 20 20 ...\n\t-port
0310: 20 6e 75 6d 20 20 20 20 20 20 50 6f 72 74 20 74 num Port t
0320: 6f 20 6c 69 73 74 65 6e 20 6f 6e 20 28 24 4f 50 o listen on ($OP
0330: 54 53 28 2d 70 6f 72 74 29 29 22 0a 09 65 78 69 TS(-port))"..exi
0340: 74 0a 20 20 20 20 7d 0a 20 20 20 20 73 65 74 20 t. }. set
0350: 4f 50 54 53 28 24 6b 65 79 29 20 24 76 61 6c 0a OPTS($key) $val.
0360: 7d 0a 0a 23 20 43 61 74 63 68 20 20 61 6e 79 20 }..# Catch any
0370: 62 61 63 6b 67 72 6f 75 6e 64 20 65 72 72 6f 72 background error
0380: 73 2e 0a 70 72 6f 63 20 62 67 65 72 72 6f 72 20 s..proc bgerror
0390: 7b 6d 73 67 7d 20 7b 20 70 75 74 73 20 73 74 64 {msg} { puts std
03a0: 65 72 72 20 22 42 47 45 52 52 4f 52 3a 20 24 6d err "BGERROR: $m
03b0: 73 67 22 20 7d 0a 0a 23 20 64 65 62 75 67 67 69 sg" }..# debuggi
03c0: 6e 67 20 68 65 6c 70 65 72 20 63 6f 64 65 0a 70 ng helper code.p
03d0: 72 6f 63 20 73 68 6f 72 74 73 74 72 20 7b 73 74 roc shortstr {st
03e0: 72 7d 20 7b 0a 20 20 20 20 72 65 74 75 72 6e 20 r} {. return
03f0: 22 5b 73 74 72 69 6e 67 20 72 65 70 6c 61 63 65 "[string replace
0400: 20 24 73 74 72 20 31 30 20 65 6e 64 20 2e 2e 2e $str 10 end ...
0410: 5d 20 5b 73 74 72 69 6e 67 20 6c 65 6e 67 74 68 ] [string length
0420: 20 24 73 74 72 5d 62 22 0a 7d 0a 70 72 6f 63 20 $str]b".}.proc
0430: 64 70 75 74 73 20 7b 6d 73 67 7d 20 7b 20 69 66 dputs {msg} { if
0440: 20 7b 24 3a 3a 4f 50 54 53 28 2d 64 65 62 75 67 {$::OPTS(-debug
0450: 29 7d 20 7b 20 70 75 74 73 20 73 74 64 65 72 72 )} { puts stderr
0460: 20 24 6d 73 67 20 3b 20 66 6c 75 73 68 20 73 74 $msg ; flush st
0470: 64 65 72 72 20 7d 20 7d 0a 0a 23 20 41 73 20 61 derr } }..# As a
0480: 20 72 65 73 70 6f 6e 73 65 20 77 65 20 6a 75 73 response we jus
0490: 74 20 65 63 68 6f 20 74 68 65 20 64 61 74 61 20 t echo the data
04a0: 73 65 6e 74 20 74 6f 20 75 73 2e 0a 23 0a 70 72 sent to us..#.pr
04b0: 6f 63 20 72 65 73 70 6f 6e 64 20 7b 63 68 61 6e oc respond {chan
04c0: 7d 20 7b 0a 20 20 20 20 69 66 20 7b 5b 63 61 74 } {. if {[cat
04d0: 63 68 20 7b 72 65 61 64 20 24 63 68 61 6e 7d 20 ch {read $chan}
04e0: 64 61 74 61 5d 7d 20 7b 0a 09 23 64 70 75 74 73 data]} {..#dputs
04f0: 20 22 45 4f 46 20 24 63 68 61 6e 20 28 5b 73 68 "EOF $chan ([sh
0500: 6f 72 74 73 74 72 20 24 64 61 74 61 29 22 0a 09 ortstr $data)"..
0510: 63 61 74 63 68 20 7b 63 6c 6f 73 65 20 24 63 68 catch {close $ch
0520: 61 6e 7d 0a 09 72 65 74 75 72 6e 0a 20 20 20 20 an}..return.
0530: 7d 0a 20 20 20 20 23 69 66 20 7b 24 64 61 74 61 }. #if {$data
0540: 20 21 3d 20 22 22 7d 20 7b 20 64 70 75 74 73 20 != ""} { dputs
0550: 22 67 6f 74 20 24 63 68 61 6e 20 28 5b 73 68 6f "got $chan ([sho
0560: 72 74 73 74 72 20 24 64 61 74 61 5d 29 22 20 7d rtstr $data])" }
0570: 0a 20 20 20 20 69 66 20 7b 5b 65 6f 66 20 24 63 . if {[eof $c
0580: 68 61 6e 5d 7d 20 7b 0a 09 23 20 63 6c 69 65 6e han]} {..# clien
0590: 74 20 67 6f 6e 65 20 6f 72 20 66 69 6e 69 73 68 t gone or finish
05a0: 65 64 0a 09 64 70 75 74 73 20 22 45 4f 46 20 24 ed..dputs "EOF $
05b0: 63 68 61 6e 22 0a 09 63 6c 6f 73 65 20 24 63 68 chan"..close $ch
05c0: 61 6e 09 09 3b 23 20 20 72 65 6c 65 61 73 65 20 an..;# release
05d0: 74 68 65 20 70 6f 72 74 0a 09 72 65 74 75 72 6e the port..return
05e0: 0a 20 20 20 20 7d 0a 20 20 20 20 70 75 74 73 20 . }. puts
05f0: 2d 6e 6f 6e 65 77 6c 69 6e 65 20 24 63 68 61 6e -nonewline $chan
0600: 20 24 64 61 74 61 0a 20 20 20 20 66 6c 75 73 68 $data. flush
0610: 20 24 63 68 61 6e 0a 20 20 20 20 23 64 70 75 74 $chan. #dput
0620: 73 20 22 73 65 6e 74 20 24 63 68 61 6e 20 28 5b s "sent $chan ([
0630: 73 68 6f 72 74 73 74 72 20 24 64 61 74 61 5d 29 shortstr $data])
0640: 22 0a 7d 0a 0a 23 20 4f 6e 63 65 20 63 6f 6e 6e ".}..# Once conn
0650: 65 63 74 69 6f 6e 20 69 73 20 65 73 74 61 62 6c ection is establ
0660: 69 73 68 65 64 2c 20 77 65 20 6e 65 65 64 20 74 ished, we need t
0670: 6f 20 65 6e 73 75 72 65 20 68 61 6e 64 73 68 61 o ensure handsha
0680: 6b 65 2e 0a 23 0a 70 72 6f 63 20 68 61 6e 64 73 ke..#.proc hands
0690: 68 61 6b 65 20 7b 73 20 63 6d 64 7d 20 7b 0a 20 hake {s cmd} {.
06a0: 20 20 20 69 66 20 7b 5b 65 6f 66 20 24 73 5d 7d if {[eof $s]}
06b0: 20 7b 0a 09 64 70 75 74 73 20 22 68 61 6e 64 73 {..dputs "hands
06c0: 68 61 6b 65 20 65 6f 66 20 24 73 22 0a 09 63 6c hake eof $s"..cl
06d0: 6f 73 65 20 24 73 0a 20 20 20 20 7d 20 65 6c 73 ose $s. } els
06e0: 65 69 66 20 7b 5b 63 61 74 63 68 20 7b 74 6c 73 eif {[catch {tls
06f0: 3a 3a 68 61 6e 64 73 68 61 6b 65 20 24 73 7d 20 ::handshake $s}
0700: 72 65 73 75 6c 74 5d 7d 20 7b 0a 09 23 20 53 6f result]} {..# So
0710: 6d 65 20 65 72 72 6f 72 73 20 61 72 65 20 6e 6f me errors are no
0720: 72 6d 61 6c 2e 20 20 53 70 65 63 69 66 69 63 61 rmal. Specifica
0730: 6c 6c 79 2c 20 49 20 28 68 6f 62 62 73 29 20 62 lly, I (hobbs) b
0740: 65 6c 69 65 76 65 20 74 68 61 74 0a 09 23 20 54 elieve that..# T
0750: 4c 53 20 74 68 72 6f 77 73 20 45 41 47 41 49 4e LS throws EAGAIN
0760: 73 20 77 68 65 6e 20 69 74 20 6d 61 79 20 6e 6f s when it may no
0770: 74 20 6e 65 65 64 20 74 6f 20 28 6f 72 20 69 73 t need to (or is
0780: 20 69 6e 61 70 70 72 6f 70 72 69 61 74 65 29 2e inappropriate).
0790: 0a 09 64 70 75 74 73 20 22 68 61 6e 64 73 68 61 ..dputs "handsha
07a0: 6b 65 20 65 72 72 6f 72 20 24 73 3a 20 24 72 65 ke error $s: $re
07b0: 73 75 6c 74 22 0a 20 20 20 20 7d 20 65 6c 73 65 sult". } else
07c0: 69 66 20 7b 24 72 65 73 75 6c 74 20 3d 3d 20 31 if {$result == 1
07d0: 7d 20 7b 0a 09 23 20 48 61 6e 64 73 68 61 6b 65 } {..# Handshake
07e0: 20 63 6f 6d 70 6c 65 74 65 0a 09 64 70 75 74 73 complete..dputs
07f0: 20 22 68 61 6e 64 73 68 61 6b 65 20 63 6f 6d 70 "handshake comp
0800: 6c 65 74 65 20 24 73 22 0a 09 66 69 6c 65 65 76 lete $s"..fileev
0810: 65 6e 74 20 24 73 20 72 65 61 64 61 62 6c 65 20 ent $s readable
0820: 5b 6c 69 73 74 20 24 63 6d 64 20 24 73 5d 0a 20 [list $cmd $s].
0830: 20 20 20 7d 0a 7d 0a 0a 23 20 43 61 6c 6c 62 61 }.}..# Callba
0840: 63 6b 20 70 72 6f 63 20 74 6f 20 61 63 63 65 70 ck proc to accep
0850: 74 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 66 t a connection f
0860: 72 6f 6d 20 61 20 63 6c 69 65 6e 74 2e 0a 23 0a rom a client..#.
0870: 70 72 6f 63 20 61 63 63 65 70 74 20 7b 20 63 68 proc accept { ch
0880: 61 6e 20 69 70 20 70 6f 72 74 20 7d 20 7b 0a 20 an ip port } {.
0890: 20 20 20 64 70 75 74 73 20 22 5b 69 6e 66 6f 20 dputs "[info
08a0: 6c 65 76 65 6c 20 30 5d 20 5b 66 63 6f 6e 66 69 level 0] [fconfi
08b0: 67 75 72 65 20 24 63 68 61 6e 5d 22 0a 20 20 20 gure $chan]".
08c0: 20 66 63 6f 6e 66 69 67 75 72 65 20 24 63 68 61 fconfigure $cha
08d0: 6e 20 2d 62 6c 6f 63 6b 69 6e 67 20 30 0a 20 20 n -blocking 0.
08e0: 20 20 66 69 6c 65 65 76 65 6e 74 20 24 63 68 61 fileevent $cha
08f0: 6e 20 72 65 61 64 61 62 6c 65 20 5b 6c 69 73 74 n readable [list
0900: 20 68 61 6e 64 73 68 61 6b 65 20 24 63 68 61 6e handshake $chan
0910: 20 72 65 73 70 6f 6e 64 5d 0a 7d 0a 0a 74 6c 73 respond].}..tls
0920: 3a 3a 69 6e 69 74 20 2d 63 61 66 69 6c 65 20 24 ::init -cafile $
0930: 4f 50 54 53 28 2d 63 61 66 69 6c 65 29 20 2d 63 OPTS(-cafile) -c
0940: 65 72 74 66 69 6c 65 20 24 4f 50 54 53 28 2d 63 ertfile $OPTS(-c
0950: 65 72 74 29 20 2d 6b 65 79 66 69 6c 65 20 24 4f ert) -keyfile $O
0960: 50 54 53 28 2d 6b 65 79 29 0a 73 65 74 20 63 68 PTS(-key).set ch
0970: 61 6e 20 5b 74 6c 73 3a 3a 73 6f 63 6b 65 74 20 an [tls::socket
0980: 2d 73 65 72 76 65 72 20 61 63 63 65 70 74 20 2d -server accept -
0990: 72 65 71 75 69 72 65 20 24 4f 50 54 53 28 2d 72 require $OPTS(-r
09a0: 65 71 75 69 72 65 29 20 24 4f 50 54 53 28 2d 70 equire) $OPTS(-p
09b0: 6f 72 74 29 5d 0a 0a 70 75 74 73 20 22 53 65 72 ort)]..puts "Ser
09c0: 76 65 72 20 77 61 69 74 69 6e 67 20 63 6f 6e 6e ver waiting conn
09d0: 65 63 74 69 6f 6e 20 6f 6e 20 24 63 68 61 6e 20 ection on $chan
09e0: 28 24 4f 50 54 53 28 2d 70 6f 72 74 29 29 22 0a ($OPTS(-port))".
09f0: 70 75 74 73 20 5b 66 63 6f 6e 66 69 67 75 72 65 puts [fconfigure
0a00: 20 24 63 68 61 6e 5d 0a 0a 76 77 61 69 74 20 5f $chan]..vwait _
0a10: 5f 66 6f 72 65 76 65 72 5f 5f 0a _forever__.