source: trunk/p2p/server.tcl @ 1723

Last change on this file since 1723 was 1273, checked in by mmc, 14 years ago

Major reorganization of p2p code, and support for solicit/proffer
messages.

File size: 8.6 KB
Line 
1# ----------------------------------------------------------------------
2#  LIBRARY: core server capability used for p2p infrastructure
3# ----------------------------------------------------------------------
4#  Michael McLennan (mmclennan@purdue.edu)
5# ======================================================================
6#  Copyright (c) 2008  Purdue Research Foundation
7#
8#  See the file "license.terms" for information on usage and
9#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10# ======================================================================
11package require Itcl
12
13namespace eval p2p { # forward declaration }
14
15# ======================================================================
16#  USAGE: p2p::server ?-option value -option value ...?
17#
18#  Used to create a new peer-to-peer server object for this program.
19#  Recognizes the following options:
20#    -port ........ port number that the server listens on
21#    -protocols ... list of protocol root names that the server handles
22#               ... any other option supported by Server class
23# ======================================================================
24proc p2p::server {args} {
25    set port "?"
26    set protocols ""
27    set options ""
28    foreach {key val} $args {
29        switch -- $key {
30            -port { set port $val }
31            -protocols { set protocols $val }
32            default { lappend options $key $val }
33        }
34    }
35
36    if {[llength $protocols] == 0} {
37        error "server needs at least one value for -protocols"
38    }
39
40    # create the server
41    set server [eval Server ::#auto $port $options]
42
43    # install the protocols that this server recognizes
44    foreach name $protocols {
45        p2p::protocol::init $server $name
46    }
47    return $server
48}
49
50# ======================================================================
51#  CLASS: Server
52# ======================================================================
53itcl::class Server {
54    inherit Handler
55
56    private variable _port  ;# stores the port that this server listens on
57
58    # name for this server (for log messages)
59    public variable servername "server"
60
61    # this code fragment gets invoked with each new client
62    public variable onconnect ""
63
64    # this code fragment gets invoked when client declares the protocol
65    public variable onprotocol ""
66
67    # this code fragment gets invoked when client drops
68    public variable ondisconnect ""
69
70    constructor {port args} {
71        #
72        # Process option switches for the server.
73        #
74        eval configure $args
75
76        #
77        # Start up the server at the specified port.  If the port
78        # number ends with a ?, then search for the first open port
79        # above that.  The actual port can be queried later via the
80        # "port" method.
81        #
82        if {[regexp {^[0-9]+$} $port]} {
83            socket -server [itcl::code $this accept] $port
84            set _port $port
85        } elseif {[regexp {^[0-9]+\?$} $port]} {
86            set pnum [string trimright $port ?]
87            set tries 500
88            while {[incr tries -1] > 0} {
89                if {[catch {socket -server [itcl::code $this accept] $pnum} result]} {
90                    incr pnum
91                } else {
92                    set _port $pnum
93                    break
94                }
95            }
96            if {$tries <= 0} {
97                error "can't find an open port for server at $port"
98            }
99            log system "$servername started at port $_port"
100        }
101    }
102
103    public method port {}
104    public method broadcast {args}
105    public method connectionSpeaks {cid protocol}
106
107    protected method dropped {cid}
108    protected method handlerType {}
109
110    private method accept {cid addr port}
111}
112
113# ----------------------------------------------------------------------
114#  USAGE: port
115#
116#  Returns the port number that this server is listening on.  When
117#  the server is first created, this can be set to a hard-coded value,
118#  or to a value followed by a ?.  In that case, the server tries to
119#  find the first open port.  The actual port is reported by this
120#  method.
121# ----------------------------------------------------------------------
122itcl::body Server::port {} {
123    return $_port
124}
125
126# ----------------------------------------------------------------------
127#  USAGE: broadcast ?-protocol <name>? ?-avoid <avoidList>? <message>
128#
129#  Sends a <message> to all clients connected to this server.  If a
130#  client address appears on the -avoid list, then that client is
131#  avoided.  If the -protocol is specified, then the message is sent
132#  only to clients who match the glob-style pattern for the protocol
133#  name.
134# ----------------------------------------------------------------------
135itcl::body Server::broadcast {args} {
136    set pattern "*"
137    set avoidList ""
138    set i 0
139    while {$i < [llength $args]} {
140        set option [lindex $args $i]
141        if {[string index $option 0] == "-"} {
142            switch -- $option {
143                -protocol {
144                    set pattern [lindex $args [expr {$i+1}]]
145                    incr i 2
146                }
147                -avoid {
148                    set avoidList [lindex $args [expr {$i+1}]]
149                    incr i 2
150                }
151                -- {
152                    incr i
153                    break
154                }
155                default {
156                    error "bad option \"$option\": should be -avoid, -protocol, or --"
157                }
158            }
159        } else {
160            break
161        }
162    }
163    if {$i != [llength $args]-1} {
164        error "wrong # args: should be \"broadcast ?-protocol pattern? ?-avoid clients? message\""
165    }
166    set message [lindex $args end]
167
168    set nmesgs 0
169    foreach cid [connections $pattern] {
170        set addr [lindex [connectionName $cid] 0]  ;# x.x.x.x (sockN)
171        if {[llength $avoidList] == 0 || [lsearch $avoidList $addr] < 0} {
172puts "  inbound => [connectionName $cid]"
173            if {[catch {puts $cid $message} result] == 0} {
174                incr nmesgs
175            } else {
176                log error "ERROR: broadcast failed for $cid: $result"
177                log error "  (message was $message)"
178            }
179        }
180    }
181    return $nmesgs
182}
183
184# ----------------------------------------------------------------------
185#  USAGE: accept <cid> <addr> <port>
186#
187#  Invoked automatically whenever a client tries to connect to this
188#  server.  The <cid> is the file handle for this client.  The <addr>
189#  and <port> give the address and port number of the incoming client.
190# ----------------------------------------------------------------------
191itcl::body Server::accept {cid addr port} {
192    fileevent $cid readable [itcl::code $this handle $cid]
193    fconfigure $cid -buffering line
194    connectionSpeaks $cid DEFAULT
195    log system "accepted: $addr ($cid)"
196
197    if {[string length $onconnect] > 0} {
198        uplevel #0 [list $onconnect $cid $addr $port]
199    }
200}
201
202# ----------------------------------------------------------------------
203#  USAGE: connectionSpeaks <client> <protocol>
204#
205#  Used internally to define what protocol the entity on the other
206#  side of the connection speaks.  This is usually invoked when that
207#  entity sends the "protocol" message, and the built-in "protocol"
208#  command in the DEFAULT parser uses this method to register the
209#  protocol for the entity.
210# ----------------------------------------------------------------------
211itcl::body Server::connectionSpeaks {cid protocol} {
212    chain $cid $protocol
213
214    # if there's a callback for the protocol change, execute it here
215    if {[string length $onprotocol] > 0} {
216        uplevel #0 [list $onprotocol $cid $protocol]
217    }
218}
219
220# ----------------------------------------------------------------------
221#  USAGE: dropped <cid>
222#
223#  Invoked automatically whenever a client connection drops, to
224#  log the event and remove all trace of the client.  Invokes any
225#  command hook for this server to note the fact that the client
226#  has dropped.
227# ----------------------------------------------------------------------
228itcl::body Server::dropped {cid} {
229    # if there's a callback to handle the drop, execute it here
230    if {[string length $ondisconnect] > 0} {
231        uplevel #0 [list $ondisconnect [connectionName $cid]]
232    }
233
234    # call the base class method to clean up after the client
235    chain $cid
236}
237
238# ----------------------------------------------------------------------
239#  USAGE: handlerType
240#
241#  Returns a descriptive string describing this handler.  Derived
242#  classes override this method to provide their own string.  Used
243#  for debug messages.
244# ----------------------------------------------------------------------
245itcl::body Server::handlerType {} {
246    return "server"
247}
Note: See TracBrowser for help on using the repository browser.