source: trunk/p2p/handler.tcl

Last change on this file was 3177, checked in by mmc, 10 years ago

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

File size: 9.2 KB
Line 
1# ----------------------------------------------------------------------
2#  LIBRARY: Handler
3#  Base class for Client and Server.  Handles protocol declarations
4#  for messages received by the handler, and knows how to process
5#  messages.
6# ----------------------------------------------------------------------
7#  Michael McLennan (mmclennan@purdue.edu)
8# ======================================================================
9#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
10#
11#  See the file "license.terms" for information on usage and
12#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13# ======================================================================
14package require Itcl
15
16itcl::class Handler {
17    private variable _namesp    ;# maps protocol name => namespace of cmds
18    private variable _parser    ;# maps protocol name => parser for cmds
19    private variable _buffer    ;# maps connection => cmd buffer
20    private variable _protocol  ;# maps connection => protocol name
21    private variable _cname     ;# maps connection => nice name for debug
22    private common _counter 0
23
24    constructor {args} {
25        #
26        # Define the DEFAULT protocol, which clients/servers use when
27        # they first connect to define the protocol they intend to speak.
28        #
29        protocol DEFAULT
30        define DEFAULT protocol {version} {
31            variable handler
32            variable cid
33            $handler connectionSpeaks $cid $version
34            return ""
35        }
36        define DEFAULT exception {message} {
37            log error "ERROR: $message"
38        }
39
40        eval configure $args
41    }
42
43    destructor {
44        foreach protocol [array names _parser] {
45            interp delete $_parser($protocol)
46        }
47        foreach protocol [array names _namesp] {
48            namespace delete $_namesp($protocol)
49        }
50    }
51
52    public method protocol {name}
53    public method define {protocol name arglist body}
54    public method connections {{protocol *}}
55    public method connectionName {cid {name ""}}
56    public method connectionSpeaks {cid protocol}
57
58    protected method handle {cid}
59    protected method finalize {protocol}
60    protected method dropped {cid}
61}
62
63# ----------------------------------------------------------------------
64#  USAGE: protocol <name>
65#
66#  Used to define a protocol that this client/server recognizes.
67#  A protocol has an associated safe interpreter full of commands
68#  that the client/server recognizes.  When each connection is
69#  established, the other party must declare the  protocol that it
70#  intends to speak up front, so the client/server can select the
71#  appropriate interpreter for all incoming requests.
72# ----------------------------------------------------------------------
73itcl::body Handler::protocol {name} {
74    if {[info exists _namesp($name)]} {
75        error "protocol \"$name\" already defined"
76    }
77    set _namesp($name) "[namespace current]::bodies[incr _counter]"
78    namespace eval $_namesp($name) {}
79    set _parser($name) [interp create -safe]
80    foreach cmd [$_parser($name) eval {info commands}] {
81        $_parser($name) hide $cmd
82    }
83    $_parser($name) invokehidden proc unknown {args} {}
84    $_parser($name) expose error
85}
86
87# ----------------------------------------------------------------------
88#  USAGE: define <protocol> <name> <arglist> <body>
89#
90#  Used to define a command that this handler recognizes.  The command
91#  is called <name> in the safe interpreter associated with the given
92#  <protocol>, which should have been defined previously via the
93#  "protocol" method.  The new command exists with the same name in a
94#  special namespace in the main interpreter.  It is implemented with
95#  an argument list <arglist> and a <body> of Tcl code.
96# ----------------------------------------------------------------------
97itcl::body Handler::define {protocol name arglist body} {
98    if {![info exists _namesp($protocol)]} {
99        error "can't define command \"$name\": protocol \"$protocol\" doesn't exist"
100    }
101    proc [set _namesp($protocol)]::$name $arglist $body
102    $_parser($protocol) alias $name [set _namesp($protocol)]::$name
103    finalize $protocol
104}
105
106# ----------------------------------------------------------------------
107#  USAGE: connections ?<protocol>?
108#
109#  Returns a list of file handles for current connections that match
110#  the glob-style <protocol> pattern.  If no pattern is given, then
111#  it returns all connections.  Each handle can be passed to
112#  connectionName and connectionSpeaks to get more information.
113# ----------------------------------------------------------------------
114itcl::body Handler::connections {{pattern *}} {
115    set rlist ""
116    foreach cid [array names _protocol] {
117        if {[string match $pattern $_protocol($cid)]} {
118            lappend rlist $cid
119        }
120    }
121    return $rlist
122}
123
124# ----------------------------------------------------------------------
125#  USAGE: connectionName <sockId> ?<name>?
126#
127#  Used to set/get the nice name associated with a <sockId> connection.
128#  The nice name is used for log messages, and makes debugging easier
129#  than chasing around a bunch of "sock3" handle names.  If no name
130#  is specified, then it defaults to the file descriptor name.
131# ----------------------------------------------------------------------
132itcl::body Handler::connectionName {cid {name ""}} {
133    if {[string length $name] > 0} {
134        set _cname($cid) $name
135    }
136    if {[info exists _cname($cid)]} {
137        return "$_cname($cid) ($cid)"
138    }
139    return $cid
140}
141
142# ----------------------------------------------------------------------
143#  USAGE: connectionSpeaks <sockId> <protocol>
144#
145#  Used internally to define what protocol the entity on the other
146#  side of the connection speaks.  This is usually invoked when that
147#  entity sends the "protocol" message, and the built-in "protocol"
148#  command in the DEFAULT parser uses this method to register the
149#  protocol for the entity.
150# ----------------------------------------------------------------------
151itcl::body Handler::connectionSpeaks {cid protocol} {
152    if {"DEFAULT" != $protocol && ![info exists _parser($protocol)]} {
153        error "protocol \"$protocol\" not recognized"
154    }
155    set _protocol($cid) $protocol
156}
157
158# ----------------------------------------------------------------------
159#  USAGE: handle <cid>
160#
161#  Invoked automatically whenever a message comes in on the file
162#  handle <cid> from the entity on the other side of the connection.
163#  This handler reads the message and executes it in a safe
164#  interpreter, thereby responding to it.
165# ----------------------------------------------------------------------
166itcl::body Handler::handle {cid} {
167    if {[gets $cid request] < 0} {
168        dropped $cid
169    } elseif {[info exists _protocol($cid)]} {
170        # complete command? then process it below...
171        append _buffer($cid) $request "\n"
172        if {[info complete $_buffer($cid)]} {
173            set request $_buffer($cid)
174            set _buffer($cid) ""
175
176            # what protocol does this entity speak?
177            set protocol $_protocol($cid)
178
179            # Some commands need to know the identity of the entity
180            # on the other side of the connection.  Save it as a
181            # global variable in the namespace where the protocol
182            # command exists.
183            set [set _namesp($protocol)]::handler $this
184            set [set _namesp($protocol)]::cid $cid
185
186            # execute the incoming command...
187            set mesg " => "
188            if {[catch {$_parser($protocol) eval $request} result] == 0} {
189                if {[string length $result] > 0} {
190                    catch {puts $cid $result}
191                    append mesg "ok: $result"
192                }
193            } else {
194                catch {puts $cid [list exception $result]}
195                append mesg "exception: $result"
196            }
197            log debug "incoming message from [connectionName $cid]: [string trimright $request \n] $mesg"
198        }
199    }
200}
201
202# ----------------------------------------------------------------------
203#  USAGE: finalize <protocol>
204#
205#  Called whenever a new command is added to the handler.  Updates
206#  the "unknown" command to report a proper usage message (including
207#  all valid keywords) when a bad command is encountered.
208# ----------------------------------------------------------------------
209itcl::body Handler::finalize {protocol} {
210    set p $_parser($protocol)
211    $p hide error
212    $p hide unknown
213    set cmds [lsort [$p invokehidden info commands]]
214    $p expose error
215    $p expose unknown
216
217    $p invokehidden proc unknown {cmd args} [format {
218        error "bad command \"$cmd\": should be %s"
219    } [join $cmds {, }]]
220}
221
222# ----------------------------------------------------------------------
223#  USAGE: dropped <cid>
224#
225#  Invoked automatically whenever a client connection drops, to
226#  log the event and remove all trace of the client.  Derived classes
227#  can override this method to perform other functions too.
228# ----------------------------------------------------------------------
229itcl::body Handler::dropped {cid} {
230    log system "dropped: [connectionName $cid]"
231
232    # connection has connection -- forget this entity
233    catch {close $cid}
234    catch {unset _buffer($cid)}
235    catch {unset _protocol($cid)}
236    catch {unset _cname($cid)}
237}
Note: See TracBrowser for help on using the repository browser.