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