RPC/XML/SessionServer.pm

package RPC::XML::SessionServer;

use strict;
use warnings;

use base qw( RPC::XML::Server );


use Data::Dumper;
use shortcuts qw( make_guid );

sub dispatch
{
    my ($self, $xml) = @_;

    my ($reqobj, @data, $response, $name, $meth);

    if (ref($xml) eq 'SCALAR')
    {
        $reqobj = $self->{__parser}->parse($$xml);
        return RPC::XML::response
            ->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj"))
                unless (ref $reqobj);
    }
    elsif (ref($xml) eq 'ARRAY')
    {
        # This is sort of a cheat, to make the system.multicall API call a
        # lot easier. The syntax isn't documented in the manual page, for good
        # reason.
        $reqobj = RPC::XML::request->new(shift(@$xml), @$xml);
    }
    elsif (UNIVERSAL::isa($xml, 'RPC::XML::request'))
    {
        $reqobj = $xml;
    }
    else
    {
        $reqobj = $self->{__parser}->parse($xml);
        return RPC::XML::response
            ->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj"))
                unless (ref $reqobj);
    }

    $self->{__request_object} = $reqobj;

    @data = @{$reqobj->args};
    $name = $reqobj->name;

    #print "request: ", Dumper($reqobj);

    #$self->{session_id} ||= '';

    my $session_id = $self->_server_read_request();

    my $err_code = 0;
    my $err_msg = '';
    
    # check session-id here: do we already know it?
    if (!$session_id) {
      $err_code = 510;
      $err_msg = "Internal error: Unique session identifier could not be created.";
    } elsif (!$self->{__sessions}->{$session_id}) {
      $err_code = 511;
      $err_msg = "Internal error: Unknown session identifier '$session_id'.";
    }

    if ($err_code) {
      return $self->_get_fault_response($err_code, $err_msg);
    }

    # increase access-counter (per-session)
    #$self->{__sessions}->{$session_id}++;


    # Get the method, call it, and bump the internal requests counter. Create
    # a fault object if there is problem with the method object itself.
    if (ref($meth = $self->get_method($name)))
    {
        if (!$self->_method_check_permissions($meth)) {
          return $self->_get_fault_response(401, "Authorization required for method \"" . $meth->name() . "\". Please login first.");
        }
        
        # manipulate sigtable, if required (session initialized)
        #if ($session_id) {
        #  my $signature = $meth->{sig_table};
        #}

        #print Dumper(@data);

        # manipulate args, if required (session initialized)
=pod
        if ($session_id && $#data >= 1) {
          my $last = pop @data;
          #print Dumper($last);
          if ($last && ref $last eq 'RPC::XML::struct') {
            my $last_value = $last->value();
            print Dumper($last_value);
            if (!$last_value->{RPCSESSID}) {
              push @data, $last;
            }
          }
        }
=cut

        $response = $meth->call($self, @data);
        $self->{__requests}++;
    }
    else
    {
        $response = RPC::XML::fault->new(300, $meth);
    }

    #my $session_id_obj = new RPC::XML::string($session_id);
    #$response = new RPC::XML::array($response, $session_id_obj);

    #print "response: ", Dumper($response);

    # All the eval'ing and error-trapping happened within the method class
    RPC::XML::response->new($response);
}

sub _get_fault_response {
  my $self = shift;
  my $code = shift;
  my $message = shift;
  my $response = RPC::XML::fault->new($code, $message);
  print __PACKAGE__ . ": [" . $self->get_session_id() . "] - $message", "\n";
  return RPC::XML::response->new($response);
}

sub _method_check_permissions {
  my $self = shift;
  my $method = shift;
  
  # if method is not declared as 'protected' - just signal good
  return 1 if !$method->{protected};
  
  # check if already authenticated - also signal good
  my $id = $self->get_session_id();
  return 1 if $self->{__auth}->{$id};

}

sub authenticate {
  my $self = shift;
  
  my $user = shift;
  my $pass = shift;
  
  # signal bad if no authentication information is supplied
  if (!$self->{authentication}) { return; }
  
  #my $method = shift;

  #my $prot = $method->{protection};
  #$prot->{type} ||= '';

  my $request_auth_type = 'plain';
  my $server_auth_type = $self->{authentication}->{type};

  # check if auth-type from request matches declaration
  if ($request_auth_type ne $server_auth_type) {
    $self->debug( "Issued authentication-type '$request_auth_type' does not match server-requirement '$server_auth_type'." );
    return;
  }

  if (!$request_auth_type) {
    $self->debug( "Authentication type was empty." );
    return;
  
  } elsif ($request_auth_type eq 'plain') {
    $self->debug( "User '$user' attempts to authenticate with type '$request_auth_type'." );
    #print Dumper($self);
    if ($self->{authentication}->{user} eq $user && $self->{authentication}->{pass} eq $pass) {
      my $id = $self->get_session_id();
      $self->{__auth}->{$id}++;
      $self->debug( "Authentication successful [user=$self->{authentication}->{user}]." );
      return 1;
      
    } else {
      $self->debug( "Authentication failed [user=$self->{authentication}->{user}]." );
    }
    
  } elsif ($request_auth_type eq 'md5') {
    $self->debug( "FIXME: Protection type '$request_auth_type' not supported." );

  } else {
    $self->debug( "Protection type '$request_auth_type' not supported." );
  }
  
}

sub _server_read_request() {
  
  my $self = shift;
  my $reqobj = $self->{__request_object};
  
  my $isNew = 0;
  my $session_id;

  # check if session-id is already present in request (we don't have cookies here) ...
  if ($session_id = $reqobj->{session_id}) {
    #print "session_id_r: ", $session_id, "\n";
    delete $reqobj->{session_id};
  } else {
    # ... issue new one
    #print Dumper($self);
    $session_id = make_guid();
    $isNew = 1;
  }

  # set current session id to server scope
  # FIXME: is this transfer still valid if multi-threading and/or -processing gets used?
  # FIXME: this is a hairy place for doing stuff like this! review twice!
  $self->{__session_id} = $session_id;

  if ($isNew) {
    $self->debug("Initializing new client session with identifier '$session_id'.");
    $self->_server_init_session();
  }

  return $session_id;

}

sub _server_init_session {
  my $self = shift;
  my $session_id = $self->{__session_id};
  # increase access-counter (per-session)
  $self->{__sessions}->{$session_id}++;
  #print "Initialized sessions:", "\n";
  #print Dumper($self->{__sessions});
}

sub get_session_id {
  my $self = shift;
  return $self->{__session_id};
}

sub debug {
  my $self = shift;
  print __PACKAGE__, "[$self->{__host}:$self->{__port}]", ": ", @_, "\n" if @_;
}


package RPC::XML::request;

use strict;
use warnings;
#use vars qw(@ISA);
use base qw( RPC::XML::request );

use Data::Dumper;


sub new
{
    my $class = shift;
    my @argz = @_;

    my ($self, $name);

    $class = ref($class) || $class;
    $RPC::XML::ERROR = '';

    unless (@argz)
    {
        $RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' .
            'must be specified';
        return undef;
    }

    if (UNIVERSAL::isa($argz[0], 'RPC::XML::request'))
    {
        # Maybe this will be a clone operation
    }
    else
    {
        # This is the method name to be called
        $name = shift(@argz);
        
        # check for session-id in request's args
        my $session_id = _request_get_RPCSESSID(\@argz);
        
        # All the remaining args must be data.
        @argz = RPC::XML::smart_encode(@argz);
        #print Dumper(@argz);
        $self = { args => [ @argz ], name => $name, session_id => $session_id };
        bless $self, $class;

        #print Dumper($self);
    }

    $self;
}

# Accessor methods
sub name       { shift->{name}       }
sub args       { shift->{args} || [] }
sub session_id       { shift->{session_id} }


sub _request_get_RPCSESSID {

  my $haystack = shift;

  # check each element in $haystack for being a hash (struct),
  # if so, check if key 'RPCSESSID' exists in there
  # propagate this as session-id!

  foreach (@$haystack) {

    # check lists (arrays) recursively
    if (ref $_ eq 'RPC::XML::array') {
      return _request_get_RPCSESSID($_);

    } elsif (ref $_ eq 'RPC::XML::struct') {
      if (exists $_->{RPCSESSID}) {
        my $id_obj = $_->{RPCSESSID};
        my $id = $id_obj->value();
        delete $_->{RPCSESSID};
        #last;
        return $id;
      }

    }
  }

}

1;
__END__
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