source: trunk/p2p/server.tcl @ 2080

Last change on this file since 2080 was 2080, checked in by mmc, 11 years ago

Part 1 of a major reorganization of content. Moving "instant" to "builder"
and setting up "builder" more like the "gui" part as a package. Moving the
Rappture::object stuff from the builder into the main installation, so it
can be shared by the tester as well. Moving "driver" into gui/scripts
where it belongs. Creating a new "launcher.tcl" script that decides
which of the three parts to launch based on command line options. Still
need to sort out the Makefiles to get this all right...

File size: 8.2 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    private method accept {cid addr port}
109}
110
111# ----------------------------------------------------------------------
112#  USAGE: port
113#
114#  Returns the port number that this server is listening on.  When
115#  the server is first created, this can be set to a hard-coded value,
116#  or to a value followed by a ?.  In that case, the server tries to
117#  find the first open port.  The actual port is reported by this
118#  method.
119# ----------------------------------------------------------------------
120itcl::body Server::port {} {
121    return $_port
122}
123
124# ----------------------------------------------------------------------
125#  USAGE: broadcast ?-protocol <name>? ?-avoid <avoidList>? <message>
126#
127#  Sends a <message> to all clients connected to this server.  If a
128#  client address appears on the -avoid list, then that client is
129#  avoided.  If the -protocol is specified, then the message is sent
130#  only to clients who match the glob-style pattern for the protocol
131#  name.
132# ----------------------------------------------------------------------
133itcl::body Server::broadcast {args} {
134    set pattern "*"
135    set avoidList ""
136    set i 0
137    while {$i < [llength $args]} {
138        set option [lindex $args $i]
139        if {[string index $option 0] == "-"} {
140            switch -- $option {
141                -protocol {
142                    set pattern [lindex $args [expr {$i+1}]]
143                    incr i 2
144                }
145                -avoid {
146                    set avoidList [lindex $args [expr {$i+1}]]
147                    incr i 2
148                }
149                -- {
150                    incr i
151                    break
152                }
153                default {
154                    error "bad option \"$option\": should be -avoid, -protocol, or --"
155                }
156            }
157        } else {
158            break
159        }
160    }
161    if {$i != [llength $args]-1} {
162        error "wrong # args: should be \"broadcast ?-protocol pattern? ?-avoid clients? message\""
163    }
164    set message [lindex $args end]
165
166    set nmesgs 0
167    foreach cid [connections $pattern] {
168        set addr [lindex [connectionName $cid] 0]  ;# x.x.x.x (sockN)
169        if {[llength $avoidList] == 0 || [lsearch $avoidList $addr] < 0} {
170puts "  inbound => [connectionName $cid]"
171            if {[catch {puts $cid $message} result] == 0} {
172                incr nmesgs
173            } else {
174                log error "ERROR: broadcast failed for $cid: $result"
175                log error "  (message was $message)"
176            }
177        }
178    }
179    return $nmesgs
180}
181
182# ----------------------------------------------------------------------
183#  USAGE: accept <cid> <addr> <port>
184#
185#  Invoked automatically whenever a client tries to connect to this
186#  server.  The <cid> is the file handle for this client.  The <addr>
187#  and <port> give the address and port number of the incoming client.
188# ----------------------------------------------------------------------
189itcl::body Server::accept {cid addr port} {
190    fileevent $cid readable [itcl::code $this handle $cid]
191    fconfigure $cid -buffering line
192    connectionSpeaks $cid DEFAULT
193    log system "accepted: $addr ($cid)"
194
195    if {[string length $onconnect] > 0} {
196        uplevel #0 [list $onconnect $cid $addr $port]
197    }
198}
199
200# ----------------------------------------------------------------------
201#  USAGE: connectionSpeaks <client> <protocol>
202#
203#  Used internally to define what protocol the entity on the other
204#  side of the connection speaks.  This is usually invoked when that
205#  entity sends the "protocol" message, and the built-in "protocol"
206#  command in the DEFAULT parser uses this method to register the
207#  protocol for the entity.
208# ----------------------------------------------------------------------
209itcl::body Server::connectionSpeaks {cid protocol} {
210    chain $cid $protocol
211
212    # if there's a callback for the protocol change, execute it here
213    if {[string length $onprotocol] > 0} {
214        uplevel #0 [list $onprotocol $cid $protocol]
215    }
216}
217
218# ----------------------------------------------------------------------
219#  USAGE: dropped <cid>
220#
221#  Invoked automatically whenever a client connection drops, to
222#  log the event and remove all trace of the client.  Invokes any
223#  command hook for this server to note the fact that the client
224#  has dropped.
225# ----------------------------------------------------------------------
226itcl::body Server::dropped {cid} {
227    # if there's a callback to handle the drop, execute it here
228    if {[string length $ondisconnect] > 0} {
229        uplevel #0 [list $ondisconnect [connectionName $cid]]
230    }
231
232    # call the base class method to clean up after the client
233    chain $cid
234}
Note: See TracBrowser for help on using the repository browser.