source: trunk/p2p/handler.tcl @ 1251

Last change on this file since 1251 was 1251, checked in by mmc, 12 years ago

Added first cut of P2P network for job management. See README in this
directory for details.

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