1#!/bin/sh 2# The next line is executed by /bin/sh, but not tcl \ 3exec tclsh8.3 "$0" ${1+"$@"} 4 5package require tls 6 7set dir [file join [file dirname [info script]] ../tests/certs] 8set OPTS(-cafile) [file join $dir ca.pem] 9set OPTS(-cert) [file join $dir server.pem] 10set OPTS(-key) [file join $dir server.key] 11 12set OPTS(-port) 2468 13set OPTS(-debug) 1 14set OPTS(-require) 1 15 16foreach {key val} $argv { 17 if {![info exists OPTS($key)]} { 18 puts stderr "Usage: $argv0 ?options?\ 19 \n\t-debug boolean Debugging on or off ($OPTS(-debug))\ 20 \n\t-cafile file Cert. Auth. File ($OPTS(-cafile))\ 21 \n\t-cert file Server Cert ($OPTS(-cert))\ 22 \n\t-key file Server Key ($OPTS(-key))\ 23 \n\t-require boolean Require Certification ($OPTS(-require))\ 24 \n\t-port num Port to listen on ($OPTS(-port))" 25 exit 26 } 27 set OPTS($key) $val 28} 29 30# Catch any background errors. 31proc bgerror {msg} { puts stderr "BGERROR: $msg" } 32 33# debugging helper code 34proc shortstr {str} { 35 return "[string replace $str 10 end ...] [string length $str]b" 36} 37proc dputs {msg} { if {$::OPTS(-debug)} { puts stderr $msg ; flush stderr } } 38 39# As a response we just echo the data sent to us. 40# 41proc respond {chan} { 42 if {[catch {read $chan} data]} { 43 #dputs "EOF $chan ([shortstr $data)" 44 catch {close $chan} 45 return 46 } 47 #if {$data != ""} { dputs "got $chan ([shortstr $data])" } 48 if {[eof $chan]} { 49 # client gone or finished 50 dputs "EOF $chan" 51 close $chan ;# release the port 52 return 53 } 54 puts -nonewline $chan $data 55 flush $chan 56 #dputs "sent $chan ([shortstr $data])" 57} 58 59# Once connection is established, we need to ensure handshake. 60# 61proc handshake {s cmd} { 62 if {[eof $s]} { 63 dputs "handshake eof $s" 64 close $s 65 } elseif {[catch {tls::handshake $s} result]} { 66 # Some errors are normal. Specifically, I (hobbs) believe that 67 # TLS throws EAGAINs when it may not need to (or is inappropriate). 68 dputs "handshake error $s: $result" 69 } elseif {$result == 1} { 70 # Handshake complete 71 dputs "handshake complete $s" 72 fileevent $s readable [list $cmd $s] 73 } 74} 75 76# Callback proc to accept a connection from a client. 77# 78proc accept { chan ip port } { 79 dputs "[info level 0] [fconfigure $chan]" 80 fconfigure $chan -blocking 0 81 fileevent $chan readable [list handshake $chan respond] 82} 83 84tls::init -cafile $OPTS(-cafile) -certfile $OPTS(-cert) -keyfile $OPTS(-key) 85set chan [tls::socket -server accept -require $OPTS(-require) $OPTS(-port)] 86 87puts "Server waiting connection on $chan ($OPTS(-port))" 88puts [fconfigure $chan] 89 90vwait __forever__ 91