/[cvs]/nfo/perl/libs/RPC/XML/SessionServer.pm
ViewVC logotype

Contents of /nfo/perl/libs/RPC/XML/SessionServer.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Apr 9 07:53:35 2003 UTC (21 years, 6 months ago) by joko
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +2 -0 lines
minor namespace update

1 package RPC::XML::SessionServer;
2
3 use strict;
4 use warnings;
5
6 use base qw( RPC::XML::Server );
7
8
9 use Data::Dumper;
10 use shortcuts qw( make_guid );
11
12 sub dispatch
13 {
14 my ($self, $xml) = @_;
15
16 my ($reqobj, @data, $response, $name, $meth);
17
18 if (ref($xml) eq 'SCALAR')
19 {
20 $reqobj = $self->{__parser}->parse($$xml);
21 return RPC::XML::response
22 ->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj"))
23 unless (ref $reqobj);
24 }
25 elsif (ref($xml) eq 'ARRAY')
26 {
27 # This is sort of a cheat, to make the system.multicall API call a
28 # lot easier. The syntax isn't documented in the manual page, for good
29 # reason.
30 $reqobj = RPC::XML::request->new(shift(@$xml), @$xml);
31 }
32 elsif (UNIVERSAL::isa($xml, 'RPC::XML::request'))
33 {
34 $reqobj = $xml;
35 }
36 else
37 {
38 $reqobj = $self->{__parser}->parse($xml);
39 return RPC::XML::response
40 ->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj"))
41 unless (ref $reqobj);
42 }
43
44 $self->{__request_object} = $reqobj;
45
46 @data = @{$reqobj->args};
47 $name = $reqobj->name;
48
49 #print "request: ", Dumper($reqobj);
50
51 #$self->{session_id} ||= '';
52
53 my $session_id = $self->_server_read_request();
54
55 my $err_code = 0;
56 my $err_msg = '';
57
58 # check session-id here: do we already know it?
59 if (!$session_id) {
60 $err_code = 510;
61 $err_msg = "Internal error: Unique session identifier could not be created.";
62 } elsif (!$self->{__sessions}->{$session_id}) {
63 $err_code = 511;
64 $err_msg = "Internal error: Unknown session identifier '$session_id'.";
65 }
66
67 if ($err_code) {
68 return $self->_get_fault_response($err_code, $err_msg);
69 }
70
71 # increase access-counter (per-session)
72 #$self->{__sessions}->{$session_id}++;
73
74
75 # Get the method, call it, and bump the internal requests counter. Create
76 # a fault object if there is problem with the method object itself.
77 if (ref($meth = $self->get_method($name)))
78 {
79 if (!$self->_method_check_permissions($meth)) {
80 return $self->_get_fault_response(401, "Authorization required for method \"" . $meth->name() . "\". Please login first.");
81 }
82
83 # manipulate sigtable, if required (session initialized)
84 #if ($session_id) {
85 # my $signature = $meth->{sig_table};
86 #}
87
88 #print Dumper(@data);
89
90 # manipulate args, if required (session initialized)
91 =pod
92 if ($session_id && $#data >= 1) {
93 my $last = pop @data;
94 #print Dumper($last);
95 if ($last && ref $last eq 'RPC::XML::struct') {
96 my $last_value = $last->value();
97 print Dumper($last_value);
98 if (!$last_value->{RPCSESSID}) {
99 push @data, $last;
100 }
101 }
102 }
103 =cut
104
105 $response = $meth->call($self, @data);
106 $self->{__requests}++;
107 }
108 else
109 {
110 $response = RPC::XML::fault->new(300, $meth);
111 }
112
113 #my $session_id_obj = new RPC::XML::string($session_id);
114 #$response = new RPC::XML::array($response, $session_id_obj);
115
116 #print "response: ", Dumper($response);
117
118 # All the eval'ing and error-trapping happened within the method class
119 RPC::XML::response->new($response);
120 }
121
122 sub _get_fault_response {
123 my $self = shift;
124 my $code = shift;
125 my $message = shift;
126 my $response = RPC::XML::fault->new($code, $message);
127 print __PACKAGE__ . ": [" . $self->get_session_id() . "] - $message", "\n";
128 return RPC::XML::response->new($response);
129 }
130
131 sub _method_check_permissions {
132 my $self = shift;
133 my $method = shift;
134
135 # if method is not declared as 'protected' - just signal good
136 return 1 if !$method->{protected};
137
138 # check if already authenticated - also signal good
139 my $id = $self->get_session_id();
140 return 1 if $self->{__auth}->{$id};
141
142 }
143
144 sub authenticate {
145 my $self = shift;
146
147 my $user = shift;
148 my $pass = shift;
149
150 # signal bad if no authentication information is supplied
151 if (!$self->{authentication}) { return; }
152
153 #my $method = shift;
154
155 #my $prot = $method->{protection};
156 #$prot->{type} ||= '';
157
158 my $request_auth_type = 'plain';
159 my $server_auth_type = $self->{authentication}->{type};
160
161 # check if auth-type from request matches declaration
162 if ($request_auth_type ne $server_auth_type) {
163 $self->debug( "Issued authentication-type '$request_auth_type' does not match server-requirement '$server_auth_type'." );
164 return;
165 }
166
167 if (!$request_auth_type) {
168 $self->debug( "Authentication type was empty." );
169 return;
170
171 } elsif ($request_auth_type eq 'plain') {
172 $self->debug( "User '$user' attempts to authenticate with type '$request_auth_type'." );
173 #print Dumper($self);
174 if ($self->{authentication}->{user} eq $user && $self->{authentication}->{pass} eq $pass) {
175 my $id = $self->get_session_id();
176 $self->{__auth}->{$id}++;
177 $self->debug( "Authentication successful [user=$self->{authentication}->{user}]." );
178 return 1;
179
180 } else {
181 $self->debug( "Authentication failed [user=$self->{authentication}->{user}]." );
182 }
183
184 } elsif ($request_auth_type eq 'md5') {
185 $self->debug( "FIXME: Protection type '$request_auth_type' not supported." );
186
187 } else {
188 $self->debug( "Protection type '$request_auth_type' not supported." );
189 }
190
191 }
192
193 sub _server_read_request() {
194
195 my $self = shift;
196 my $reqobj = $self->{__request_object};
197
198 my $isNew = 0;
199 my $session_id;
200
201 # check if session-id is already present in request (we don't have cookies here) ...
202 if ($session_id = $reqobj->{session_id}) {
203 #print "session_id_r: ", $session_id, "\n";
204 delete $reqobj->{session_id};
205 } else {
206 # ... issue new one
207 #print Dumper($self);
208 $session_id = make_guid();
209 $isNew = 1;
210 }
211
212 # set current session id to server scope
213 # FIXME: is this transfer still valid if multi-threading and/or -processing gets used?
214 # FIXME: this is a hairy place for doing stuff like this! review twice!
215 $self->{__session_id} = $session_id;
216
217 if ($isNew) {
218 $self->debug("Initializing new client session with identifier '$session_id'.");
219 $self->_server_init_session();
220 }
221
222 return $session_id;
223
224 }
225
226 sub _server_init_session {
227 my $self = shift;
228 my $session_id = $self->{__session_id};
229 # increase access-counter (per-session)
230 $self->{__sessions}->{$session_id}++;
231 #print "Initialized sessions:", "\n";
232 #print Dumper($self->{__sessions});
233 }
234
235 sub get_session_id {
236 my $self = shift;
237 return $self->{__session_id};
238 }
239
240 sub debug {
241 my $self = shift;
242 print __PACKAGE__, "[$self->{__host}:$self->{__port}]", ": ", @_, "\n" if @_;
243 }
244
245
246
247
248 package RPC::XML::request;
249
250 use strict;
251 use warnings;
252 #use vars qw(@ISA);
253 use base qw( RPC::XML::request );
254
255 use Data::Dumper;
256
257
258 sub new
259 {
260 my $class = shift;
261 my @argz = @_;
262
263 my ($self, $name);
264
265 $class = ref($class) || $class;
266 $RPC::XML::ERROR = '';
267
268 unless (@argz)
269 {
270 $RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' .
271 'must be specified';
272 return undef;
273 }
274
275 if (UNIVERSAL::isa($argz[0], 'RPC::XML::request'))
276 {
277 # Maybe this will be a clone operation
278 }
279 else
280 {
281 # This is the method name to be called
282 $name = shift(@argz);
283
284 # check for session-id in request's args
285 my $session_id = _request_get_RPCSESSID(\@argz);
286
287 # All the remaining args must be data.
288 @argz = RPC::XML::smart_encode(@argz);
289 #print Dumper(@argz);
290 $self = { args => [ @argz ], name => $name, session_id => $session_id };
291 bless $self, $class;
292
293 #print Dumper($self);
294 }
295
296 $self;
297 }
298
299 # Accessor methods
300 sub name { shift->{name} }
301 sub args { shift->{args} || [] }
302 sub session_id { shift->{session_id} }
303
304
305 sub _request_get_RPCSESSID {
306
307 my $haystack = shift;
308
309 # check each element in $haystack for being a hash (struct),
310 # if so, check if key 'RPCSESSID' exists in there
311 # propagate this as session-id!
312
313 foreach (@$haystack) {
314
315 # check lists (arrays) recursively
316 if (ref $_ eq 'RPC::XML::array') {
317 return _request_get_RPCSESSID($_);
318
319 } elsif (ref $_ eq 'RPC::XML::struct') {
320 if (exists $_->{RPCSESSID}) {
321 my $id_obj = $_->{RPCSESSID};
322 my $id = $id_obj->value();
323 delete $_->{RPCSESSID};
324 #last;
325 return $id;
326 }
327
328 }
329 }
330
331 }
332
333 1;
334 __END__

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed