package Mojolicious::Plugin::SOAP;

=head1 NAME

Mojolicious::Plugin::SOAP - Parse SOAP messages and dispatch to a route

=head1 DESCRIPTION

This plugin register a L<around_dispatch|Mojolicious/around_dispatch> hook,
which parse the body of the incoming message on POST and tries to find a
SOAP method, if the data looks like XML.

The method is found by looking at the first tag name inside the SOAP "Body"
tag - with prefixes stripped away.

=head1 SYNOPSIS

  use Mojolicious::Lite;
  plugin "SOAP";

  post "/soap/someMethodInsideBody" => sub {
    my $c = shift;
    $c->render("someMethodInsideBodyResponse");
  };

  app->start;

See L</register> for C<%config> options.

=cut

use Mojo::Base 'Mojolicious::Plugin';
use Mojo::DOM;
use constant DEBUG => $ENV{WAPS_SOAP_DEBUG} ? 1 : 0;

=head1 ATTRIBUTES

=head2 content_type

  $str = $self->content_type;

=cut

has content_type => 'text/xml; charset=ISO-8859-1';

=head1 METHODS

=head2 register

  $self->register($app, \%config);

C<%config> can contain:

=over 4

=item * allow_empty => 1

This enabling a custom route called "/soap/empty" to be fired on a POST
without a body.

=item * base => $str,

Used to change the "/soap" part to something else.

=back

=cut

sub register {
  my ($self, $app, $config) = @_;
  my $allow_empty = $config->{allow_empty} || 0;
  my $base = $config->{base} || '/soap';
  my $e;

  $app->routes->add_condition(chunked => sub {
    my ($route, $c, $captures) = @_;
    $c->stash('transfer.encoding.chunked' => 1);
    $c->res->code(200);
    $c->render_later;
  });

  $app->hook(around_dispatch => sub {
    my ($next, $c) = @_;
    my $req = $c->tx->req;
    my($xml, $action);

    return $next->() unless $req->method eq 'POST';

    if ($req->body =~ /^\s*$/s) {
      if ($allow_empty) {
        $self->_got_soap_message($c, {}, $base, 'empty');
        $c->app->log->warn("Server <<< Client ()") if DEBUG;
      }
      $next->();
      $self->_render_response($c);
      return;
    }
    elsif($req->body !~ /^\s*</s) { # not xml
        return $next->();
    }

    $c->app->log->warn("Server <<< Client (@{[$req->body]})") if DEBUG;
    $xml = XML::Bare->new(text => $req->body)->parse or return $next->();
    $self->_remove_prefix($xml);
    $self->_got_soap_message($c, $xml, $base, grep { not /^(?:_|value|encodingStyle)/ } keys %{ $xml->{Envelope}{Body} });
    $next->();
    $self->_render_response($c);
});
}

sub _remove_prefix {
    my($self, $tree) = @_;

    if(ref $tree eq 'ARRAY') {
        $self->_remove_prefix($_) for @$tree;
    }
    elsif(ref $tree eq 'HASH') {
        for my $key (keys %$tree) {
            if($key =~ /^xmlns/) {
                next;
            }
            elsif($key =~ /^[\w-]+:(\w+)$/) {
                $tree->{$1} = delete $tree->{$key};
                $self->_remove_prefix($tree->{$1});
            }
        }
    }
}

sub _render_response {
    my($self, $c) = @_;
    my $stash = $c->stash;
    my($output, $format);

    if(!$stash->{'transfer.encoding.chunked'}) {
        $c->render unless $c->stash('mojo.rendered');
        $c->app->log->warn("Client <<< Server (@{[$c->res->body]})") if DEBUG and $c->stash('soap_action') and $c->stash('mojo.rendered');
        return;
    }
    if($c->res->code ne '200') {
        return;
    }

    local $stash->{template}
        = $stash->{template}
       || join '/', grep { $_ } @$stash{qw/ controller action /};

    if(!$stash->{template}) {
        $c->logf(error => 'SOAP: Internal error. No template.');
        $c->render(text => 'SOAP: Internal error. No template.', status => 500);
        return;
    }

    ($output, $format) = $c->app->renderer->render($c, $stash);

    $c->app->log->warn("Client <<< Server ($output)") if DEBUG;
    $c->write_chunk($output, sub {
        my $c = shift;
        $c->write_chunk('');
        $c->finish;
    });
}

sub _got_soap_message {
  my ($self, $c, $base, $action) = @_;
  my $headers = $c->res->headers;

  $headers->connection('keep-alive');
  $headers->content_type($self->content_type) if $self->content_type;
  $headers->header('SOAPAction' => '');
  $c->stash(format => 'xml', 'soap.message' => $soap);
  $c->req->url->path("$base/$action");
}

=head1 AUTHOR

Jan Henning Thorsen - C<jhthorsen@cpan.org>

=cut

1;