1#
2# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
3#
4# $Header: /cvsroot/tls/tls/tests/oldTests/tlsSrv.tcl,v 1.1 2000/06/06 18:13:21 aborr Exp $
5#
6# Sample Tls-enabled server
7#
8set dir [file dirname [info script]]
9cd $dir
10source tls.tcl
11#lappend auto_path d:/tcl80/lib
12#package require tls
13
14#
15# Sample callback - just reflect data back to client
16#
17proc reflectCB {chan {verbose 0}} {
18    set x hello
19    if {[catch {read $chan 1024} data]} {
20	puts stderr "EOF ($data)"
21	catch {close $chan}
22	return
23    }
24
25    if {$verbose && $data != ""} {
26	puts -nonewline stderr $data
27    }
28    if {[eof $chan]} {    ;# client gone or finished
29	puts stderr "EOF"
30	close $chan        ;# release the servers client channel
31	return
32    }
33    puts -nonewline $chan $data
34    flush $chan
35}
36proc acceptCB { chan ip port } {
37    puts "accept: $chan $ip $port [fconfigure $chan]"
38    if {[catch {
39	tls::handshake $chan
40    } err]} {
41	catch {close $chan}
42	return
43    }
44    puts [tls::status $chan]
45
46    fconfigure $chan -buffering none -blocking 0
47    fileevent $chan readable [list reflectCB $chan 1]
48}
49#tls::init -cafile server.pem -certfile server.pem
50tls::init -cafile server.pem
51#tls::init
52
53set chan [tls::socket -server acceptCB \
54		-request 1 -require 0 1234]
55#		-require 1 -command tls::callback 1234]
56
57puts "Server waiting connection on $chan (1234)"
58puts [fconfigure $chan]
59
60# Go into the eventloop
61vwait /Exit
62