File Coverage

blib/lib/POE/Component/Server/XMLRPC.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# $Id: XMLRPC.pm,v 1.4 2003/03/20 23:26:02 mah Exp $
# License and documentation are after __END__.

package POE::Component::Server::XMLRPC;

use warnings;
use strict;
use Carp qw(croak);

use vars qw($VERSION);
$VERSION = '0.05';

use POE;
use POE::Component::Server::HTTP;
use XMLRPC::Lite;

my %public_interfaces;

sub new {
  my $type = shift;

  croak "Must specify an even number of parameters to $type\->new()" if @_ % 2;
  my %params = @_;

  my $alias = delete $params{alias};
  croak "Must specify an alias in $type\->new()"
    unless defined $alias and length $alias;

  my $interface = delete $params{interface};
  croak "$type\->new() currently does not support the interface parameter"
    if defined $interface;

  my $port = delete $params{port};
  $port = 80 unless $port;

  POE::Session->create
    ( inline_states =>
      { _start => sub {
          $_[KERNEL]->alias_set($alias);
        },
        publish => sub {
          my ($alias, $event) = @_[ARG0, ARG1];
          $public_interfaces{$alias}{$event} = 1;
        },
        rescind => sub {
          my ($alias, $event) = @_[ARG0, ARG1];
          delete $public_interfaces{$alias}{$event};
        },
      }
    );

  POE::Component::Server::HTTP->new
    ( Port     => $port,
      Headers  =>
      { Server => "POE::Component::Server::XMLRPC/$VERSION",
      },
      ContentHandler => { "/" => \&web_handler },
    );

  undef;
}

### Handle web requests by farming them out to other sessions.

sub web_handler {
  my ($request, $response) = @_;

  # Parse useful things from the request.

  my $query_string = $request->uri->query();
  unless (defined($query_string) and $query_string =~ /\bsession=(.+ $ )/x) {
    $response->code(400);
    return RC_OK;
  }
  my $session = $1;

  my $http_method            = $request->method();
  my $request_content_type   = $request->header('Content-Type');
  my $request_content_length = $request->header('Content-Length');
  my $debug_request          = $request->header('DebugRequest');
  my $request_content        = $request->content();
  my $data                   = XMLRPC::Deserializer
    ->deserialize($request_content);
  my $method_name            = $data->valueof("methodName");
  my $args                   = $data->valueof("params");

  unless ($request_content_type =~ /^text\/xml(;.*)?$/) {
    _request_failed( $response,
		     403,
                     "Bad Request",
                     "Content-Type must be text/xml.",
                   );
    return RC_OK;
  }

  unless (defined($method_name) and length($method_name)) {
    _request_failed( $response,
                     403,
                     "Bad Request",
                     "methodName is required.",
                   );
    return RC_OK;
  }

  unless ($method_name =~ /^(\S+)$/) {
   _request_failed( $response,
		    403,
                    "Bad Request",
                    "Unrecognized methodName: $method_name",
                  );
  }

  unless (exists $public_interfaces{$session}) {
    _request_failed( $response,
		     500,
                     "Bad Request",
                     "Unknown session: $session",
                   );
    return RC_OK;
  }

  unless (exists $public_interfaces{$session}{$method_name}) {
    _request_failed( $response,
		     500,
                     "Bad Request",
                     "Unknown method: $method_name",
                   );
    return RC_OK;
  }

  eval {
    XMLRPCTransaction->start($response, $session, $method_name, $args);
  };

  if ($@) {
    _request_failed( $response,
                     500,
                     "Application Faulted",
                     "An exception fired while processing the request: $@",
                   );
  }

  return RC_WAIT;
}

sub _request_failed {
  my ($response, $fault_code, $fault_string, $result_description) = @_;

  my $response_content = qq{


faultCode$fault_code
faultString$fault_string


};

  $response->code(200);
  $response->header("Content-Type", "text/xml");
  $response->header("Content-Length", length($response_content));
  $response->content($response_content);
}

package XMLRPCTransaction;

sub TR_RESPONSE () { 0 }
sub TR_SESSION  () { 1 }
sub TR_EVENT    () { 2 }
sub TR_ARGS     () { 3 }

sub start {
  my ($type, $response, $session, $event, $args) = @_;

  my $self = bless
    [ $response,
      $session,
      $event,
      $args,
    ], $type;

  $POE::Kernel::poe_kernel->post($session, $event, $self);
  undef;
}

sub params {
  my $self = shift;
  return $self->[TR_ARGS];
}

sub return {
  my ($self, $retval) = @_;

  my $content = XMLRPC::Serializer->envelope(response => 'toMethod', $retval);
  my $response = $self->[TR_RESPONSE];

  $response->code(200);
  $response->header("Content-Type", "text/xml");
  $response->header("Content-Length", length($content));
  $response->content($content);
  $response->continue();
}

1;

__END__