soap.pm

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

package PunJab::Server::Soap;
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 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 );
use Digest::SHA1;

use SOAP::Defs;
use SOAP::EnvelopeMaker;
#use SOAP::Parser;

my %soap_public_interfaces; 


sub new {
    shift;
    my $config = shift;
    my $alias  = shift;
    $alias = "soap" if not defined $alias;
    $config->{'type'} = "soap_client";
    PunJab::Server::HTTP->new($config,\&handler,undef,undef,'soap_web_server');

    POE::Session->create
	( inline_states =>
	  { _start => sub {
	      my $kernel = $_[KERNEL];
	      if ($config->{debug}>0) {
		  &debug("Soap Server Session Started\n");
	      }
	      $kernel->alias_set($alias);

	  },
	    publish => sub {
		my ($alias, $event) = @_[ARG0, ARG1];
		$soap_public_interfaces{$alias}{$event} = 1;
	    },
	    rescind => sub {
		my ($alias, $event) = @_[ARG0, ARG1];
		delete $soap_public_interfaces{$alias}{$event};
	    },
#	    send_soap      => \&send_soap,

	    dump_body  => sub {
		my $soap_transaction = $_[ARG0];
		use YAML qw(freeze);
		$soap_transaction->return(freeze $soap_transaction->params());
	    },
	},
	  heap => { CONFIG => $config },
	  options => { debug => $config->{'debug'}, trace => $config->{'debug'} }
	  );
    return undef;

}


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

sub handler()
{
    # taken and modified from POE::Component::SOAP::Server
    my ($kernel,$heap,$sender,$request) = @_[KERNEL, HEAP,SENDER, ARG0];
    if($request->isa('HTTP::Response'))
     {	 
	 _request_failed( $request,
			  $soap_fc_server,
			  "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) {
	$response->code(400);
	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 $soap_method_name       = $request->header('SOAPAction');
    my $debug_request          = $request->header('DebugRequest');
    my $request_content        = $request->content();
   

    unless ($request_content_type =~ /^text\/xml(;.*)?$/) {
	_request_failed( $response,
			 $soap_fc_client,
			 "Bad Request",
			 "Content-Type must be text/xml.",
			 $sender,
			 );
	return;
    }
        
    unless (defined($soap_method_name) and length($soap_method_name)) {
	_request_failed( $response,
			 $soap_fc_client,
			 "Bad Request",
			 "SOAPAction is required.",
			 $sender,
			 );
	return;
    }
    unless ($soap_method_name =~ /^([\"\']?)(\S+)\#(\S+)\1$/) {
	_request_failed( $response,
			 $soap_fc_client,
			 "Bad Request",
			 "Unrecognized SOAPAction header: $soap_method_name",
			 $sender
			 );

	return;
    }

    my ($event_uri, $event_name) = ($2, $3);
    my ($headers, $body);

    eval {
	$data                   = SOAP::Deserializer
	    ->deserialize($request_content);
	$headers = $data->valueof('Header'); # should give access to header if present
	$body = $data->valueof('Body');   # should give access to body
	$body = $body->{$event_name};
    };

    if ($@) {
	_request_failed( $response,
			 $soap_fc_server,
			 "Application Faulted",
			 "Failed while unmarshaling the request: $@",
			 $sender
			 );
	return;
    }
    if (length($body) == 0) {
	_request_failed( $response,
			 $soap_fc_server,
			 "Application Faulted",
			 "Failed while unmarshaling the request: Empty body.",
			 $sender
			 );
	return;
    }

    unless (exists $soap_public_interfaces{$session}) {
	_request_failed( $response,
			 $soap_fc_client,
			 "Bad Request",
			 "Unknown session: $session",
			 $sender,
			 );
	return;
  }

    unless (exists $soap_public_interfaces{$session}{$event_name}) {
	# put soap routing code here. 
	
	_request_failed( $response,
			 $soap_fc_server,
			 "Bad Request",
			 "Unknown method: $event_name",
			 $sender,
                   );
	return;
    }

    eval {
	SOAPTransaction->start($sender,
			       $request,
			       $response,
			       $session, 
			       $event_name, 
			       $headers, 
			       $body);
    };
    
    if ($@) {
	_request_failed( $response,
			 $soap_fc_server,
			 "Application Faulted",
			 "An exception fired while processing the request: $@",
			 $sender,
			 );
    }
    return;
}

#sub send_soap {
#    my ($kernel,$session,$heap,$ret_val,$soap_trans) = 
#	@_[KERNEL, SESSION, HEAP, ARG0, ARG1];
#
#    my $ret;
#    if(ref($ret_val) eq 'HASH') {
#	
#    } elsif(ref($ret_val) eq 'ARRAY') {
#
#    } else {
#	$ret = $ret_val;
#    }
#
#    $soap_trans->return($ret_val);
#
#}

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

   my $response_content =
    ( "<s:Envelope xmlns:s='$soap_namespace'>" .
      "<s:Body><s:Fault>" .
      "<faultcode>s:$fault_code</faultcode>" .
      "<faultstring>$fault_string</faultstring>" .
      "<detail>$result_description</detail>" .
      "</s:Fault></s:Body></s:Envelope>"
    );
  
  $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);
}



package SOAPTransaction; 
# code derived from http://search.cpan.org/src/RCAPUTO/POE-Component-Server-SOAP-0.03/SOAP.pm

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

sub start {
  my ($type, $sender, $request, $response, $session,$event, $headers, $body) = @_;

  my $self = bless
    [ $request,
      $response,
      $session,
      $event,
      $headers,  # TR_HEADERS
      $body,     # TR_BODY
      $sender->postback( 'send_response', $response),
    ], $type;

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

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

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


sub return {
    my $self = shift;
    
    my $content;
    eval {
	$content = SOAP::Serializer->envelope(method=>$self->[TR_EVENT], 
					      @_);#,
	#$self->[TR_HEADERS]);
    };

    # headers are broken right now
    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 = SOAP::Serializer->envelope(fault=>$self->[TR_EVENT], 
					      @_);#,
	#$self->[TR_HEADERS]);
    };
    # headers are broken right now.

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

sub auth {
    # this will need to be redone
    my $self = shift;
    my $content;
    eval {
	$content = SOAP::Serializer->envelope(fault=>$self->[TR_EVENT], 
					     @_);#,
					     #$self->[TR_HEADERS]);
    };    
    # headers are broken right now.
    
    my $response = $self->[TR_RESPONSE];
 
    $response->code(500);
    $response->header("Content-Type", "text/xml");
    $response->header("Content-Length", length($content));
    $response->content($content);
    $self->[TR_CLIENT]->($response);
    return;
}

1;

__END__