by [Reinhard Max], Jul 21 2003. #!/usr/bin/tclsh # # Authors: # 2003, Reinhard Max # SSL support added by Pat Thoyts # # This file may be used and distributed under the same conditions as Tcl/Tk # # Which port doe we listen on. The second element can be an alternative socket # command. set ports {{4242 {}} {443 {}}} # If you want to use SSL on port 443 then you need to provide a pair of OpenSSL # files for the keys. We setup the tls package here and below we can specify # what command to use to create the socket for each port. if {![catch {package require tls 1.4}] } { if {[file exists server-public.pem]} { ::tls::init \ -certfile server-public.pem \ -keyfile server-private.pem \ -ssl2 1 \ -ssl3 1 \ -tls1 0 \ -require 0 \ -request 0 # fix this if you change the ports variable above. lset ports 1 1 ::tls::socket } } # Which commands shall be understood by our protocol set commands { echo I help listme bye reload showstate auth } array unset help array set help { help {Lists the available commands.} {help } {Prints a short help on the given command.} {echo } {Return the given arguments.} {I am } {Tell the server your name and it will greet you.} listme {Returns the Tcl script that implements this server.} bye {Close the connection.} showstate {Show the state array of the current connection.} {auth } {Authenticate yourself.} } proc auth {user pass} { upvar 1 state state # Put your code for username/password lookup here. set state(user) $user set state(pass) $pass set state(auth) 1 return OK } proc showstate {} { upvar 1 state state farray state } proc reload {args} { after idle [list source [info script]] return "Matrix reloaded! ;)" } proc echo {args} { upvar 1 state state return $args } proc I {args} { set args [lrange $args 1 end] return "Hello $args!" } proc listme {} { set fd [open [info script]] set script [read $fd] close $fd return $script } proc bye {} { upvar 1 state state after idle [list slaveServer::closeSocket $state(socket)] return "Good bye!" } proc strip {string} { regsub -all -line {^\s+} $string {} } proc max {a b} {expr {$a > $b ? $a : $b}} proc farray {array {separator =} {pattern *}} { upvar $array a set names [lsort [array names a $pattern]] set max 0 foreach name $names { set max [max $max [string length $name]] } set result [list] foreach name $names { lappend result [format " %-*s %s %s" $max $name $separator $a($name)] } return [join $result "\n"] } proc help {{{} {}}} { global help set helps [farray help - ${}*] if {$helps == ""} { set helps "No help available for ${}!" } return "\n$helps\n" } namespace eval slaveServer { # procs that start with a lowercase letter are public namespace export {[a-z]*} variable serversocket } proc slaveServer::closeSocket {socket} { variable $socket upvar 0 $socket state puts stderr "Closing $socket [clock format [clock seconds]]" catch {close $socket} unset state } # This gets called whenever a client connects proc slaveServer::Server {socket host port} { variable $socket upvar 0 $socket state # just to be sure ... array unset state set state(socket) $socket set state(host) $host set state(port) $port puts stderr "New Connection: $socket $host $port [clock format [clock seconds]]" fconfigure $socket -buffering line -blocking 0 fileevent $socket readable [list [namespace code Handler] $socket] puts $socket "Welcome to this little demo server!" puts $socket "Type \"help\" to see what you can do here." } # This gets called whenever a client sends a new line # of data or disconnects proc slaveServer::Handler {socket} { variable $socket upvar 0 $socket state # Do we have a disconnect? if {[eof $socket]} { closeSocket $socket return } # Does reading the socket give us an error? if {[catch {gets $socket line} ret] == -1} { puts stderr "Closing $socket" closeSocket $socket return } # Did we really get a whole line? if {$ret == -1} return # ... and is it not empty? ... set line [string trim $line] if {$line == ""} return ## ... and not an SSL request? ... #if {[string index $line 0] == "\200"} { # puts stderr "SSL request - closing connection" # closeSocket $socket # return #} # OK, so log it ... puts stderr "$socket > $line" # ... evaluate it, ... if {[catch {slave eval $line} ret]} { set ret "ERROR: $ret" } # ... log the result ... puts stderr [regsub -all -line ^ $ret "$socket < "] # ... and send it back to the client. if {[catch {puts $socket $ret}]} { closeSocket $socket } } proc slaveServer::init {ports commands} { variable serversockets # (re-)create a safe slave interpreter catch {interp delete slave} interp create -safe slave # remove all predefined commands from the slave foreach command [slave eval info commands] { slave hide $command } # link the commands for the protocol into the slave puts -nonewline stderr "Initializing commands:" foreach command $commands { puts -nonewline stderr " $command" interp alias slave $command {} $command } puts stderr "" #(re-)create the server socket if {[info exists serversockets]} { foreach sock $serversockets { catch {close $sock} } unset serversockets } puts -nonewline stderr "Opening sockets:" foreach {port} $ports { foreach {port socketCmd} $port {} if {$socketCmd == {}} { set socketCmd ::socket } puts -nonewline stderr " $port ($socketCmd)" lappend serversockets \ [$socketCmd -server [namespace code Server] $port] } puts stderr "" } slaveServer::init $ports $commands if {![info exists forever]} { set forever 1 vwait forever } ---- [[ [Category Internet] - [Category Networking] ]]