Version 3 of A Server Template

Updated 2005-12-18 16:38:51

by Reinhard Max, Jul 21 2003.

 #!/usr/bin/tclsh
 #
 # Authors:
 # 2003, Reinhard Max
 # SSL support added by Pat Thoyts <[email protected]>
 #
 # 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 <command>} {Prints a short help on the given command.}
    {echo <arg>}     {Return the given arguments.}
    {I am <name>}    {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 <user> <password>} {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 {{{<command>} {}}} {
    global help
    set helps [farray help - ${<command>}*]
    if {$helps == ""} {
        set helps "No help available for ${<command>}!"
    }
    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 ]