| 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__ |
Parent Directory
| 
Revision Log
