1#
2# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
3#
4# $Header: /cvsroot/tls/tls/tests/oldTests/tlsSrv2.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    if {[catch {read $chan 1024} data]} {
19	puts stderr "EOF ($data)"
20	catch {close $chan}
21	return
22    }
23
24    if {$verbose && $data != ""} {
25	puts -nonewline stderr $data
26    }
27    if {[eof $chan]} {    ;# client gone or finished
28	puts stderr "EOF"
29	close $chan        ;# release the servers client channel
30	return
31    }
32    puts -nonewline $chan $data
33    flush $chan
34}
35proc acceptCB { chan ip port } {
36    puts "accept: $chan $ip $port"
37
38    if {![tls::handshake $chan]} {
39	puts stderr "Handshake pending"
40	return
41    }
42    array set cert [tls::status $chan]
43    parray cert
44
45    fconfigure $chan -buffering none -blocking 0
46    fileevent $chan readable [list reflectCB $chan 1]
47}
48tls::init -certfile server.pem -tls1 1 ;#-cipher RC4-SHA
49
50set chan [tls::socket -server acceptCB \
51		-request 1 -require 0 -command tls::callback 1234]
52
53puts "Server waiting connection on $chan (1234)"
54
55# Go into the eventloop
56vwait /Exit
57