Catalyst::Action::SOAP::RPCEndpoint - RPC Dispatcher

Catalyst-Controller-SOAP documentation Contained in the Catalyst-Controller-SOAP distribution.

Index

Code Index:

NAME

Top

Catalyst::Action::SOAP::RPCEndpoint - RPC Dispatcher

SYNOPSIS

Top

  # not used directly.

DESCRIPTION

Top

This class is used by Catalyst::Controller::SOAP to dispatch to the RPC operations inside a controller. These operations are quite different from the others, as they are seen by Catalyst as this single action. During the registering phase, the soap rpc operations are included in the hash that is sent to this object, so they can be invoked later.

TODO

Top

Almost all the SOAP protocol is unsupported, only the method dispatching and, optionally, the soap-decoding of the arguments are made.

AUTHORS

Top

Daniel Ruoso <daniel@ruoso.com>

BUG REPORTS

Top

Please submit all bugs regarding Catalyst::Controller::SOAP to bug-catalyst-controller-soap@rt.cpan.org

LICENSE

Top

This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself.

Catalyst-Controller-SOAP documentation Contained in the Catalyst-Controller-SOAP distribution. 
{ package Catalyst::Action::SOAP::RPCEndpoint;

  use strict;
  use base qw/Catalyst::Action::SOAP/;
  use constant NS_SOAP_ENV => "http://schemas.xmlsoap.org/soap/envelope/";
  use UNIVERSAL;

  sub execute {
      my $self = shift;
      my ( $controller, $c ) = @_;

      $self->prepare_soap_helper($controller,$c);
      $self->prepare_soap_xml_post($controller,$c);
      unless ($c->stash->{soap}->fault) {
          my $envelope = $c->stash->{soap}->parsed_envelope;
          my $namespace = $c->stash->{soap}->namespace || NS_SOAP_ENV;
          my ($body) = $envelope->getElementsByTagNameNS($namespace,'Body',0);
          my @children = grep { UNIVERSAL::isa( $_, 'XML::LibXML::Element') } $body->getChildNodes();
          if (scalar @children != 1) {
              $c->stash->{soap}->fault
                ({ code => 'SOAP-ENV:Client',
                   reason => 'Bad Body', detail =>
                   'RPC messages should contain only one element inside body'})
            } else {
                my $rpc_element = $children[0];
                my ($smthing, $operation) = split /:/, $rpc_element->nodeName();
                $operation ||= $smthing; # if there's no ns prefix,
                                         # operation is the first
                                         # part.
                $c->stash->{soap}->operation_name($operation);

                eval {
                    if ($controller->wsdlobj) {
                        my $decoder = $controller->decoders->{$operation};
                        my ($args) = $decoder->($rpc_element)
                          if UNIVERSAL::isa($decoder,'CODE');
                        $c->stash->{soap}->arguments($args);
                    } else {
                        my $arguments = $rpc_element->getChildNodes();
                        $c->stash->{soap}->arguments($arguments);
                    }
                };
                if ($@) {
                    $c->stash->{soap}->fault
                      ({ code => 'SOAP-ENV:Client',
                         reason => 'Bad Body', detail =>
                         'Malformed parts on the message body: '.$@});
                } else {
                    my $action = $controller->action_for($operation);

                    if (!$action ||
                        !grep { /RPC(Encoded|Literal)/ } @{$action->attributes->{ActionClass}}) {
                        $c->stash->{soap}->fault
                          ({ code => 'SOAP-ENV:Client',
                             reason => 'Bad Operation', detail =>
                             'Invalid Operation'});
                    } else {
                        # this is our RPC action
                        $c->forward($operation);
                    }
                }

            }
      }
  }
};

1;

__END__