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