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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide 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 joko 1.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 joko 1.2 #print "Initialized sessions:", "\n";
232     #print Dumper($self->{__sessions});
233 joko 1.1 }
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