source: trunk/p2p/server.tcl @ 4503

Last change on this file since 4503 was 3177, checked in by mmc, 8 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

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) 2004-2012  HUBzero Foundation, LLC
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.