File Coverage

blib/lib/XML/Compile/SOAP/Daemon.pm

Criterion	Covered	Total	%
statement	86	168	51.1
branch	23	76	30.2
condition	8	40	20.0
subroutine	18	27	66.6
pod	15	17	88.2
total	150	328	45.7

# Copyrights 2007-2018 by [Mark Overmeer ].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution XML-Compile-SOAP-Daemon.  Meta-POD
# processed with OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package XML::Compile::SOAP::Daemon;
use vars '$VERSION';
$VERSION = '3.14';


use warnings;
use strict;

use Log::Report 'xml-compile-soap-daemon';

use XML::LibXML        ();
use XML::Compile::Util qw/type_of_node/;
use XML::Compile::SOAP ();

# We use HTTP status definitions for each soap protocol, but HTTP::Status
# may not be installed.
use constant
  { RC_SEE_OTHER            => 303
  , RC_FORBIDDEN            => 403
  , RC_NOT_FOUND            => 404
  , RC_UNPROCESSABLE_ENTITY => 422
  , RC_NOT_IMPLEMENTED      => 501
  };

my $parser        = XML::LibXML->new;


sub new(@)
{   my $class = shift;
    $class ne __PACKAGE__
        or error __x"you can only use extensions of {pkg}", pkg => __PACKAGE__;
    (bless {}, $class)->init( {@_} );
}

sub init($)
{   my ($self, $args) = @_;
    $self->{accept_slow_select}
      = exists $args->{accept_slow_select} ? $args->{accept_slow_select} : 1;

    $self->addWsaTable(INPUT  => $args->{wsa_action_input});
    $self->addWsaTable(OUTPUT => $args->{wsa_action_output});
    $self->addSoapAction($args->{soap_action_input});

    if(my $support = delete $args->{support_soap})
    {   # simply only load the protocol versions you want to accept.
        error __x"new(support_soap} removed in 2.00";
    }

    my @classes = XML::Compile::SOAP->registered;
    @classes   # explicit load required since 2.00
        or warning "No protocol modules loaded.  Need XML::Compile::SOAP11?";

    $self->{output_charset} = delete $args->{output_charset} || 'UTF-8';
    $self->{handler}        = {};
    $self;
}

#-----------

sub outputCharset() {shift->{output_charset}}


sub addWsaTable($@)
{   my ($self, $dir) = (shift, shift);
    my $h = @_==1 ? shift : { @_ };
    my $t = $dir eq 'INPUT'  ? ($self->{wsa_input}  ||= {})
          : $dir eq 'OUTPUT' ? ($self->{wsa_output} ||= {})
          : error __x("addWsaTable requires 'INPUT' or 'OUTPUT', not {got}"
              , got => $dir);

    while(my($op, $action) = each %$h) { $t->{$op} ||= $action }
    $t;
}


sub addSoapAction(@)
{   my $self = shift;
    my $h = @_==1 ? shift : { @_ };
    my $t = $self->{sa_input}     ||= {};
    my $r = $self->{sa_input_rev} ||= {};
    while(my($op, $action) = each %$h)
    {   $t->{$op}     ||= $action;
        $r->{$action} ||= $op;
    }
    $t;
}

#------------------

sub run(@)
{   my ($self, %args) = @_;
    notice __x"WSA module loaded, but not used"
        if XML::Compile::SOAP::WSA->can('new') && !keys %{$self->{wsa_input}};

    $self->{wsa_input_rev}  = +{ reverse %{$self->{wsa_input}} };
    $self->_run(\%args);
}


# defined by Net::Server
sub process_request(@) { panic "must be extended" }

sub process($)
{   my ($self, $input, $req, $soapaction) = @_;

    my $xmlin;
    if(! defined $input)
    {  return $self->faultNotSoapMessage('No input');
    }
    elsif(ref $input eq 'SCALAR')
    {   $xmlin = try { $parser->parse_string($$input) };
        return $self->faultInvalidXML($@->wasFatal) if $@;
    }
    else
    {   $xmlin = $input;
    }

    $xmlin     = $xmlin->documentElement
        if $xmlin->isa('XML::LibXML::Document');

    my $local  = $xmlin->localName;
    $local eq 'Envelope'
        or return $self->faultNotSoapMessage(type_of_node $xmlin);

    my $envns  = $xmlin->namespaceURI || '';
    my $proto  = XML::Compile::SOAP->fromEnvelope($envns)
        or return $self->faultUnsupportedSoapVersion($envns);
    # proto is a XML::Compile::SOAP*::Operation
    my $server = $proto->serverClass;

    my $info   = XML::Compile::SOAP->messageStructure($xmlin);
    my $version  = $info->{soap_version} = $proto->version;
    my $handlers = $self->{handler}{$version} || {};

    # Try to resolve operation via WSA
    my $wsa_in   = $self->{wsa_input_rev};
    if(my $wsa_action = $info->{wsa_action})
    {   if(my $name = $wsa_in->{$wsa_action})
        {   my $handler = $handlers->{$name};
            local $info->{selected_by} = 'wsa-action';
            my ($rc, $msg, $xmlout) = $handler->($name, $xmlin, $info, $req);
            if($xmlout)
            {   trace "data ready for $version $name, via wsa $wsa_action";
                return ($rc, $msg, $xmlout);
            }
        }
    }

    # Try to resolve operation via soapAction
    my $sa = $self->{sa_input_rev};
    if(defined $soapaction)
    {   if(my $name = $sa->{$soapaction})
        {   my $handler = $handlers->{$name};
            local $info->{selected_by} = 'soap-action';
            my ($rc, $msg, $xmlout) = $handler->($name, $xmlin, $info, $req);
            if($xmlout)
            {   trace "data ready for $version $name, via sa '$soapaction'";
                return ($rc, $msg, $xmlout);
            }
        }
    }

    # Last resort, try each of the operations for the first which
    # can be parsed correctly.
    if($self->{accept_slow_select})
    {   keys %$handlers;  # reset each()
        $info->{selected_by} = 'attempt all';
        while(my ($name, $handler) = each %$handlers)
        {   my ($rc, $msg, $xmlout) = $handler->($name, $xmlin, $info, $req);
            defined $xmlout or next;

            trace "data ready for $version $name";
            return ($rc, $msg, $xmlout);
        }
    }

    my $bodyel = $info->{body}[0] || '(none)';
    my @other  = sort grep {$_ ne $version && keys %{$self->{$_}}}
        $self->soapVersions;

    return (RC_SEE_OTHER, 'SOAP protocol not in use'
      , $server->faultTryOtherProtocol($bodyel, \@other))
        if @other;

    # we do not have the names of the request body elements here :(
    my @ports = sort keys %$handlers;

      ( RC_NOT_FOUND, 'message not recognized'
      , $server->faultMessageNotRecognized($bodyel, $soapaction, \@ports)
      );
}

#------------------

sub operationsFromWSDL($@)
{   my ($self, $wsdl, %args) = @_;
    my %callbacks  = $args{callbacks} ? %{$args{callbacks}} : ();
    my %names;

    my $default_cb = $args{default_callback};
    my $wsa_input  = $self->{wsa_input};
    my $wsa_output = $self->{wsa_output};

    my $ops = $args{operations};
    my @ops = $ops ? @$ops : $wsdl->operations(%args);
    @ops or return;   # none selected

    foreach my $op (@ops)
    {   my $name = $op->name;
        warning __x"multiple operations with name `{name}'", name => $name
            if $names{$name}++;

        my $code;
        if(my $callback = $callbacks{$name})
        {   UNIVERSAL::isa($callback, 'CODE')
               or error __x"callback {name} must provide a CODE ref"
                    , name => $name;

            trace __x"add handler for operation `{name}'", name => $name;
            $code = $op->compileHandler(callback => $callback);
        }
        else
        {   trace __x"add stub handler for operation `{name}'", name => $name;
            my $handler = $default_cb
              || sub { $_[0]->faultNotImplemented($name) };

            $code = $op->compileHandler(callback => $handler);
        }

        $self->addHandler($name, $op, $code);

        if($op->can('wsaAction'))
        {   my $in  = $op->wsaAction('INPUT');
            $wsa_input->{$name}  = $in if defined $in;
            my $out = $op->wsaAction('OUTPUT');
            $wsa_output->{$name} = $out if defined $out;
        }
        $self->addSoapAction($name, $op->soapAction);
    }

    info __x"added {nr} operations from WSDL", nr => (scalar @ops);

    if(keys %names != keys %callbacks)
    {   $names{$_}
            or warning __x"no operation for callback handler `{name}'",name=>$_
                for sort keys %callbacks;
    }

    $self;
}


sub addHandler($$$)
{   my ($self, $name, $soap, $code) = @_;

    my $version = ref $soap ? $soap->version : $soap;
    $self->{handler}{$version}{$name} = $code;
}


sub setWsdlResponse($;$)
{   my ($self, $filename, $type) = @_;
    panic "not implemented by backend {pkg}", pkg => (ref $self || $self);
}

#------------------

sub handlers($)
{   my ($self, $soap) = @_;
    my $version = ref $soap ? $soap->version : $soap;
    my $table   = $self->{handler}{$version} || {};
    keys %$table;
}


sub soapVersions() { sort keys %{shift->{handler}} }


sub printIndex(;$)
{   my $self = shift;
    my $fh   = shift || \*STDOUT;

    foreach my $version ($self->soapVersions)
    {   my @handlers = $self->handlers($version);
        @handlers or next;

        local $" = "\n   ";
        $fh->print("$version:\n   @handlers\n");
    }
}


sub faultInvalidXML($)
{   my ($self, $error) = @_;
    ( RC_UNPROCESSABLE_ENTITY, 'XML syntax error'
    , __x("The XML cannot be parsed: {error}", error => $error));
}


sub faultNotSoapMessage($)
{   my ($self, $type) = @_;
    ( RC_FORBIDDEN, 'message not SOAP'
    , __x( "The message was XML, but not SOAP; not an Envelope but `{type}'"
         , type => $type));
}


sub faultUnsupportedSoapVersion($)
{   my ($self, $envns) = @_;
    ( RC_NOT_IMPLEMENTED, 'SOAP version not supported'
    , __x("The soap version `{envns}' is not supported", envns => $envns));
}

#------------------

1;