# Copyrights 2007-2018 by [Mark Overmeer <markov@cpan.org>].
#  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::LWPutil;
use vars '$VERSION';
$VERSION = '3.14';

use parent 'Exporter';

use warnings;
use strict;


our @EXPORT = qw(
    lwp_action_from_header
    lwp_add_header
    lwp_handle_connection
    lwp_make_response
    lwp_run_request
    lwp_wsdl_response
    lwp_socket_init
    lwp_http11_connection
);

use Log::Report 'xml-compile-soap-daemon';
use XML::Compile::SOAP::Util ':daemon';
use LWP;
use HTTP::Status qw/RC_OK RC_METHOD_NOT_ALLOWED RC_NOT_ACCEPTABLE/;

sub lwp_add_header($$@);
sub lwp_handle_connection($@);
sub lwp_run_request($$;$$);
sub lwp_make_response($$$$;$);
sub lwp_action_from_header($);



our @default_headers;
BEGIN
{   foreach my $pkg (qw/XML::Compile XML::Compile::SOAP
        XML::Compile::SOAP::Daemon XML::LibXML LWP/)
    {   no strict 'refs';
        my $version = ${"${pkg}::VERSION"} || 'undef';
        (my $field = "X-$pkg-Version") =~ s/\:\:/-/g;
        push @default_headers, $field => $version;
    }
}

sub lwp_add_header($$@) { push @default_headers, @_ }


my $wsdl_response;
sub lwp_wsdl_response(;$$)
{   @_ or return $wsdl_response;

    my ($file, $ft) = @_;
    $file && !ref $file
        or return $wsdl_response = $file;

    local *SRC;
    open SRC, '<:raw', $file
        or fault __x"cannot read wsdl file {file}", file => $file;
    local $/;
    my $spec = <SRC>;
    close SRC;

    $ft ||= 'application/wsdl+xml';
    $wsdl_response = HTTP::Response->new
      ( RC_OK, "WSDL specification"
      , [ @default_headers
        , "Content-Type" => "$ft; charset=utf-8"
        ]
      , $spec
      );
}
    

sub lwp_handle_connection($@)
{   my ($connection, %args) = @_;
    my $expires  = $args{expires};
    my $maxmsgs  = $args{maxmsgs};
    my $reqbonus = $args{reqbonus};
    my $postproc = $args{postprocess};

    local $SIG{ALRM} = sub { die "timeout\n" };

    my $timeleft;
    while(($timeleft = $expires - time) > 0.01)
    {   alarm $timeleft if $timeleft;
        my $request  = $connection->get_request;
        alarm 0;
        $request or last;

        my $response = lwp_run_request $request, $args{handler}
          , $connection, $postproc;

        $connection->force_last_request if $maxmsgs==1;
        $connection->send_response($response);

        --$maxmsgs or last;
        $expires += $reqbonus;
    }
}


sub lwp_run_request($$;$$)
{   my ($request, $handler, $connection, $postproc) = @_;

#   my $client   = $connection->peerhost;
    return $wsdl_response
        if $wsdl_response
        && $request->method eq 'GET'
        && uc($request->uri->query || '') eq 'WSDL';

    if($request->method !~ m/^(?:M-)?POST/ )
    {   return lwp_make_response $request
          , RC_METHOD_NOT_ALLOWED
          , 'only POST or M-POST'
          , "attempt to connect via ".$request->method;
    }

    my $media    = $request->content_type || 'text/plain';
    $media =~ m{[/+]xml$}i
        or return lwp_make_response $request
          , RC_NOT_ACCEPTABLE
          , 'required is XML'
          , "content-type seems to be $media, must be some XML";

    my $action   = lwp_action_from_header $request;
    my $ct       = $request->header('Content-Type');
    my $charset  = $ct =~ m/\;\s*type\=(["']?)([\w-]*)\1/ ? $2: 'utf-8';
    my $xmlin    = $request->decoded_content(charset => $charset, ref => 1);

    my ($status, $status_msg, $xml)
      = $handler->($xmlin, $request, $action);

    lwp_make_response $request, $status, $status_msg, $xml, $postproc;
}


sub lwp_make_response($$$$;$)
{   my ($request, $status, $msg, $body, $postproc) = @_;

    my $response = HTTP::Response->new($status, $msg);
    $response->header(@default_headers);
    $response->protocol($request->protocol);  # match request's

    my $s;
    if(UNIVERSAL::isa($body, 'XML::LibXML::Document'))
    {   $s = $body->toString($status == RC_OK ? 0 : 1);
        $response->header('Content-Type' => 'text/xml; charset=utf-8');
    }
    else
    {   $s = "[$status] $body";
        $response->header(Content_Type => 'text/plain');
    }

    $postproc->($request, $response, $status, \$s)
        if $postproc;

    $response->content_ref(\$s);
    { use bytes; $response->header('Content-Length' => length $s); }

    if(substr($request->method, 0, 2) eq 'M-')
    {   # HTTP extension framework.  More needed?
        $response->header(Ext => '');
    }

    $response;
}


sub lwp_action_from_header($)
{   my ($request) = @_;

    my $action;
    if($request->method eq 'POST')
    {   $action = $request->header('SOAPAction');
    }
    elsif($request->method eq 'M-POST')
    {   # Microsofts HTTP Extension Framework
        my $http_ext_id = '"' . MSEXT . '"';
        my $man = first { m/\Q$http_ext_id\E/ } $request->header('Man');
        defined $man or return undef;

        $man =~ m/\;\s*ns\=(\d+)/ or return undef;
        $action = $request->header("$1-SOAPAction");
    }
    else
    {   return undef;
    }

    defined $action or return;

    $action =~ s/["'\s]//g;  # often wrong blanks and quotes
    $action;
}


sub lwp_socket_init($)
{   my $socket = shift;
    my $http11_impl = $socket->isa('IO::Socket::SSL')
      ? 'HTTP::Daemon::SSL' : 'HTTP::Daemon';

    eval "require $http11_impl";
    error $@ if $@;
}


sub lwp_http11_connection($$)
{   my ($daemon, $client) = @_;
    my $http11_impl = $client->isa('IO::Socket::SSL')
      ? 'HTTP::Daemon::ClientConn::SSL' : 'HTTP::Daemon::ClientConn';

    # Ugly hack: hijack the HTTP11 implementation of HTTP::Daemon
    my $connection  = bless $client, $http11_impl;
    ${*$connection}{httpd_daemon} = $daemon;
    $connection;
}


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

1;