Artifact
86951f40b86e387bcebf4d17491ea66f4751ccb9:
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 63 65 72 74 2e 70 65 n $dir cacert.pe
00e0: 6d 5d 0a 73 65 74 20 4f 50 54 53 28 2d 63 65 72 m].set OPTS(-cer
00f0: 74 29 09 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 24 t)..[file join $
0100: 64 69 72 20 73 65 72 76 65 72 2e 70 65 6d 5d 0a dir server.pem].
0110: 73 65 74 20 4f 50 54 53 28 2d 6b 65 79 29 09 09 set OPTS(-key)..
0120: 5b 66 69 6c 65 20 6a 6f 69 6e 20 24 64 69 72 20 [file join $dir
0130: 73 6b 65 79 2e 70 65 6d 5d 0a 0a 73 65 74 20 4f skey.pem]..set O
0140: 50 54 53 28 2d 70 6f 72 74 29 09 32 34 36 38 0a PTS(-port).2468.
0150: 73 65 74 20 4f 50 54 53 28 2d 64 65 62 75 67 29 set OPTS(-debug)
0160: 20 31 0a 73 65 74 20 4f 50 54 53 28 2d 72 65 71 1.set OPTS(-req
0170: 75 69 72 65 29 20 31 0a 0a 66 6f 72 65 61 63 68 uire) 1..foreach
0180: 20 7b 6b 65 79 20 76 61 6c 7d 20 24 61 72 67 76 {key val} $argv
0190: 20 7b 0a 20 20 20 20 69 66 20 7b 21 5b 69 6e 66 {. if {![inf
01a0: 6f 20 65 78 69 73 74 73 20 4f 50 54 53 28 24 6b o exists OPTS($k
01b0: 65 79 29 5d 7d 20 7b 0a 09 70 75 74 73 20 73 74 ey)]} {..puts st
01c0: 64 65 72 72 20 22 55 73 61 67 65 3a 20 24 61 72 derr "Usage: $ar
01d0: 67 76 30 20 3f 6f 70 74 69 6f 6e 73 3f 5c 0a 09 gv0 ?options?\..
01e0: 09 5c 6e 5c 74 2d 64 65 62 75 67 20 20 20 20 62 .\n\t-debug b
01f0: 6f 6f 6c 65 61 6e 20 20 44 65 62 75 67 67 69 6e oolean Debuggin
0200: 67 20 6f 6e 20 6f 72 20 6f 66 66 20 28 24 4f 50 g on or off ($OP
0210: 54 53 28 2d 64 65 62 75 67 29 29 5c 0a 09 09 5c TS(-debug))\...\
0220: 6e 5c 74 2d 63 61 66 69 6c 65 20 20 20 66 69 6c n\t-cafile fil
0230: 65 20 20 20 20 20 43 65 72 74 2e 20 41 75 74 68 e Cert. Auth
0240: 2e 20 46 69 6c 65 20 28 24 4f 50 54 53 28 2d 63 . File ($OPTS(-c
0250: 61 66 69 6c 65 29 29 5c 0a 09 09 5c 6e 5c 74 2d afile))\...\n\t-
0260: 63 65 72 74 20 20 20 20 20 66 69 6c 65 20 20 20 cert file
0270: 20 20 53 65 72 76 65 72 20 43 65 72 74 20 28 24 Server Cert ($
0280: 4f 50 54 53 28 2d 63 65 72 74 29 29 5c 0a 09 09 OPTS(-cert))\...
0290: 5c 6e 5c 74 2d 6b 65 79 20 20 20 20 20 20 66 69 \n\t-key fi
02a0: 6c 65 20 20 20 20 20 53 65 72 76 65 72 20 4b 65 le Server Ke
02b0: 79 20 28 24 4f 50 54 53 28 2d 6b 65 79 29 29 5c y ($OPTS(-key))\
02c0: 0a 09 09 5c 6e 5c 74 2d 72 65 71 75 69 72 65 20 ...\n\t-require
02d0: 20 62 6f 6f 6c 65 61 6e 20 20 52 65 71 75 69 72 boolean Requir
02e0: 65 20 43 65 72 74 69 66 69 63 61 74 69 6f 6e 20 e Certification
02f0: 28 24 4f 50 54 53 28 2d 72 65 71 75 69 72 65 29 ($OPTS(-require)
0300: 29 5c 0a 09 09 5c 6e 5c 74 2d 70 6f 72 74 20 20 )\...\n\t-port
0310: 20 20 20 6e 75 6d 20 20 20 20 20 20 50 6f 72 74 num Port
0320: 20 74 6f 20 6c 69 73 74 65 6e 20 6f 6e 20 28 24 to listen on ($
0330: 4f 50 54 53 28 2d 70 6f 72 74 29 29 22 0a 09 65 OPTS(-port))"..e
0340: 78 69 74 0a 20 20 20 20 7d 0a 20 20 20 20 73 65 xit. }. se
0350: 74 20 4f 50 54 53 28 24 6b 65 79 29 20 24 76 61 t OPTS($key) $va
0360: 6c 0a 7d 0a 0a 23 20 43 61 74 63 68 20 20 61 6e l.}..# Catch an
0370: 79 20 62 61 63 6b 67 72 6f 75 6e 64 20 65 72 72 y background err
0380: 6f 72 73 2e 0a 70 72 6f 63 20 62 67 65 72 72 6f ors..proc bgerro
0390: 72 20 7b 6d 73 67 7d 20 7b 20 70 75 74 73 20 73 r {msg} { puts s
03a0: 74 64 65 72 72 20 22 42 47 45 52 52 4f 52 3a 20 tderr "BGERROR:
03b0: 24 6d 73 67 22 20 7d 0a 0a 23 20 64 65 62 75 67 $msg" }..# debug
03c0: 67 69 6e 67 20 68 65 6c 70 65 72 20 63 6f 64 65 ging helper code
03d0: 0a 70 72 6f 63 20 73 68 6f 72 74 73 74 72 20 7b .proc shortstr {
03e0: 73 74 72 7d 20 7b 0a 20 20 20 20 72 65 74 75 72 str} {. retur
03f0: 6e 20 22 5b 73 74 72 69 6e 67 20 72 65 70 6c 61 n "[string repla
0400: 63 65 20 24 73 74 72 20 31 30 20 65 6e 64 20 2e ce $str 10 end .
0410: 2e 2e 5d 20 5b 73 74 72 69 6e 67 20 6c 65 6e 67 ..] [string leng
0420: 74 68 20 24 73 74 72 5d 62 22 0a 7d 0a 70 72 6f th $str]b".}.pro
0430: 63 20 64 70 75 74 73 20 7b 6d 73 67 7d 20 7b 20 c dputs {msg} {
0440: 69 66 20 7b 24 3a 3a 4f 50 54 53 28 2d 64 65 62 if {$::OPTS(-deb
0450: 75 67 29 7d 20 7b 20 70 75 74 73 20 73 74 64 65 ug)} { puts stde
0460: 72 72 20 24 6d 73 67 20 3b 20 66 6c 75 73 68 20 rr $msg ; flush
0470: 73 74 64 65 72 72 20 7d 20 7d 0a 0a 23 20 41 73 stderr } }..# As
0480: 20 61 20 72 65 73 70 6f 6e 73 65 20 77 65 20 6a a response we j
0490: 75 73 74 20 65 63 68 6f 20 74 68 65 20 64 61 74 ust echo the dat
04a0: 61 20 73 65 6e 74 20 74 6f 20 75 73 2e 0a 23 0a a sent to us..#.
04b0: 70 72 6f 63 20 72 65 73 70 6f 6e 64 20 7b 63 68 proc respond {ch
04c0: 61 6e 7d 20 7b 0a 20 20 20 20 69 66 20 7b 5b 63 an} {. if {[c
04d0: 61 74 63 68 20 7b 72 65 61 64 20 24 63 68 61 6e atch {read $chan
04e0: 7d 20 64 61 74 61 5d 7d 20 7b 0a 09 23 64 70 75 } data]} {..#dpu
04f0: 74 73 20 22 45 4f 46 20 24 63 68 61 6e 20 28 5b ts "EOF $chan ([
0500: 73 68 6f 72 74 73 74 72 20 24 64 61 74 61 29 22 shortstr $data)"
0510: 0a 09 63 61 74 63 68 20 7b 63 6c 6f 73 65 20 24 ..catch {close $
0520: 63 68 61 6e 7d 0a 09 72 65 74 75 72 6e 0a 20 20 chan}..return.
0530: 20 20 7d 0a 20 20 20 20 23 69 66 20 7b 24 64 61 }. #if {$da
0540: 74 61 20 21 3d 20 22 22 7d 20 7b 20 64 70 75 74 ta != ""} { dput
0550: 73 20 22 67 6f 74 20 24 63 68 61 6e 20 28 5b 73 s "got $chan ([s
0560: 68 6f 72 74 73 74 72 20 24 64 61 74 61 5d 29 22 hortstr $data])"
0570: 20 7d 0a 20 20 20 20 69 66 20 7b 5b 65 6f 66 20 }. if {[eof
0580: 24 63 68 61 6e 5d 7d 20 7b 0a 09 23 20 63 6c 69 $chan]} {..# cli
0590: 65 6e 74 20 67 6f 6e 65 20 6f 72 20 66 69 6e 69 ent gone or fini
05a0: 73 68 65 64 0a 09 64 70 75 74 73 20 22 45 4f 46 shed..dputs "EOF
05b0: 20 24 63 68 61 6e 22 0a 09 63 6c 6f 73 65 20 24 $chan"..close $
05c0: 63 68 61 6e 09 09 3b 23 20 20 72 65 6c 65 61 73 chan..;# releas
05d0: 65 20 74 68 65 20 70 6f 72 74 0a 09 72 65 74 75 e the port..retu
05e0: 72 6e 0a 20 20 20 20 7d 0a 20 20 20 20 70 75 74 rn. }. put
05f0: 73 20 2d 6e 6f 6e 65 77 6c 69 6e 65 20 24 63 68 s -nonewline $ch
0600: 61 6e 20 24 64 61 74 61 0a 20 20 20 20 66 6c 75 an $data. flu
0610: 73 68 20 24 63 68 61 6e 0a 20 20 20 20 23 64 70 sh $chan. #dp
0620: 75 74 73 20 22 73 65 6e 74 20 24 63 68 61 6e 20 uts "sent $chan
0630: 28 5b 73 68 6f 72 74 73 74 72 20 24 64 61 74 61 ([shortstr $data
0640: 5d 29 22 0a 7d 0a 0a 23 20 4f 6e 63 65 20 63 6f ])".}..# Once co
0650: 6e 6e 65 63 74 69 6f 6e 20 69 73 20 65 73 74 61 nnection is esta
0660: 62 6c 69 73 68 65 64 2c 20 77 65 20 6e 65 65 64 blished, we need
0670: 20 74 6f 20 65 6e 73 75 72 65 20 68 61 6e 64 73 to ensure hands
0680: 68 61 6b 65 2e 0a 23 0a 70 72 6f 63 20 68 61 6e hake..#.proc han
0690: 64 73 68 61 6b 65 20 7b 73 20 63 6d 64 7d 20 7b dshake {s cmd} {
06a0: 0a 20 20 20 20 69 66 20 7b 5b 65 6f 66 20 24 73 . if {[eof $s
06b0: 5d 7d 20 7b 0a 09 64 70 75 74 73 20 22 68 61 6e ]} {..dputs "han
06c0: 64 73 68 61 6b 65 20 65 6f 66 20 24 73 22 0a 09 dshake eof $s"..
06d0: 63 6c 6f 73 65 20 24 73 0a 20 20 20 20 7d 20 65 close $s. } e
06e0: 6c 73 65 69 66 20 7b 5b 63 61 74 63 68 20 7b 74 lseif {[catch {t
06f0: 6c 73 3a 3a 68 61 6e 64 73 68 61 6b 65 20 24 73 ls::handshake $s
0700: 7d 20 72 65 73 75 6c 74 5d 7d 20 7b 0a 09 23 20 } result]} {..#
0710: 53 6f 6d 65 20 65 72 72 6f 72 73 20 61 72 65 20 Some errors are
0720: 6e 6f 72 6d 61 6c 2e 20 20 53 70 65 63 69 66 69 normal. Specifi
0730: 63 61 6c 6c 79 2c 20 49 20 28 68 6f 62 62 73 29 cally, I (hobbs)
0740: 20 62 65 6c 69 65 76 65 20 74 68 61 74 0a 09 23 believe that..#
0750: 20 54 4c 53 20 74 68 72 6f 77 73 20 45 41 47 41 TLS throws EAGA
0760: 49 4e 73 20 77 68 65 6e 20 69 74 20 6d 61 79 20 INs when it may
0770: 6e 6f 74 20 6e 65 65 64 20 74 6f 20 28 6f 72 20 not need to (or
0780: 69 73 20 69 6e 61 70 70 72 6f 70 72 69 61 74 65 is inappropriate
0790: 29 2e 0a 09 64 70 75 74 73 20 22 68 61 6e 64 73 )...dputs "hands
07a0: 68 61 6b 65 20 65 72 72 6f 72 20 24 73 3a 20 24 hake error $s: $
07b0: 72 65 73 75 6c 74 22 0a 20 20 20 20 7d 20 65 6c result". } el
07c0: 73 65 69 66 20 7b 24 72 65 73 75 6c 74 20 3d 3d seif {$result ==
07d0: 20 31 7d 20 7b 0a 09 23 20 48 61 6e 64 73 68 61 1} {..# Handsha
07e0: 6b 65 20 63 6f 6d 70 6c 65 74 65 0a 09 64 70 75 ke complete..dpu
07f0: 74 73 20 22 68 61 6e 64 73 68 61 6b 65 20 63 6f ts "handshake co
0800: 6d 70 6c 65 74 65 20 24 73 22 0a 09 66 69 6c 65 mplete $s"..file
0810: 65 76 65 6e 74 20 24 73 20 72 65 61 64 61 62 6c event $s readabl
0820: 65 20 5b 6c 69 73 74 20 24 63 6d 64 20 24 73 5d e [list $cmd $s]
0830: 0a 20 20 20 20 7d 0a 7d 0a 0a 23 20 43 61 6c 6c . }.}..# Call
0840: 62 61 63 6b 20 70 72 6f 63 20 74 6f 20 61 63 63 back proc to acc
0850: 65 70 74 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e ept a connection
0860: 20 66 72 6f 6d 20 61 20 63 6c 69 65 6e 74 2e 0a from a client..
0870: 23 0a 70 72 6f 63 20 61 63 63 65 70 74 20 7b 20 #.proc accept {
0880: 63 68 61 6e 20 69 70 20 70 6f 72 74 20 7d 20 7b chan ip port } {
0890: 0a 20 20 20 20 64 70 75 74 73 20 22 5b 69 6e 66 . dputs "[inf
08a0: 6f 20 6c 65 76 65 6c 20 30 5d 20 5b 66 63 6f 6e o level 0] [fcon
08b0: 66 69 67 75 72 65 20 24 63 68 61 6e 5d 22 0a 20 figure $chan]".
08c0: 20 20 20 66 63 6f 6e 66 69 67 75 72 65 20 24 63 fconfigure $c
08d0: 68 61 6e 20 2d 62 6c 6f 63 6b 69 6e 67 20 30 0a han -blocking 0.
08e0: 20 20 20 20 66 69 6c 65 65 76 65 6e 74 20 24 63 fileevent $c
08f0: 68 61 6e 20 72 65 61 64 61 62 6c 65 20 5b 6c 69 han readable [li
0900: 73 74 20 68 61 6e 64 73 68 61 6b 65 20 24 63 68 st handshake $ch
0910: 61 6e 20 72 65 73 70 6f 6e 64 5d 0a 7d 0a 0a 74 an respond].}..t
0920: 6c 73 3a 3a 69 6e 69 74 20 2d 63 61 66 69 6c 65 ls::init -cafile
0930: 20 24 4f 50 54 53 28 2d 63 61 66 69 6c 65 29 20 $OPTS(-cafile)
0940: 2d 63 65 72 74 66 69 6c 65 20 24 4f 50 54 53 28 -certfile $OPTS(
0950: 2d 63 65 72 74 29 20 2d 6b 65 79 66 69 6c 65 20 -cert) -keyfile
0960: 24 4f 50 54 53 28 2d 6b 65 79 29 0a 73 65 74 20 $OPTS(-key).set
0970: 63 68 61 6e 20 5b 74 6c 73 3a 3a 73 6f 63 6b 65 chan [tls::socke
0980: 74 20 2d 73 65 72 76 65 72 20 61 63 63 65 70 74 t -server accept
0990: 20 2d 72 65 71 75 69 72 65 20 24 4f 50 54 53 28 -require $OPTS(
09a0: 2d 72 65 71 75 69 72 65 29 20 24 4f 50 54 53 28 -require) $OPTS(
09b0: 2d 70 6f 72 74 29 5d 0a 0a 70 75 74 73 20 22 53 -port)]..puts "S
09c0: 65 72 76 65 72 20 77 61 69 74 69 6e 67 20 63 6f erver waiting co
09d0: 6e 6e 65 63 74 69 6f 6e 20 6f 6e 20 24 63 68 61 nnection on $cha
09e0: 6e 20 28 24 4f 50 54 53 28 2d 70 6f 72 74 29 29 n ($OPTS(-port))
09f0: 22 0a 70 75 74 73 20 5b 66 63 6f 6e 66 69 67 75 ".puts [fconfigu
0a00: 72 65 20 24 63 68 61 6e 5d 0a 0a 76 77 61 69 74 re $chan]..vwait
0a10: 20 5f 5f 66 6f 72 65 76 65 72 5f 5f 0a __forever__.