view release on metacpan or  search on metacpan

lib/Net/DRI/Transport/HTTP.pm  view on Meta::CPAN

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.

=cut

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

## These ENV keys will be set each time just before doing HTTP stuff, making sure to remove pre-existing ones beforehand
## This should enable us to deal with multiple endpoints with various parameters at the same time (BUT this should be really tested)
our @HTTPS_ENV=qw/HTTPS_DEBUG HTTPS_VERSION HTTPS_CERT_FILE HTTPS_KEY_FILE HTTPS_CA_FILE HTTPS_CA_DIR/;

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

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

 my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance
 $self->has_state(1); ## some registries need login (like .PL) some not (like .ES) ; see end of method & call to open_connection()
 $self->is_sync(1);
 $self->name('http');
 $self->version($VERSION);

 foreach my $k (qw/client_login client_password client_newpassword protocol_data/)
 {
  $t{$k}=$opts{$k} if exists($opts{$k});
 }

 my @need=qw/read_data write_message/;
 Net::DRI::Exception::usererr_invalid_parameters('protocol_connection class must have: '.join(' ',@need)) if (grep { ! $t{pc}->can($_) } @need);
 $t{protocol_data}=$opts{protocol_data} if (exists($opts{protocol_data}) && $opts{protocol_data});
 Net::DRI::Exception::usererr_insufficient_parameters('remote_url must be defined') unless (exists $opts{'remote_url'} && defined $opts{'remote_url'});
 Net::DRI::Exception::usererr_invalid_parameters('remote_url must be an uri starting with http:// or https:// with a proper path') unless $opts{remote_url}=~m!^https?://\S+/\S*$!;
 $t{remote_url}=$opts{remote_url};
 $t{remote_uri}=$t{remote_url}; ## only used for error messages

 my $ua=LWP::UserAgent->new();
 $ua->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP/%s ',$Net::DRI::VERSION,$VERSION)); ## the final space triggers LWP::UserAgent to add its own string
 $ua->cookie_jar({}); ## Cookies needed by some registries, like .PL (how strange !)
 ## Now some security settings
 $ua->max_redirect(0);
 $ua->parse_head(0);
 $ua->protocols_allowed(['http','https']);
 $ua->timeout($self->timeout()) if $self->timeout(); ## problem with our own alarm ?
 $t{ua}=$ua;

 $t{local_host}=$opts{local_host} if (exists($opts{local_host}) && $opts{local_host});
 $t{setenv}=0;
 foreach my $k (map { lc } @HTTPS_ENV) ## Backport this stuff to other Transport modules in order to handle multiple differents sets of env values ?
 {
  next unless (exists($opts{$k}) && defined($opts{$k}));
  $t{setenv}=1;
  $t{$k}=$opts{$k};
 }

 $t{verify_response}=$opts{verify_response} if (exists($opts{verify_response}) && defined($opts{verify_response}) && (ref($opts{verify_response}) eq 'CODE'));
 $self->{transport}=\%t;
 $t{pc}->init($self) if $t{pc}->can('init');

 $self->open_connection($ctx); ## noop for registries without login, will properly setup has_state()
 return $self;
}

sub send_login
{
 my ($self,$ctx)=@_;
 my $t=$self->transport_data();
 my $pc=$t->{pc};
 my ($cltrid,$dr);

 ## Get registry greeting, if available
 if ($pc->can('greeting') && $pc->can('parse_greeting'))
 {
  $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); ## not used for greeting (<hello> has no clTRID), but used in logging
  my $greeting=$pc->greeting($t->{message_factory});
  $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'out',message=>$greeting});
  Net::DRI::Exception->die(0,'transport/http',4,'Unable to send greeting message to '.$t->{remote_uri}) unless $self->_http_send(1,$greeting,1);
  $dr=$self->_http_receive(1);
  $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr});
  my $rc1=$pc->parse_greeting($dr); ## gives back a Net::DRI::Protocol::ResultStatus
  die($rc1) unless $rc1->is_success();
 }

 my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid,$dr,$t->{client_newpassword},$t->{protocol_data});
 $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'out',message=>$login});
 Net::DRI::Exception->die(0,'transport/http',4,'Unable to send login message to '.$t->{remote_uri}) unless $self->_http_send(1,$login,1);
 $dr=$self->_http_receive(1);
 $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr});
 my $rc2=$pc->parse_login($dr); ## gives back a Net::DRI::Protocol::ResultStatus
 die($rc2) unless $rc2->is_success();
}

sub open_connection
{
 my ($self,$ctx)=@_;
 my $t=$self->transport_data();
 my $pc=$t->{pc};
 $self->has_state(0);

 if ($pc->can('login') && $pc->can('parse_login'))
 {
  $self->send_login($ctx);
  $self->has_state(1);
  $self->current_state(1);
 }

 $self->time_open(time());
 $self->time_used(time());
 $self->transport_data()->{exchanges_done}=0;
}

sub send_logout
{
 my ($self)=@_;
 my $t=$self->transport_data();
 my $pc=$t->{pc};

 return unless ($pc->can('logout') && $pc->can('parse_logout'));

 my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
 my $logout=$pc->logout($t->{message_factory},$cltrid);
 $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'out',message=>$logout});
 Net::DRI::Exception->die(0,'transport/http',4,'Unable to send logout message to '.$t->{remote_uri}) unless $self->_http_send(1,$logout,3);
 my $dr=$self->_http_receive(1);
 $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'in',message=>$dr});
 my $rc1=$pc->parse_logout($dr);
 die($rc1) unless $rc1->is_success();
}

sub close_connection
{
 my ($self)=@_;
 $self->send_logout() if ($self->has_state() && $self->current_state());
 $self->transport_data()->{ua}->cookie_jar({});
 $self->current_state(0);
}

sub end
{
 my ($self)=@_;
 if ($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,\&_http_send,sub {});
}

sub _http_send
{
 my ($self,$count,$tosend,$phase)=@_;
 $phase=2 unless defined($phase); ## Phase 2 = normal operations (1=greeting+login, 3=logout)
 my $t=$self->transport_data();

 ## Having two lines put the warnings away. This module is loaded by LWP::UserAgent anyway.
 @LWP::Protocol::http::EXTRA_SOCK_OPTS=();
 @LWP::Protocol::http::EXTRA_SOCK_OPTS=( LocalAddr => $t->{local_host} ) if exists($t->{local_host});
 if ($t->{setenv})
 {
  foreach my $k (map { lc } @HTTPS_ENV)
  {
   delete($ENV{uc($k)});
   next unless exists($t->{$k});
   $ENV{uc($k)}=$t->{$k};
  }
 }

 ## Content-Length is automatically computed and added during the request() call, no need to do it before
 my $req=$t->{pc}->write_message($self,$tosend); ## gives back an HTTP::Request object
 Net::DRI::Util::check_isa($req,'HTTP::Request');
 my $ans=$t->{ua}->request($req);
 $t->{verify_response}->($self,$phase,$count,$req,$ans) if exists($t->{verify_response});
 $t->{last_reply}=$ans;
 return 1; ## very important
}

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

sub _http_receive
{
 my ($self,$count)=@_;
 my $t=$self->transport_data();

 ## Convert answer in a Net::DRI::Data::Raw object
 my $dr=$t->{pc}->read_data($self,$t->{last_reply});
 Net::DRI::Util::check_isa($dr,'Net::DRI::Data::Raw');
 $t->{last_reply}=undef;
 $t->{exchanges_done}++;
 return $dr;
}

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