Index: trunk/p2p/Makefile
===================================================================
--- trunk/p2p/Makefile	(revision 1251)
+++ trunk/p2p/Makefile	(revision 1251)
@@ -0,0 +1,2 @@
+all:
+	./mkindex handler.tcl server.tcl client.tcl log.tcl random.tcl
Index: trunk/p2p/README
===================================================================
--- trunk/p2p/README	(revision 1251)
+++ trunk/p2p/README	(revision 1251)
@@ -0,0 +1,53 @@
+----------------------------------------------------------------------
+ P2P job management infrastructure
+ Michael McLennan (mmclennan@purdue.edu)
+======================================================================
+ Copyright (c) 2008  Purdue Research Foundation
+======================================================================
+
+ The files in this directory form the basis for a peer-to-peer
+ job management infrastructure.  The basic idea is that a client
+ connects to a network of workers, asks for bids on a series of
+ jobs it wants to execute, and then farms the jobs out to the
+ workers and collects the results.  In addition to the client
+ and the workers, there are "authority" servers that act like
+ superpeers, helping clients/workers find each other and manage
+ the transfer of points for completed jobs.
+
+ TO RUN THE DEMO:
+
+ $ wish test.tcl
+
+ Press the "Start" button to launch an authority server and a
+ series of workers.  Press the "Reload" button after that to
+ load log information from the workers as they run.  Press
+ "Stop" to kill all processes and load the final log information
+ for visualization.
+
+ Use the "<" and ">" buttons at the bottom to move forward/backward
+ through time, visualizing the communication traffic and the P2P
+ network formation.  Use the slider to jump quickly to a specific
+ point in time.
+
+
+ CLASSES:
+   Handler ... Basis of all servers and clients.  Knows how to
+               receive and interpret Tcl-based commands.  Has a
+               notion of various "protocols" which are collections
+               of messages that can be received and understood.
+               Protocols can be versioned, so each handler should
+               be able to support new and old clients if the protocol
+               changes over time.
+
+   Server .... Derived class based on Handler.  Sits at a particular
+               port and listens for client connections.  The first
+               message any client should send defines the protocol,
+               and then the client sends Tcl-based commands after
+               that.
+
+   Client .... Derived class based on Handler.  Opens a socket to a
+               particular host:port and begins sending/receiving
+               messages.  The first message that it sends should
+               define the protocol for outgoing messages, and the
+               first message it receives should define the protocol
+               for incoming messages.
Index: trunk/p2p/authority.tcl
===================================================================
--- trunk/p2p/authority.tcl	(revision 1251)
+++ trunk/p2p/authority.tcl	(revision 1251)
@@ -0,0 +1,111 @@
+# ----------------------------------------------------------------------
+#  P2P: central authority for all P2P activities
+#
+#  This server is the "superpeer" that all workers contact first
+#  to join the network.  Clients and workers also contact the authority
+#  to handle payments for services.
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+
+# recognize other library files in this same directory
+set dir [file dirname [info script]]
+lappend auto_path $dir
+
+# handle log file for this authority
+log channel debug on
+log channel system on
+
+# ======================================================================
+#  WORKER OPTIONS
+# ======================================================================
+
+# set of connections for authority servers
+set worker_options(authority_hosts) \
+    {127.0.0.1:9001 127.0.0.1:9002 127.0.0.1:9003}
+
+# register with the central authority at this frequency
+set worker_options(time_between_registers) 60000
+
+# workers should try to connect with this many other peers
+set worker_options(max_peer_connections) 4
+
+# ======================================================================
+# set up a server at the first open port above 9001
+set server [Server ::#auto 9001? \
+    -servername authority \
+    -onconnect authority_client_address \
+    -onprotocol authority_client_protocol \
+]
+
+# ----------------------------------------------------------------------
+#  COMMAND: authority_client_address <cid> <addr> <port>
+#
+#  Invoked automatically whenever a client connects to the server.
+#  Adds the client address/port to a list of all known clients.
+#  Other clients searching for peers can ask for a list of all known
+#  clients.
+# ----------------------------------------------------------------------
+proc authority_client_address {cid addr port} {
+    global client2address
+    set client2address($cid) $addr
+}
+
+# ----------------------------------------------------------------------
+#  COMMAND: authority_client_protocol <cid> <protocol>
+#
+#  Invoked automatically whenever a client declares its protocol
+#  to the server.  Clients speaking the "worker" protocol are
+#  kept on a special list.
+# ----------------------------------------------------------------------
+proc authority_client_protocol {cid protocol} {
+    global worker_options client2address
+    if {"DEFAULT" != $protocol} {
+        puts $cid [list protocol $protocol]
+        puts $cid "options [array get worker_options] ip $client2address($cid)"
+    }
+}
+
+# ======================================================================
+#  PROTOCOL: hub:worker/1
+# ======================================================================
+$server protocol hubzero:worker/1
+
+# ----------------------------------------------------------------------
+#  DIRECTIVE: exception <message>
+# ----------------------------------------------------------------------
+$server define hubzero:worker/1 exception {args} {
+    log system "error from worker: $args"
+}
+
+# ----------------------------------------------------------------------
+#  DIRECTIVE: listening <port>
+#  Workers use this to tell the authority what port they're listening
+#  on.  Other workers should connect to this port.
+# ----------------------------------------------------------------------
+$server define hubzero:worker/1 listening {port} {
+    global client2address workers
+    variable handler
+    variable cid
+
+    # register this address on the list of workers
+    set addr "$client2address($cid):$port"
+    set workers($addr) "--"
+
+    # name this connection for easier debugging
+    $handler connectionName $cid $addr
+
+    return ""
+}
+
+# ----------------------------------------------------------------------
+#  DIRECTIVE: peers
+# ----------------------------------------------------------------------
+$server define hubzero:worker/1 peers {} {
+    global workers
+    return [list peers [array names workers]]
+}
+
+vwait main-loop
Index: trunk/p2p/client.tcl
===================================================================
--- trunk/p2p/client.tcl	(revision 1251)
+++ trunk/p2p/client.tcl	(revision 1251)
@@ -0,0 +1,85 @@
+# ----------------------------------------------------------------------
+#  LIBRARY: handles the client side of the connection in the p2p
+#    infrastructure
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+package require Itcl
+
+itcl::class Client {
+    inherit Handler
+
+    private variable _addr "" ;# address that this client is connected to
+    private variable _sid ""  ;# file handle for server connection
+
+    constructor {addr args} {
+        eval configure $args
+
+        #
+        # Connect to the server at the specified address, which is
+        # specified as "host:port".
+        #
+        set alist [split $addr :]
+        if {[llength $alist] != 2} {
+            error "bad address \"$addr\": should be host:port"
+        }
+        foreach {host port} $alist break
+        set _sid [socket $host $port]
+        connectionName $_sid $host:$port
+        connectionSpeaks $_sid DEFAULT
+
+        fileevent $_sid readable [itcl::code $this handle $_sid]
+        fconfigure $_sid -buffering line
+
+        set _addr $addr
+    }
+
+    destructor {
+        catch {close $_sid}
+    }
+
+    public method send {message}
+    public method address {}
+
+    protected method handlerType {}
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: send <message>
+#
+#  Used to send a <message> off to the server.  If the connection
+#  was unexpectedly closed, then this method does nothing.
+# ----------------------------------------------------------------------
+itcl::body Client::send {message} {
+    if {"" != $_sid} {
+        if {[eof $_sid]} {
+            set _sid ""
+        } else {
+            log debug "sending: $message"
+            puts $_sid $message
+        }
+    }
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: address
+#
+#  Returns the address that this client is connected to.  This is
+#  the host:port passed in when the client was created.
+# ----------------------------------------------------------------------
+itcl::body Client::address {} {
+    return $_addr
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: handlerType
+#
+#  Returns a descriptive string describing this handler.  Derived
+#  classes override this method to provide their own string.  Used
+#  for debug messages.
+# ----------------------------------------------------------------------
+itcl::body Client::handlerType {} {
+    return "client"
+}
Index: trunk/p2p/handler.tcl
===================================================================
--- trunk/p2p/handler.tcl	(revision 1251)
+++ trunk/p2p/handler.tcl	(revision 1251)
@@ -0,0 +1,211 @@
+# ----------------------------------------------------------------------
+#  LIBRARY: Handler
+#  Base class for Client and Server.  Handles protocol declarations
+#  for messages received by the handler, and knows how to process
+#  messages.
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+package require Itcl
+
+itcl::class Handler {
+    private variable _namesp    ;# maps protocol name => namespace of cmds
+    private variable _parser    ;# maps protocol name => parser for cmds
+    private variable _buffer    ;# maps connection => cmd buffer
+    private variable _protocol  ;# maps connection => protocol name
+    private variable _cname     ;# maps connection => nice name for debug
+    private common _counter 0
+
+    constructor {args} {
+        #
+        # Define the DEFAULT protocol, which clients/servers use when
+        # they first connect to define the protocol they intend to speak.
+        #
+        protocol DEFAULT
+        define DEFAULT protocol {version} {
+            variable handler
+            variable cid
+            $handler connectionSpeaks $cid $version
+            return ""
+        }
+
+        eval configure $args
+    }
+
+    destructor {
+        foreach protocol [array names _parser] {
+            interp delete $_parser($protocol)
+        }
+        foreach protocol [array names _namesp] {
+            namespace delete $_namesp($protocol)
+        }
+    }
+
+    public method protocol {name}
+    public method define {protocol name arglist body}
+    public method connectionName {cid {name ""}}
+    public method connectionSpeaks {cid protocol}
+
+    protected method handle {cid}
+    protected method finalize {protocol}
+    protected method handlerType {}
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: protocol <name>
+#
+#  Used to define a protocol that this client/server recognizes.
+#  A protocol has an associated safe interpreter full of commands
+#  that the client/server recognizes.  When each connection is
+#  established, the other party must declare the  protocol that it
+#  intends to speak up front, so the client/server can select the
+#  appropriate interpreter for all incoming requests.
+# ----------------------------------------------------------------------
+itcl::body Handler::protocol {name} {
+    if {[info exists _namesp($name)]} {
+        error "protocol \"$name\" already defined"
+    }
+    set _namesp($name) "[namespace current]::bodies[incr _counter]"
+    namespace eval $_namesp($name) {}
+    set _parser($name) [interp create -safe]
+    foreach cmd [$_parser($name) eval {info commands}] {
+        $_parser($name) hide $cmd
+    }
+    $_parser($name) invokehidden proc unknown {args} {}
+    $_parser($name) expose error
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: define <protocol> <name> <arglist> <body>
+#
+#  Used to define a command that this handler recognizes.  The command
+#  is called <name> in the safe interpreter associated with the given
+#  <protocol>, which should have been defined previously via the
+#  "protocol" method.  The new command exists with the same name in a
+#  special namespace in the main interpreter.  It is implemented with
+#  an argument list <arglist> and a <body> of Tcl code.
+# ----------------------------------------------------------------------
+itcl::body Handler::define {protocol name arglist body} {
+    if {![info exists _namesp($protocol)]} {
+        error "can't define command \"$name\": protocol \"$protocol\" doesn't exist"
+    }
+    proc [set _namesp($protocol)]::$name $arglist $body
+    $_parser($protocol) alias $name [set _namesp($protocol)]::$name
+    finalize $protocol
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: connectionName <sockId> ?<name>?
+#
+#  Used to set/get the nice name associated with a <sockId> connection.
+#  The nice name is used for log messages, and makes debugging easier
+#  than chasing around a bunch of "sock3" handle names.  If no name
+#  is specified, then it defaults to the file descriptor name.
+# ----------------------------------------------------------------------
+itcl::body Handler::connectionName {cid {name ""}} {
+    if {[string length $name] > 0} {
+        set _cname($cid) $name
+    }
+    if {[info exists _cname($cid)]} {
+        return "$_cname($cid) ($cid)"
+    }
+    return $cid
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: connectionSpeaks <sockId> <protocol>
+#
+#  Used internally to define what protocol the entity on the other
+#  side of the connection speaks.  This is usually invoked when that
+#  entity sends the "protocol" message, and the built-in "protocol"
+#  command in the DEFAULT parser uses this method to register the
+#  protocol for the entity.
+# ----------------------------------------------------------------------
+itcl::body Handler::connectionSpeaks {cid protocol} {
+    if {"DEFAULT" != $protocol && ![info exists _parser($protocol)]} {
+        error "protocol \"$protocol\" not recognized"
+    }
+    set _protocol($cid) $protocol
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: handle <cid>
+#
+#  Invoked automatically whenever a message comes in on the file
+#  handle <cid> from the entity on the other side of the connection.
+#  This handler reads the message and executes it in a safe
+#  interpreter, thereby responding to it.
+# ----------------------------------------------------------------------
+itcl::body Handler::handle {cid} {
+    if {[gets $cid request] < 0} {
+        log system "dropped: [connectionName $cid]"
+        # connection has connection -- forget this entity
+        catch {close $cid}
+        catch {unset _buffer($cid)}
+        catch {unset _protocol($cid)}
+        catch {unset _cname($cid)}
+    } elseif {[info exists _protocol($cid)]} {
+        # complete command? then process it below...
+        append _buffer($cid) $request "\n"
+        if {[info complete $_buffer($cid)]} {
+            set request $_buffer($cid)
+            set _buffer($cid) ""
+
+            # what protocol does this entity speak?
+            set protocol $_protocol($cid)
+
+            # Some commands need to know the identity of the entity
+            # on the other side of the connection.  Save it as a
+            # global variable in the namespace where the protocol
+            # command exists.
+            set [set _namesp($protocol)]::handler $this
+            set [set _namesp($protocol)]::cid $cid
+
+            # execute the incoming command...
+            set mesg " => "
+            if {[catch {$_parser($protocol) eval $request} result] == 0} {
+                if {[string length $result] > 0} {
+                    puts $cid $result
+                    append mesg "ok: $result"
+                }
+            } else {
+                puts $cid [list exception $result]
+                append mesg "exception: $result"
+            }
+            log debug "[handlerType] message from [connectionName $cid]: [string trimright $request \n] $mesg"
+        }
+    }
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: finalize <protocol>
+#
+#  Called whenever a new command is added to the handler.  Updates
+#  the "unknown" command to report a proper usage message (including
+#  all valid keywords) when a bad command is encountered.
+# ----------------------------------------------------------------------
+itcl::body Handler::finalize {protocol} {
+    set p $_parser($protocol)
+    $p hide error
+    $p hide unknown
+    set cmds [lsort [$p invokehidden info commands]]
+    $p expose error
+    $p expose unknown
+
+    $p invokehidden proc unknown {cmd args} [format {
+        error "bad command \"$cmd\": should be %s"
+    } [join $cmds {, }]]
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: handlerType
+#
+#  Returns a descriptive string describing this handler.  Derived
+#  classes override this method to provide their own string.  Used
+#  for debug messages.
+# ----------------------------------------------------------------------
+itcl::body Handler::handlerType {} {
+    return "handler"
+}
Index: trunk/p2p/log.tcl
===================================================================
--- trunk/p2p/log.tcl	(revision 1251)
+++ trunk/p2p/log.tcl	(revision 1251)
@@ -0,0 +1,131 @@
+# ----------------------------------------------------------------------
+#  LIBRARY: logging routines
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+# ----------------------------------------------------------------------
+#  USAGE: log channel <channel> ?on|off?
+#  USAGE: log <channel> <message>
+#  USAGE: log retrieve
+#  USAGE: log clear
+#
+#  Used to handle log messages within this package.  Typical usage
+#  sequence starts with one or more "log channel" statements, which
+#  define a series of message channels and whether they are on or off.
+#  Then, as "log <channel>" statements are encountered within the code,
+#  they are either passed along to the log file or ignored.  At any
+#  point, the contents of the log file can be retrieved by calling
+#  "log retrieve", and it can be cleared by calling "log clear".
+# ----------------------------------------------------------------------
+
+set log_options(tmpdir) "/tmp"
+set log_options(logfile) ""
+set log_options(logfid) ""
+
+proc log {option args} {
+    global log_options log_channels
+
+    switch -- $option {
+        channel {
+            # ----------------------------------------------------------
+            #  HANDLE: log channel
+            # ----------------------------------------------------------
+            if {[llength $args] > 2} {
+                error "wrong # args: should be \"log channel name ?state?\""
+            }
+            set channel [lindex $args 0]
+            if {[llength $args] == 1} {
+                if {[info exists log_channels($channel)]} {
+                    return $log_channels($channel)
+                }
+                return "off"
+            }
+
+            set state [lindex $args 1]
+            if {![string is boolean $state]} {
+                error "bad value \"$state\": should be on/off"
+            }
+            set log_channels($channel) $state
+
+            # make sure the log file is open and ready
+            if {"" == $log_options(logfid)} {
+                log clear
+            }
+            return $log_channels($channel)
+        }
+        retrieve {
+            # ----------------------------------------------------------
+            #  HANDLE: log retrieve
+            # ----------------------------------------------------------
+            if {[llength $args] != 0} {
+                error "wrong # args: should be \"log retrieve\""
+            }
+            if {[string length $log_options(logfile)] == 0} {
+                return ""
+            }
+            if {[catch {
+                close $log_options(logfid)
+                set fid [open $log_options(logfile) r]
+                set info [read $fid]
+                close $fid
+                set log_options(logfid) [open $log_options(logfile) a]
+              } result]} {
+                return "ERROR: $result"
+            }
+            return $info
+        }
+        clear {
+            # ----------------------------------------------------------
+            #  HANDLE: log clear
+            # ----------------------------------------------------------
+            if {[llength $args] != 0} {
+                error "wrong # args: should be \"log clear\""
+            }
+
+            # close any existing file
+            if {"" != $log_options(logfid)} {
+                catch {close $log_options(logfid)}
+                set log_options(logfid) ""
+            }
+
+            # don't have a log file name yet?  then look for a good name
+            if {[string length $log_options(logfile)] == 0} {
+                set counter 0
+                while {[incr counter] < 500} {
+                    set fname [file join $log_options(tmpdir) log[pid].$counter]
+                    if {[catch {
+                        set fid [open $fname w]; close $fid
+                      } result] == 0} {
+                        # success! use this name
+                        set log_options(logfile) $fname
+                        break
+                    }
+                }
+            }
+            if {[string length $log_options(logfile)] == 0} {
+                error "couldn't open log file in directory $log_options(tmpdir)"
+            }
+            set log_options(logfid) [open $log_options(logfile) w]
+            return ""
+        }
+        default {
+            # ----------------------------------------------------------
+            #  HANDLE: log <channel> <message>
+            # ----------------------------------------------------------
+            if {![info exists log_channels($option)] &&
+                  [lsearch {channel retrieve clear} $option] < 0} {
+                error "bad option \"$option\": should be a channel defined by \"log channel\" or one of channel, retrieve, or clear"
+            }
+            if {$log_channels($option)} {
+                if {[llength $args] != 1} {
+                    error "wrong # args: should be \"log chan message\""
+                }
+                set date [clock format [clock seconds] -format "%m/%d/%Y %H:%M:%S"]
+                puts $log_options(logfid) "$date [lindex $args 0]"
+                flush $log_options(logfid)
+            }
+        }
+    }
+}
Index: trunk/p2p/mkindex
===================================================================
--- trunk/p2p/mkindex	(revision 1251)
+++ trunk/p2p/mkindex	(revision 1251)
@@ -0,0 +1,6 @@
+#!/usr/bin/tclsh
+package require Itcl
+if {"" == $argv} {
+    set argv *
+}
+eval auto_mkindex . $argv
Index: trunk/p2p/random.tcl
===================================================================
--- trunk/p2p/random.tcl	(revision 1251)
+++ trunk/p2p/random.tcl	(revision 1251)
@@ -0,0 +1,36 @@
+# ----------------------------------------------------------------------
+#  LIBRARY: randomization routines
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+
+expr srand([clock seconds])
+
+# ----------------------------------------------------------------------
+#  USAGE: randomize <list> ?<pickThisMany>?
+#
+#  Scrambles the elements in a list and returns them in random order.
+#  Given a list of peer connections, for example, this function
+#  scrambles the order so that a "foreach" command can traverse them
+#  in a random order.  If <pickThisMany> is specified, then the list
+#  is truncated after that many random entries.  Instead of randomizing
+#  all 10,000 entries, for example, you can pick the first random 10.
+# ----------------------------------------------------------------------
+proc randomize {entries {pickThisMany -1}} {
+    set rlist ""
+    set rlen [llength $entries]
+    for {set i 0} {$i < $rlen} {incr i} {
+        # if we have the desired number of elements, then quit
+        if {$pickThisMany >= 0 && $i >= $pickThisMany} {
+            break
+        }
+
+        # pick a random element and add it to the return list
+        set nrand [expr {int(rand()*[llength $entries])}]
+        lappend rlist [lindex $entries $nrand]
+        set entries [lreplace $entries $nrand $nrand]
+    }
+    return $rlist
+}
Index: trunk/p2p/server.tcl
===================================================================
--- trunk/p2p/server.tcl	(revision 1251)
+++ trunk/p2p/server.tcl	(revision 1251)
@@ -0,0 +1,123 @@
+# ----------------------------------------------------------------------
+#  LIBRARY: core server capability used for p2p infrastructure
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+package require Itcl
+
+itcl::class Server {
+    inherit Handler
+
+    private variable _port  ;# stores the port that this server listens on
+
+    # name for this server (for log messages)
+    public variable servername "server"
+
+    # this code fragment gets invoked with each new client
+    public variable onconnect ""
+
+    # this code fragment gets invoked when client declares the protocol
+    public variable onprotocol ""
+
+    constructor {port args} {
+        #
+        # Process option switches for the server.
+        #
+        eval configure $args
+
+        #
+        # Start up the server at the specified port.  If the port
+        # number ends with a ?, then search for the first open port
+        # above that.  The actual port can be queried later via the
+        # "port" method.
+        #
+        if {[regexp {^[0-9]+$} $port]} {
+            socket -server [itcl::code $this accept] $port
+            set _port $port
+        } elseif {[regexp {^[0-9]+\?$} $port]} {
+            set pnum [string trimright $port ?]
+            set tries 500
+            while {[incr tries -1] > 0} {
+                if {[catch {socket -server [itcl::code $this accept] $pnum} result]} {
+                    incr pnum
+                } else {
+                    set _port $pnum
+                    break
+                }
+            }
+            if {$tries <= 0} {
+                error "can't find an open port for server at $port"
+            }
+            log system "$servername started at port $_port"
+        }
+    }
+
+    public method port {}
+    public method connectionSpeaks {cid protocol}
+
+    protected method handlerType {}
+
+    private method accept {cid addr port}
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: port
+#
+#  Returns the port number that this server is listening on.  When
+#  the server is first created, this can be set to a hard-coded value,
+#  or to a value followed by a ?.  In that case, the server tries to
+#  find the first open port.  The actual port is reported by this
+#  method.
+# ----------------------------------------------------------------------
+itcl::body Server::port {} {
+    return $_port
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: accept <cid> <addr> <port>
+#
+#  Invoked automatically whenever a client tries to connect to this
+#  server.  The <cid> is the file handle for this client.  The <addr>
+#  and <port> give the address and port number of the incoming client.
+# ----------------------------------------------------------------------
+itcl::body Server::accept {cid addr port} {
+    fileevent $cid readable [itcl::code $this handle $cid]
+    fconfigure $cid -buffering line
+    connectionSpeaks $cid DEFAULT
+    log system "accepted: $addr ($cid)"
+
+    if {[string length $onconnect] > 0} {
+        uplevel #0 [list $onconnect $cid $addr $port]
+    }
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: connectionSpeaks <client> <protocol>
+#
+#  Used internally to define what protocol the entity on the other
+#  side of the connection speaks.  This is usually invoked when that
+#  entity sends the "protocol" message, and the built-in "protocol"
+#  command in the DEFAULT parser uses this method to register the
+#  protocol for the entity.
+# ----------------------------------------------------------------------
+itcl::body Server::connectionSpeaks {cid protocol} {
+    chain $cid $protocol
+
+    # if there's a callback for the protocol change, execute it here
+    if {[string length $onprotocol] > 0} {
+        uplevel #0 [list $onprotocol $cid $protocol]
+    }
+}
+
+# ----------------------------------------------------------------------
+#  USAGE: handlerType
+#
+#  Returns a descriptive string describing this handler.  Derived
+#  classes override this method to provide their own string.  Used
+#  for debug messages.
+# ----------------------------------------------------------------------
+itcl::body Server::handlerType {} {
+    return "server"
+}
Index: trunk/p2p/tclIndex
===================================================================
--- trunk/p2p/tclIndex	(revision 1251)
+++ trunk/p2p/tclIndex	(revision 1251)
@@ -0,0 +1,23 @@
+# Tcl autoload index file, version 2.0
+# This file is generated by the "auto_mkindex" command
+# and sourced to set up indexing information for one or
+# more commands.  Typically each line is a command that
+# sets an element in the auto_index array, where the
+# element name is the name of a command and the value is
+# a script that loads the command.
+
+set auto_index(Handler) [list source [file join $dir handler.tcl]]
+set auto_index(::Handler::protocol) [list source [file join $dir handler.tcl]]
+set auto_index(::Handler::define) [list source [file join $dir handler.tcl]]
+set auto_index(::Handler::connectionSpeaks) [list source [file join $dir handler.tcl]]
+set auto_index(::Handler::handle) [list source [file join $dir handler.tcl]]
+set auto_index(::Handler::finalize) [list source [file join $dir handler.tcl]]
+set auto_index(Server) [list source [file join $dir server.tcl]]
+set auto_index(::Server::port) [list source [file join $dir server.tcl]]
+set auto_index(::Server::accept) [list source [file join $dir server.tcl]]
+set auto_index(::Server::connectionSpeaks) [list source [file join $dir server.tcl]]
+set auto_index(Client) [list source [file join $dir client.tcl]]
+set auto_index(::Client::send) [list source [file join $dir client.tcl]]
+set auto_index(::Client::address) [list source [file join $dir client.tcl]]
+set auto_index(log) [list source [file join $dir log.tcl]]
+set auto_index(randomize) [list source [file join $dir random.tcl]]
Index: trunk/p2p/test.tcl
===================================================================
--- trunk/p2p/test.tcl	(revision 1251)
+++ trunk/p2p/test.tcl	(revision 1251)
@@ -0,0 +1,556 @@
+# ----------------------------------------------------------------------
+#  TEST HARNESS for the P2P infrastructure
+#
+#  This script drives the test setup and visualization for the P2P
+#  infrastructure.  It launches the authority server(s) and various
+#  workers, and helps to visualize their interactions.
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+package require Itcl
+
+# recognize other library files in this same directory
+set dir [file dirname [info script]]
+lappend auto_path $dir
+
+set time0 [clock seconds]
+set processes ""
+set nodes(all) ""
+set nodeRadius 15
+
+# ======================================================================
+#  SHAPES
+# ======================================================================
+itcl::class Shape {
+    private variable _canvas ""      ;# shape sits on this canvas
+    private variable _ranges ""      ;# list of time ranges for shape
+    private common _shapesOnCanvas   ;# maps canvas => list of shapes
+
+    public variable command ""  ;# command template used to create shape
+
+    constructor {canvas args} {
+        # add this shape to the list of shapes on this canvas
+        lappend _shapesOnCanvas($canvas) $this
+        set _canvas $canvas
+        eval configure $args
+    }
+    destructor {
+        # remove this shape from the list of shapes on the canvas
+        set i [lsearch $_shapesOnCanvas($_canvas) $this]
+        if {$i >= 0} {
+            set _shapesOnCanvas($_canvas) \
+                [lreplace $_shapesOnCanvas($_canvas) $i $i]
+        }
+    }
+
+    # ------------------------------------------------------------------
+    #  METHOD: addRange <time0> <time1>
+    #  Declares that this shape exists during the given time range
+    #  between <time0> and <time1>.
+    # ------------------------------------------------------------------
+    public method addRange {t0 t1} {
+        # see if there's any overlap with existing ranges
+        set ri0 -1
+        set ri1 -1
+        for {set i 0} {$i < [llength $_ranges]} {incr i} {
+            set pair [lindex $_ranges $i]
+            foreach {r0 r1} $pair break
+            if {$r0 >= $t0 && $r0 <= $t1} {
+                set ri0 $i
+            }
+            if {$r1 >= $t0 && $r1 <= $t1} {
+                set ri1 $i
+            }
+            incr i
+        }
+
+        if {$ri0 < 0 && $ri1 < 1} {
+            # doesn't overlap with anything -- insert in right place
+            for {set i 0} {$i < [llength $_ranges]} {incr i} {
+                set pair [lindex $_ranges $i]
+                foreach {r0 r1} $pair break
+                if {$t0 < $r0} break
+            }
+            set _ranges [linsert $_ranges $i [list $t0 $t1]]
+        } elseif {$ri0 >= 0 && $ri1 >= 0} {
+            # overlaps on both limits -- bridge the middle part
+            set r0 [lindex [lindex $_ranges $ri0] 0]
+            set r1 [lindex [lindex $_ranges $ri1] 1]
+            set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] 
+        } elseif {$ri0 >= 0} {
+            # overlaps on the lower limit
+            for {set i [expr {[llength $_ranges]-1}]} {$i >= 0} {incr i -1} {
+                set pair [lindex $_ranges $i]
+                foreach {r0 r1} $pair break
+                if {$r0 > $t0 && $r1 < $t1} {
+                    # remove any ranges completely contained in this one
+                    set _ranges [lreplace $_ranges $i $i] 
+                }
+                set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] 
+            }
+            set pair [lindex $_ranges $ri0]
+            foreach {r0 r1} $pair break
+            set _ranges [lreplace $_ranges $ri0 $ri0 [list $r0 $t1]] 
+        } else {
+            # overlaps on the upper limit
+            for {set i [expr {[llength $_ranges]-1}]} {$i >= 0} {incr i -1} {
+                set pair [lindex $_ranges $i]
+                foreach {r0 r1} $pair break
+                if {$r0 > $t0 && $r1 < $t1} {
+                    # remove any ranges completely contained in this one
+                    set _ranges [lreplace $_ranges $i $i] 
+                }
+                set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] 
+            }
+            set pair [lindex $_ranges $ri1]
+            foreach {r0 r1} $pair break
+            set _ranges [lreplace $_ranges $ri1 $ri1 [list $t0 $r1]] 
+        }
+    }
+
+    # ------------------------------------------------------------------
+    #  METHOD: exists <time>
+    #  Checks to see if this shape exists at the given <time>.
+    #  Returns 1 if so, and 0 otherwise.
+    # ------------------------------------------------------------------
+    public method exists {t} {
+        for {set i 0} {$i < [llength $_ranges]} {incr i} {
+            set pair [lindex $_ranges $i]
+            foreach {r0 r1} $pair break
+            if {$t >= $r0 && $t <= $r1} {
+                return 1
+            }
+        }
+        return 0
+    }
+
+    # ------------------------------------------------------------------
+    #  PROC: draw <canvas> <time>
+    #  Finds the list of shapes that exist on the given <canvas> at
+    #  the specified time, and executes all of their associated
+    #  -command templates, adding them to the canvas.
+    # ------------------------------------------------------------------
+    public proc draw {canvas time} {
+        if {[info exists _shapesOnCanvas($canvas)]} {
+            foreach obj $_shapesOnCanvas($canvas) {
+                if {[$obj exists $time]} {
+                    set cmd [$obj cget -command]
+                    regsub -all %c $cmd $canvas cmd
+                    eval $cmd
+                }
+            }
+        }
+    }
+
+    # ------------------------------------------------------------------
+    #  PROC: clear <canvas>
+    #  Removes all shapes associated with the specified <canvas>.
+    # ------------------------------------------------------------------
+    public proc clear {canvas} {
+        if {[info exists _shapesOnCanvas($canvas)]} {
+            eval itcl::delete object $_shapesOnCanvas($canvas)
+        }
+    }
+}
+
+# ======================================================================
+#  Build the main interface
+# ======================================================================
+frame .cntls
+pack .cntls -fill x
+
+button .cntls.start -text "Start" -command test_start
+pack .cntls.start -side left -padx 4 -pady 2
+
+button .cntls.stop -text "Stop" -command test_stop -state disabled
+pack .cntls.stop -side left -padx 4 -pady 2
+
+button .cntls.reload -text "Reload" -command test_reload
+pack .cntls.reload -side left -padx 4 -pady 2
+
+button .cntls.layout -text "New Layout" -command {
+    foreach key [array names nodes *-\[xy\]] {
+        unset nodes($key)
+    }
+    after idle test_reload
+}
+pack .cntls.layout -side left -padx 4 -pady 2
+
+frame .player
+pack .player -side bottom -fill x
+
+button .player.back -text "<" -command {test_frame_go -1 nudge}
+pack .player.back -side left -padx 4 -pady 2
+
+button .player.fwd -text ">" -command {test_frame_go 1 nudge}
+pack .player.fwd -side left -padx 4 -pady 2
+
+scale .player.scale -label "Frame" -orient horizontal \
+    -from 0 -to 1 -showvalue 0 -command {test_frame_go 1}
+pack .player.scale -side left -expand yes -fill x -padx 4 -pady 2
+
+frame .view
+pack .view -side bottom -anchor w
+label .view.show -text "Show:"
+grid .view.show -row 0 -column 0 -sticky e
+radiobutton .view.network -text "P2P Network" -variable view -value network -command test_view_change
+grid .view.network -row 0 -column 1 -sticky w
+radiobutton .view.traffic -text "Network traffic" -variable view -value traffic -command test_view_change
+grid .view.traffic -row 1 -column 1 -sticky w
+
+frame .diagram
+pack .diagram -expand yes -fill both
+canvas .diagram.network -width 500 -height 400
+canvas .diagram.traffic -width 500 -height 400
+
+after idle .view.traffic invoke
+
+proc test_stop {} {
+    global processes
+
+    # kill any existing processes
+    foreach job $processes {
+        exec kill $job
+    }
+    set processes ""
+
+    .cntls.stop configure -state disabled
+    .cntls.start configure -state normal
+
+    after idle test_reload
+}
+
+proc test_start {} {
+    global processes
+
+    # clean up existing log files...
+    foreach fname [glob -nocomplain /tmp/log*] {
+        file delete $fname
+    }
+
+    # launch a new authority server
+    lappend processes [exec tclsh authority.tcl &]
+
+    # launch a series of workers
+    for {set i 0} {$i < 20} {incr i} {
+        lappend processes [exec tclsh worker.tcl &]
+        after [expr {int(rand()*5000)}]
+    }
+
+    .cntls.start configure -state disabled
+    .cntls.stop configure -state normal
+}
+
+proc test_reload {} {
+    global time0 nodes actions nodeRadius
+
+    array set colors {
+        authority blue
+        worker gray
+    }
+
+    Shape::clear .diagram.network
+    Shape::clear .diagram.traffic
+    set tmax 0
+
+    #
+    # Scan through all files and generate positions for all nodes.
+    #
+    foreach fname [glob -nocomplain /tmp/log*] {
+        set fid [open $fname r]
+        set info [read $fid]
+        close $fid
+
+        # get the address for this host
+        regexp {started at port ([0-9]+)} $info match port
+        if {[regexp {options [^\n]+ ip ([^ ]+)} $info match ip]} {
+            set addr $ip:$port
+        } else {
+            set addr 127.0.0.1:$port
+        }
+
+        set lasttime ""
+        set info [split $info \n]
+        set first [lindex $info 0]
+        regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) +(authority|worker)} $first match t0 type
+        set t0val [expr {([clock scan $t0]-$time0)*100}]
+
+        set last [lindex $info end-1]
+        regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+)} $last match t1
+        set t1val [expr {([clock scan $t1]-$time0)*100 + 99}]
+        set margin 20
+        set r $nodeRadius
+
+        set nodes($fname) $addr
+        set nodes($addr-log) $fname
+        set nodes($addr-type) $type
+        if {![info exists nodes($addr-x)]} {
+            set w [expr {[winfo width .diagram]-2*$margin}]
+            set h [expr {[winfo height .diagram]-2*$margin}]
+            set nodes($addr-x) [expr {int(rand()*$w) + $margin}]
+            set nodes($addr-y) [expr {int(rand()*$h) + $margin}]
+        }
+        set x $nodes($addr-x)
+        set y $nodes($addr-y)
+
+        foreach canv {.diagram.traffic .diagram.network} {
+            set s [Shape ::#auto $canv -command \
+                [list %c create oval [expr {$x-$r}] [expr {$y-$r}] \
+                [expr {$x+$r}] [expr {$y+$r}] \
+                -outline black -fill $colors($type) \
+                -tags [list $fname $fname-node]]]
+            $s addRange $t0val $t1val
+        }
+
+        append actions($t0val) "$type $addr online\n"
+        append actions($t1val) "$type $addr offline\n"
+
+        if {$t1val > $tmax} { set tmax $t1val }
+    }
+                
+    #
+    # Scan through files again and generate shapes for all messages
+    #
+    foreach fname [glob -nocomplain /tmp/log*] {
+        set fid [open $fname r]
+        set info [read $fid]
+        close $fid
+puts "\nscanning $fname"
+
+        catch {unset started}
+        set peerlist(addrs) ""
+        set peerlist(time) 0
+        set lasttime ""
+        set counter 0
+        foreach line [split $info \n] {
+            if {[regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) (.+)$} $line match time mesg]} {
+                set tval [expr {([clock scan $time]-$time0)*100}]
+
+                if {$time == $lasttime} {
+                    set tval [expr {$tval + [incr counter]}]
+                }
+                set lasttime $time
+
+                if {$tval > $tmax} { set tmax $tval }
+
+                if {[regexp {accepted: +([^ ]+) +\((.+)\)} $mesg match addr cid]} {
+                    append actions($tval) $mesg \n
+                    set started(connect$cid-time) $tval
+                    set started(connect$cid-addr) ?
+
+                } elseif {[regexp {dropped: +([^ ]+) +\((.+)\)} $mesg match addr cid] && [info exists started(connect$cid-time)]} {
+                    append actions($tval) $mesg \n
+                    set from $nodes($fname)
+                    set x0 $nodes($from-x)
+                    set y0 $nodes($from-y)
+                    set x1 $nodes($addr-x)
+                    set y1 $nodes($addr-y)
+                    set s [Shape ::#auto .diagram.traffic -command \
+                        [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]]
+                    $s addRange $started(connect$cid-time) $tval
+
+                    unset started(connect$cid-time)
+                    unset started(connect$cid-addr)
+
+                } elseif {[regexp {server message from ([a-zA-Z0-9\.]+:[0-9]+) \(([a-z0-9]+)\): +(.+) => (.*)} $mesg match addr cid cmd result]} {
+                    if {![string match identity* $cmd]} {
+                        append actions($tval) $mesg \n
+                        set from $nodes($fname)
+                        set x0 $nodes($from-x)
+                        set y0 $nodes($from-y)
+                        set x1 $nodes($addr-x)
+                        set y1 $nodes($addr-y)
+                        set w [expr {[winfo width .diagram]/2}]
+
+                        set s [Shape ::#auto .diagram.traffic -command \
+                            [list %c create line [expr $x0-3] [expr $y0-3] [expr $x1-3] [expr $y1-3] -fill black -arrow first -tags transient]]
+                        $s addRange $tval $tval
+
+                        set s [Shape ::#auto .diagram.traffic -command \
+                            [list %c create text [expr {0.5*($x0+$x1)}] [expr {0.5*($y0+$y1)-1}] -width $w -fill black -anchor s -text $cmd -tags transient]]
+                        $s addRange $tval $tval
+
+                        if {"" != [string trim $result]} {
+                            if {[regexp {^ok:} $result]} {
+                                set color black
+                            } else {
+                                set color red
+                            }
+                            set s [Shape ::#auto .diagram.traffic -command \
+                                [list %c create line [expr $x0+3] [expr $y0+3] [expr $x1+3] [expr $y1+3] -fill $color -arrow last -tags transient]]
+                            $s addRange $tval $tval
+
+                            set s [Shape ::#auto .diagram.traffic -command \
+                                [list %c create text [expr {0.5*($x0+$x1)}] [expr {0.5*($y0+$y1)+1}] -width $w -fill $color -anchor n -text $result -tags transient]]
+                            $s addRange $tval $tval
+                        }
+                    }
+
+                    # no address for this client yet?  then save this info
+                    if {[info exists started(connect$cid-addr)]
+                           && $started(connect$cid-addr) == "?"} {
+                        set started(connect$cid-addr) $addr
+                    }
+
+                } elseif {[regexp {connected to peers: (.*)} $mesg match plist]} {
+                    # draw a highlight ring, indicating that peers have changed
+                    set from $nodes($fname)
+                    set x $nodes($from-x)
+                    set y $nodes($from-y)
+                    foreach canv {.diagram.traffic .diagram.network} {
+                        set s [Shape ::#auto $canv -command \
+                            [list %c create oval [expr {$x-$r-3}] [expr {$y-$r-3}] [expr {$x+$r+3}] [expr {$y+$r+3}] -outline red -fill "" -tags transient]]
+                        $s addRange $tval [expr {$tval+20}]
+                    }
+
+                    # draw lines from the previous peer list, now that
+                    # we know it's time range is done.
+                    foreach addr $peerlist(addrs) {
+                        set from $nodes($fname)
+                        set x0 $nodes($from-x)
+                        set y0 $nodes($from-y)
+                        set x1 $nodes($addr-x)
+                        set y1 $nodes($addr-y)
+                        set s [Shape ::#auto .diagram.network -command \
+                            [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]]
+                        $s addRange $peerlist(time) $tval
+                    }
+
+                    # save the start of this new peer list
+                    set peerlist(addrs) $plist
+                    set peerlist(time) $tval
+                }
+            }
+        }
+
+        # any connections hanging out that we haven't drawn?
+        foreach key [array names started connect*-addr] {
+            regexp {connect([^-]+)-addr} $key match cid
+            set from $nodes($fname)
+            set addr $started($key)
+            set x0 $nodes($from-x)
+            set y0 $nodes($from-y)
+            set x1 $nodes($addr-x)
+            set y1 $nodes($addr-y)
+            set s [Shape ::#auto .diagram.traffic -command \
+                [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]]
+            $s addRange $started(connect$cid-time) $tval
+
+            unset started(connect$cid-time)
+            unset started(connect$cid-addr)
+        }
+
+        .diagram.traffic bind $fname <Enter> "
+            %W itemconfigure $fname-node -outline red
+            %W itemconfigure $fname-cnx -fill red
+            %W raise $fname-cnx
+        "
+        .diagram.traffic bind $fname <Leave> "
+            %W itemconfigure $fname-node -outline black
+            %W itemconfigure $fname-cnx -fill gray
+            %W raise transient
+        "
+
+        foreach canv {.diagram.network .diagram.traffic} {
+            $canv bind $fname-node <ButtonPress-1> \
+                [list worker_node_click %W $fname %x %y]
+            $canv bind $fname-node <B1-Motion> \
+                [list worker_node_drag %W $fname %x %y]
+            $canv bind $fname-node <ButtonRelease-1> \
+                [list worker_node_release %W $fname %x %y]
+        }
+
+        # any peer connections that we haven't drawn?  then do it now
+        foreach addr $peerlist(addrs) {
+            set from $nodes($fname)
+            set x0 $nodes($from-x)
+            set y0 $nodes($from-y)
+            set x1 $nodes($addr-x)
+            set y1 $nodes($addr-y)
+            set s [Shape ::#auto .diagram.network -command \
+                [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]]
+            $s addRange $peerlist(time) $tmax
+        }
+
+        .diagram.network bind $fname <Enter> "
+            %W itemconfigure $fname-node -outline red
+            %W itemconfigure $fname-cnx -fill red
+            %W raise $fname-cnx
+        "
+        .diagram.network bind $fname <Leave> "
+            %W itemconfigure $fname-node -outline black
+            %W itemconfigure $fname-cnx -fill gray
+            %W raise transient
+        "
+    }
+    .player.scale configure -to $tmax
+
+    after cancel test_visualize
+    after idle test_visualize
+}
+
+proc worker_node_click {canv fname x y} {
+    $canv itemconfigure $fname-node -stipple gray50
+}
+
+proc worker_node_drag {canv fname x y} {
+    global nodeRadius
+    $canv itemconfigure $fname-node -stipple ""
+    $canv coords $fname-node [expr {$x-$nodeRadius}] [expr {$y-$nodeRadius}] [expr {$x+$nodeRadius}] [expr {$y+$nodeRadius}]
+}
+
+proc worker_node_release {canv fname x y} {
+    global move nodes
+
+    worker_node_drag $canv $fname $x $y
+    $canv itemconfigure $fname-node -stipple ""
+
+    set addr $nodes($fname)
+    set nodes($addr-x) $x
+    set nodes($addr-y) $y
+    after idle test_reload
+}
+
+proc test_frame_go {dir position} {
+    global actions
+
+    set tmax [.player.scale cget -to]
+    if {"nudge" == $position} {
+        set nframe [.player.scale get]
+        incr nframe $dir
+    } else {
+        set nframe $position
+    }
+
+    while {![info exists actions($nframe)] && $nframe > 0 && $nframe < $tmax} {
+        incr nframe $dir
+    }
+
+    # set the scale to this new position
+    .player.scale configure -command ""
+    .player.scale set $nframe
+    .player.scale configure -command {test_frame_go 1}
+
+    after cancel test_visualize
+    after idle test_visualize
+}
+
+proc test_visualize {} {
+    .diagram.traffic delete all
+    Shape::draw .diagram.traffic [.player.scale get]
+    .diagram.traffic raise transient
+
+    .diagram.network delete all
+    Shape::draw .diagram.network [.player.scale get]
+    .diagram.network raise transient
+}
+
+proc test_view_change {} {
+    global view
+    foreach widget [pack slaves .diagram] {
+        catch {pack forget $widget}
+    }
+    pack .diagram.$view -expand yes -fill both
+}
Index: trunk/p2p/worker.tcl
===================================================================
--- trunk/p2p/worker.tcl	(revision 1251)
+++ trunk/p2p/worker.tcl	(revision 1251)
@@ -0,0 +1,390 @@
+# ----------------------------------------------------------------------
+#  P2P: worker node in P2P mesh bidding on and executing jobs
+#
+#  This server is a typical worker node in the P2P mesh for HUBzero
+#  job execution.  It talks to other workers to distribute the load
+#  of job requests.  It bids on jobs based on its current resources
+#  and executes jobs to earn points from the central authority.
+# ----------------------------------------------------------------------
+#  Michael McLennan (mmclennan@purdue.edu)
+# ======================================================================
+#  Copyright (c) 2008  Purdue Research Foundation
+# ======================================================================
+
+# recognize other library files in this same directory
+set dir [file dirname [info script]]
+lappend auto_path $dir
+
+# handle log file for this worker
+log channel debug on
+log channel system on
+
+# set up a server at the first open port above 9101
+set server [Server ::#auto 9101? -servername worker \
+    -onprotocol worker_peers_protocol]
+
+# ======================================================================
+#  OPTIONS
+#  These options get the worker started, but new option settings
+#  some from the authority after this worker first connects.
+# ======================================================================
+set authority ""     ;# file handle for authority connection
+set myaddress "?:?"  ;# address/port for this worker
+
+# set of connections for authority servers
+set options(authority_hosts) 127.0.0.1:9001
+
+# register with the central authority at this frequency
+set options(time_between_registers) 10000
+
+# this worker should try to connect with this many other peers
+set options(max_peer_connections) 4
+
+# ======================================================================
+#  PEERS
+# ======================================================================
+# eventually set to the list of all peers in the network
+set peers(all) ""
+
+# list of peers that we're testing connections with
+set peers(testing) ""
+
+# ======================================================================
+#  PROTOCOL: hubzero:peer/1
+#  This protocol gets used when another worker connects to this one.
+# ======================================================================
+$server protocol hubzero:peer/1
+
+$server define hubzero:peer/1 exception {message} {
+    log system "ERROR: $message"
+}
+
+# ----------------------------------------------------------------------
+#  DIRECTIVE: identity
+#  Used for debugging, so that each client can identify itself by
+#  name to this worker.
+# ----------------------------------------------------------------------
+$server define hubzero:peer/1 identity {name} {
+    variable cid
+    variable handler
+    $handler connectionName $cid $name
+    return ""
+}
+
+# ----------------------------------------------------------------------
+#  DIRECTIVE: ping
+# ----------------------------------------------------------------------
+$server define hubzero:peer/1 ping {} {
+    return "pong"
+}
+
+# ======================================================================
+#  PROTOCOL: hubzero:worker/1
+#  The authority_connect procedure connects this worker to an authority
+#  and begins the authority/worker protocol.  The directives below
+#  handle the incoming (authority->worker) traffic.
+# ======================================================================
+proc authority_connect {} {
+    global authority options
+    log system "connecting to authorities..."
+
+    authority_disconnect
+
+    # scan through list of authorities and try to connect
+    foreach addr [randomize $options(authority_hosts)] {
+        if {[catch {Client ::#auto $addr} result] == 0} {
+            set authority $result
+            break
+        }
+    }
+
+    if {"" == $authority} {
+        error "can't connect to any known authorities"
+    }
+
+    # add handlers to process the incoming commands...
+    $authority protocol hubzero:worker/1
+    $authority define hubzero:worker/1 exception {args} {
+        log system "error from authority: $args"
+    }
+
+    # ------------------------------------------------------------------
+    #  DIRECTIVE: options <key1> <value1> <key2> <value2> ...
+    #  These option settings coming from the authority override the
+    #  option settings built into the client at the top of this
+    #  script.  The authority probably has a more up-to-date list
+    #  of other authorities and better policies for living within
+    #  the network.
+    # ------------------------------------------------------------------
+    $authority define hubzero:worker/1 options {args} {
+        global options server myaddress
+
+        array set options $args
+
+        if {[info exists options(ip)]} {
+            set myaddress $options(ip):[$server port]
+            log debug "my address $myaddress"
+        }
+        return ""
+    }
+
+    # ------------------------------------------------------------------
+    #  DIRECTIVE: peers <listOfAddresses>
+    #  This message comes in after this worker has sent the "peers"
+    #  message to request the current list of peers.  The
+    #  <listOfAddresses> is a list of host:port addresses that this
+    #  worker should contact to enter the p2p network.
+    # ------------------------------------------------------------------
+    $authority define hubzero:worker/1 peers {plist} {
+        global peers
+        set peers(all) $plist
+        after idle worker_peers_update
+
+        # now that we've gotten the peers, we're done with the authority
+        authority_disconnect
+    }
+
+    # ------------------------------------------------------------------
+    #  DIRECTIVE: identity
+    #  Used for debugging, so that each client can identify itself by
+    #  name to this worker.
+    # ------------------------------------------------------------------
+    $authority define hubzero:worker/1 identity {name} {
+        variable cid
+        variable handler
+        $handler connectionName $cid $name
+        return ""
+    }
+
+    $authority send "protocol hubzero:worker/1"
+    return $authority
+}
+
+proc authority_disconnect {} {
+    global authority
+    if {"" != $authority} {
+        catch {itcl::delete object $authority}
+        set authority ""
+    }
+}
+
+# ======================================================================
+#  USEFUL ROUTINES
+# ======================================================================
+# ----------------------------------------------------------------------
+#  COMMAND:  worker_register
+#
+#  Invoked when this worker first starts up and periodically thereafter
+#  to register the worker with the central authority, and to request
+#  a list of peers that this peer can talk to.
+# ----------------------------------------------------------------------
+proc worker_register {} {
+    global options server
+
+    # connect to the authority and request a list of peers
+    if {[catch {
+        set client [authority_connect]
+        $client send "listening [$server port]"
+        $client send "peers"
+    } result]} {
+        log system "ERROR: $result"
+    }
+
+    # register again at regular intervals in case the authority
+    # gets restarted in between.
+    after $options(time_between_registers) worker_register
+}
+
+# ----------------------------------------------------------------------
+#  COMMAND:  worker_peers_update
+#
+#  Invoked when this worker has received a list of peers, and from
+#  time to time thereafter, to establish connections with other peers
+#  in the network.  This worker picks a number of peers randomly from
+#  the list of all available peers, and then pings each of them.
+#  Timing results from the pings are stored away, and when all pings
+#  have completed, this worker picks the best few connections and
+#  keeps those.
+# ----------------------------------------------------------------------
+proc worker_peers_update {} {
+    global options peers myaddress
+    worker_peers_cleanup
+
+    #
+    # Pick a random group of peers and try to connect to them.
+    # Start with the existing peers, and then add a random
+    # bunch of others.
+    #
+    foreach key [array names peers current-*] {
+        set peer $peers($key)
+        lappend peers(testing) $peer
+    }
+
+    #
+    # Pick other peers at random.  We don't have to try all
+    # peers--just some number that is much larger than the
+    # final number we want to talk to.
+    #
+    set ntest [expr {10 * $options(max_peer_connections)}]
+    foreach addr [randomize $peers(all) $ntest] {
+        if {$addr == $myaddress} {
+            continue
+        }
+        if {![info exists peers(current-$addr)]
+              && [catch {Client ::#auto $addr} peer] == 0} {
+            # open a new connection to this address
+            lappend peers(testing) $peer
+            $peer protocol hubzero:peer/1
+
+            $peer define hubzero:peer/1 exception {message} {
+                log system "ERROR: $message"
+            }
+
+            $peer define hubzero:peer/1 identity {name} {
+                variable cid
+                variable handler
+                $handler connectionName $cid $name
+                return ""
+            }
+
+            # when we get a "pong" back, store the latency
+            $peer define hubzero:peer/1 pong {} {
+                global peers
+                variable handler
+puts "  pong from $handler"
+                set now [clock clicks -milliseconds]
+                set delay [expr {$now - $peers(ping-$handler-start)}]
+                set peers(ping-$handler-latency) $delay
+                incr peers(responses)
+                worker_peers_finalize
+                return ""
+            }
+
+            # start the ping/pong session with the peer
+            $peer send "protocol hubzero:peer/1"
+
+            # send tell this peer our name (for debugging)
+            if {[log channel debug]} {
+                $peer send "identity $myaddress"
+            }
+        }
+    }
+
+    #
+    # Now, loop through all peers and send a "ping" message.
+    #
+    foreach peer $peers(testing) {
+puts "pinging $peer = [$peer address]..."
+        # mark the time and send a ping to this peer
+        set peers(ping-$peer-start) [clock clicks -milliseconds]
+        $peer send "ping"
+    }
+
+    # if this test takes too long, just give up
+    after 10000 worker_peers_finalize -force
+}
+
+# ----------------------------------------------------------------------
+#  COMMAND:  worker_peers_finalize ?-force?
+#
+#  Called after worker_peers_update has finished its business to
+#  clean up all of the connections that were open for testing.
+# ----------------------------------------------------------------------
+proc worker_peers_finalize {{option -check}} {
+    global peers options
+    if {$option == "-force" || $peers(responses) == [llength $peers(testing)]} {
+        # build a list:  {peer latency} {peer latency} ...
+        set plist ""
+        foreach obj $peers(testing) {
+            if {[info exists peers(ping-$obj-latency)]} {
+                lappend plist [list $obj $peers(ping-$obj-latency)]
+            }
+        }
+puts "-------------------\nFINALIZING $::myaddress"
+puts "PINGS: $plist"
+
+        # sort the list and extract the top peers
+        set plist [lsort -increasing -index 1 $plist]
+        set plist [lrange $plist 0 [expr {$options(max_peer_connections)-1}]]
+puts "TOP: $plist"
+
+        set current [array names peers current-*]
+puts "  current: $current"
+
+        # transfer the top peers to the "current" list
+        set all ""
+        foreach rec $plist {
+            set peer [lindex $rec 0]
+            set addr [$peer address]
+            set peers(current-$addr) $peer
+            lappend all $addr
+
+            # if it is already on the "current" list, then keep it
+            set i [lsearch $current current-$addr]
+            if {$i >= 0} {
+                set current [lreplace $current $i $i]
+            }
+            set i [lsearch $peers(testing) $peer]
+            if {$i >= 0} {
+                set peers(testing) [lreplace $peers(testing) $i $i]
+            }
+        }
+        log system "connected to peers: $all"
+puts "  new current: [array names peers current-*]"
+puts "  final: $all"
+puts "  leftover: $current $peers(testing)"
+
+        # get rid of old peers that we no longer want to talk to
+        foreach leftover $current {
+            itcl::delete object $peers($leftover)
+            unset peers($leftover)
+puts "  cleaned up $leftover (was on current list)"
+        }
+
+        # clean up after this test
+        worker_peers_cleanup
+    }
+}
+
+# ----------------------------------------------------------------------
+#  COMMAND:  worker_peers_cleanup
+#
+#  Called after worker_peers_update has finished its business to
+#  clean up all of the connections that were open for testing.
+# ----------------------------------------------------------------------
+proc worker_peers_cleanup {} {
+    global peers
+    foreach obj $peers(testing) {
+        catch {itcl::delete object $obj}
+puts "  cleaned up $obj (was on testing list)"
+    }
+    set peers(testing) ""
+
+    foreach key [array names peers ping-*] {
+        unset peers($key)
+    }
+    set peers(responses) 0
+
+    after cancel worker_peers_finalize -force
+}
+
+# ----------------------------------------------------------------------
+#  COMMAND:  worker_peers_protocol
+#
+#  Invoked whenever a peer sends their protocol message to this
+#  worker.  Sends the same protocol name back, so the other worker
+#  understands what protocol we're speaking.
+# ----------------------------------------------------------------------
+proc worker_peers_protocol {cid protocol} {
+    if {"DEFAULT" != $protocol} {
+        puts $cid [list protocol $protocol]
+    }
+}
+
+# ======================================================================
+#  Connect to one of the authorities to get a list of peers.  Then,
+#  sit in the event loop and process events.
+# ======================================================================
+after idle worker_register
+log system "starting..."
+vwait main-loop
