xmlrpc.pm

Punjab is a jabber XMLRPC/SOAP/REST client. It is a xmlrpc, soap, or REST server that allows for p

package PunJab::Server::XMLRPC;
use strict;
use warnings;

use POE;
use POE::Filter::XML;
use POE::Filter::XML::Node;
use POE::Filter::XML::NS qw/ :JABBER :IQ /;
use POE::Filter::XML::Utils;

use XMLRPC::Lite;

use PunJab::Util;
use PunJab::Session;
use PunJab::Server::HTTP;

use POSIX qw(strftime);
use Digest::MD5 qw(md5 md5_hex md5_base64);
use Data::Uniqid qw ( suniqid uniqid luniqid );

my %public_interfaces; 

# xmlrpc code adapted from POE::Component::Server::XMLRPC
sub new {
    shift;
    my $config = shift;
    my $alias  = shift;
    $alias = "xmlrpc" if not defined $alias;
    #$config->{'type'} = "xmlrpc_client";

    PunJab::Server::HTTP->new($config,\&handler,undef,undef,'xmlrpc_web_server');
    
    POE::Session->create
	( inline_states =>
	  { _start => sub {
	      my $kernel = $_[KERNEL];
	      if ($config->{debug}>0) {
		  &debug("XMLRPC Server Session Started\n");   
	      }
	      $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};
	  },
	
         # send_xmlrpc    => \&send_xmlrpc,


	},
	  heap => { CONFIG => $config },
	  options => { debug => $config->{'debug'}, trace => $config->{'debug'} }
	  );
    

    return undef;

}


### Handlers for the xmlrpc server. 
sub shutdown_service {
    $_[KERNEL]->yield("shutdown");
}

sub handler()
{
    # taken and modified from POE::Component::XMLRPC::Server
    my ($kernel,$sender, $heap,$request) = @_[KERNEL,SENDER, HEAP, ARG0];
    
    if($request->isa('HTTP::Response'))
     {	 
	 _request_failed( $request,
			  403,
			  "Bad Request",
			  "This was a response?",
			  $sender,	       
			  );	 
	 return;
     }

    my $response = HTTP::Response->new();
    $heap->{'stream_count'} = 0;
    # Parse useful things from the request.
    
    my $query_string = $request->uri->query();
    unless (defined($query_string) and $query_string =~ /\bsession=(.+ $ )/x) {
	_request_failed( $response,
			 404,
			 "Bad Session Request",
			 "Session does not exist.",
			 $sender,
			 );
	return;
    }
    my $session = $1;
    my ($data,$method_name,$args);
    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();
    eval {
	$data                   = XMLRPC::Deserializer
	    ->deserialize($request_content);
    };
            
    if (defined($data)) {
	$method_name            = $data->valueof("methodName");
	$args                   = $data->valueof("params");
    }

    unless ($request_content_type =~ /^text\/xml(;.*)?$/) {
	_request_failed( $response,
			 404,
			 "Bad Content-Type Request",
			 "Content-Type must be text/xml.",
			 $sender,
			 );	
	return;
    }
    
    unless (defined($method_name) and length($method_name)) {
	_request_failed( $response,
			 404,
			 "Bad methodName Request",
			 "methodName is required.",
			 $sender,
			 );
	return;
    }
    
    unless ($method_name =~ /^(\S+)$/) {
	_request_failed( $response,
			 403,
			 "Bad Request",
			 "Unrecognized methodName: $method_name",
			 $sender,
			 );
	return;
    }

    unless (exists $public_interfaces{$session}) {
	_request_failed( $response,
			 500,
			 "Bad Request",
			 "Unknown session: $session",
			 $sender,
			 );
	return;
  }
    
    unless (exists $public_interfaces{$session}{$method_name}) {
	# put xmlrpc routing code here. 
	_request_failed( $response,
			 500,
			 "Bad Request",
			 "Unknown method: $method_name",
			 $sender,
                   );
	return;
    }
    
    eval {
	XMLRPCTransaction->start($sender,
				 $request,
				 $response,
				 $session, 
				 $method_name,
				 $args,
				 );
    };
    
    if ($@) {
	_request_failed( $response,
			 500,
			 "Application Faulted",
			 "An exception fired while processing the request: $@",
			 $sender,			
			 );
	
    }
    return;
}


#sub send_xmlrpc {
#    my ($kernel,$session,$heap,$ret_val,$xmlrpc_trans) = 
#	@_[KERNEL, SESSION, HEAP, ARG0, ARG1];  
#    $xmlrpc_trans->return($ret_val);
#}



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

  my $response_content = qq{<?xml version="1.0"?>
<methodResponse>
<fault><value><struct>
<member><name>faultCode</name><value><int>$fault_code</int></value></member>
<member><name>faultString</name><value><string>$fault_string</string></value>
</member>
</struct></value></fault>
</methodResponse>};
  $response->code(200);
  $response->header("Content-Type", "text/xml");
  $response->header("Content-Length", length($response_content));
  $response->content($response_content);
  my $pb = $sender->postback( 'send_response', $response);
  $pb->($response); # is there another way to do this?

}

package XMLRPCTransaction;

sub TR_REQUEST  () { 0 }
sub TR_RESPONSE () { 1 }
sub TR_SESSION  () { 2 }
sub TR_EVENT    () { 3 }
sub TR_ARGS     () { 4 }
sub TR_CLIENT   () { 5 }


sub start()
{
  my ($type, $sender, $request, $response, $session,$event, $args, $csid) = @_;
  
  my $self = bless
    [ $request,
      $response,
      $session,
      $event,
      $args,
      $sender->postback( 'send_response', $response),
    ], $type;

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

sub request {
    my $self = shift;
    return $self->[TR_REQUEST];
}


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

sub return()
{
    my $self = shift;
    
    my $content;
    eval {
	$content = XMLRPC::Serializer->envelope(response => 'toMethod', @_);
    };
    if ($@) {
	$content = XMLRPC::Serializer->envelope(response => 'toMethod', $@);
    }
    my $response = $self->[TR_RESPONSE];

    $response->code(200);
    $response->header("Content-Type", "text/xml");
    $response->header("Content-Length", length($content));
    $response->content($content);   
    $self->[TR_CLIENT]->($response);
    return;
}

sub error {
    my $self = shift;
    my $content;
    eval {
	$content = XMLRPC::Serializer->envelope(response => 'fault', @_);
    };
    if ($@) {
	$content = XMLRPC::Serializer->envelope(response => 'fault', $@);
    }
    my $response = $self->[TR_RESPONSE];
 
    $response->code(200);
    $response->header("Content-Type", "text/xml");
    $response->header("Content-Length", length($content));
    $response->content($content);
    $self->[TR_CLIENT]->($response);
    return;
}

sub auth {
    my $self = shift;
    
    my $content = qq{<?xml version="1.0"?>
<methodResponse>
<fault><value><struct>
<member><name>faultCode</name><value><int>403</int></value></member>
<member><name>faultString</name><value><string>@_</string></value>
</member>
</struct></value></fault>
</methodResponse>};
    my $response = $self->[TR_RESPONSE];
 
    $response->code(200);
    $response->header("Content-Type", "text/xml");
    $response->header("Content-Length", length($content));
    $response->content($content);
    $self->[TR_CLIENT]->($response);
    return;
}

1;

__END__