Net::DRI::Transport::HTTP::XMLRPCLite - XML-RPC Transport for Net::DRI

## Domain Registry Interface, XML-RPC Transport
##
## Copyright (c) 2008-2010 Patrick Mevzek <netdri@dotandco.com>. All rights reserved.
##
## This file is part of Net::DRI
##
## Net::DRI is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## See the LICENSE file that comes with this distribution for more details.
#
# 
#
####################################################################################################

package Net::DRI::Transport::HTTP::XMLRPCLite;

use strict;
use warnings;

use base qw(Net::DRI::Transport);

use Net::DRI::Exception;
use Net::DRI::Data::Raw;
use Net::DRI::Util;
use XMLRPC::Lite;

our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); };

####################################################################################################
sub new
{
 my ($class,$ctx,$rp)=@_;
 my %opts=%$rp;
 my $po=$ctx->{protocol};

 my %t=(message_factory => $po->factories()->{message});
 if (exists($opts{protocol_connection}) && $opts{protocol_connection})
 {
  $t{protocol_connection}=$opts{protocol_connection};
  $t{protocol_connection}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{protocol_connection},$@);
  if ($t{protocol_connection}->can('transport_default'))
  {
   %opts=($t{protocol_connection}->transport_default('xmlrpclite'),%opts);
  }
 }

 my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance
 $self->is_sync(1);
 $self->name('xmlrpclite');
 $self->version($VERSION);

 $t{has_login}=(exists($opts{has_login}) && defined($opts{has_login}))? $opts{has_login} : 0;
 $t{has_logout}=(exists($opts{has_logout}) && defined($opts{has_logout}))? $opts{has_logout} : 0;
 $self->has_state($t{has_login});
 if ($t{has_login})
 {
  foreach my $p (qw/client_login client_password/)
  {
   Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p}));
   $t{$p}=$opts{$p};
  }
  $t{session_data}={};
 }

 foreach my $p (qw/protocol_connection proxy_uri/)
 {
  Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p}));
  $t{$p}=$opts{$p};
 }
 Net::DRI::Exception::usererr_invalid_parameters('proxy_uri must be http:// or https://') unless ($t{proxy_uri}=~m!^https?://!);

 my $pc=$t{protocol_connection};
 if ($t{has_login})
 {
  foreach my $m (qw/login parse_login extract_session/)
  {
   Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_login=1') unless ($pc->can($m));
  }
 }

 if ($t{has_logout})
 {
  foreach my $m (qw/logout parse_logout/)
  {
   Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_logout=1') unless ($pc->can($m));
  }
 }

 $self->{transport}=\%t;
 bless($self,$class);

 if ($self->has_state())
 {
  if ($self->defer()) ## we will open, but later
  {
   $self->current_state(0);
  } else ## we will open NOW
  {
   $self->open_connection($ctx);
  }
 } else
 {
  $self->init();
  $self->time_open(time());
 }

 return $self;
}

sub soap { my ($self,$v)=@_; $self->{transport}->{soap}=$v if @_==2; return $self->{transport}->{soap}; }
sub session_data { my ($self,$v)=@_; $self->{transport}->{session_data}=$v if @_==2; return $self->{transport}->{session_data}; }

sub init
{
 my ($self)=@_;
 return if defined($self->soap());
 my $soap=XMLRPC::Lite->new();
 $soap->proxy($self->{transport}->{proxy_uri});
 $soap->transport()->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP::XMLRPCLite/%s ',$Net::DRI::VERSION,$VERSION).$soap->transport()->agent());
 $self->soap($soap);
}

sub send_login
{
 my ($self,$ctx)=@_;
 my $t=$self->{transport};
 return unless $t->{has_login};
 foreach my $p (qw/client_login client_password/)
 {
  Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p});
 }

 my $pc=$t->{protocol_connection};
 my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
 my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid);
 my $res=$self->_send_receive({otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening'},$login);
 my $msg=$t->{message_factory}->();
 $msg->parse(Net::DRI::Data::Raw->new(1,[$res]));
 my $rc=$pc->parse_login($msg);
 die($rc) unless $rc->is_success();

 $self->session_data($pc->extract_session($msg));
}

sub send_logout
{
 my ($self)=@_;
 my $t=$self->{transport};
 return unless $t->{has_logout};

 my $pc=$t->{protocol_connection};
 my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
 my $logout=$pc->logout($t->{message_factory},$cltrid,$t->{session_data});
 my $res=$self->_send_receive({otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing'},$logout);
 my $msg=$t->{message_factory}->();
 $msg->parse(Net::DRI::Data::Raw->new(1,[$res]));
 my $rc=$pc->parse_logout($msg);
 die($rc) unless $rc->is_success();

 $self->session_data({});
}

sub _send_receive
{
 my ($self,$ctx,$msg)=@_;
 my $soap=$self->soap();
 my $err;
 my $res=$soap->on_fault(sub { (undef,$err)=@_; return; })->call($msg->method(),@{$msg->params()});
 if (my $httpres=$soap->transport()->http_response())
 {
  $self->log_output('notice','transport',$ctx,{direction=>'out',message=>$httpres->request()});
  $self->log_output('notice','transport',$ctx,{direction=>'in', message=>$httpres});
 } else
 {
  $self->log_output('error','transport',$ctx,{direction=>'out',message=>'No response for message '.$soap->serializer()->envelope(method => $msg->method(), @{$msg->params()})});
 }
 return $res if defined $res && ref $res && ! $res->fault() && ! defined $err;

 Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP fault: '.$err->faultcode().' '.$err->faultstring()) if defined $err && ref $err;
 Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP transport error: '.$soap->transport()->status()) unless $soap->transport()->is_success();
 Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP deserialization error: '.$err);
}

sub open_connection
{
 my ($self,$ctx)=@_;
 $self->init();
 $self->send_login($ctx);
 $self->current_state(1);
 $self->time_open(time());
 $self->time_used(time());
}

sub close_connection
{
 my ($self)=@_;
 $self->send_logout();
 $self->soap(undef);
 $self->current_state(0);
}

sub end
{
 my ($self)=@_;
 if ($self->has_state() && $self->current_state())
 {
  eval
  {
   local $SIG{ALRM}=sub { die 'timeout' };
   alarm(10);
   $self->close_connection();
  };
  alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases
 }
}

####################################################################################################

sub send
{
 my ($self,$ctx,$tosend)=@_;
 $self->SUPER::send($ctx,$tosend,\&_soap_send,sub {});
}

sub _soap_send
{
 my ($self,$count,$tosend,$ctx)=@_;
 my $t=$self->{transport};
 $tosend->add_session($self->session_data()) if $tosend->can('add_session');
 my $res=$self->_send_receive($ctx,$tosend);
 $t->{last_reply}=$res;
 return 1; ## very important
}

sub receive
{
 my ($self,$ctx,$count)=@_;
 return $self->SUPER::receive($ctx,\&_soap_receive);
}

sub _soap_receive
{
 my ($self,$count)=@_;
 my $t=$self->{transport};
 my $r=$t->{last_reply};
 $t->{last_reply}=undef;
 return Net::DRI::Data::Raw->new(6,[$r]);
}

####################################################################################################
1;