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