File Coverage

blib/lib/LWP/Protocol/AnyEvent/http.pm

Criterion	Covered	Total	%
statement	78	102	76.4
branch	15	44	34.0
condition	0	11	0.0
subroutine	15	16	93.7
pod	1	1	100.0
total	109	174	62.6

package LWP::Protocol::AnyEvent::http;

use strict;
use warnings;

use version; our $VERSION = qv('v1.10.0');

use AnyEvent            qw( );
use AnyEvent::HTTP      qw( http_request );
use HTTP::Response      qw( );
use LWP::Protocol       qw( );
use LWP::Protocol::http qw( );

our @ISA = 'LWP::Protocol';

LWP::Protocol::implementor($_, __PACKAGE__) for qw( http https );


# This code was based on _extra_sock_opts in LWP::Protocol::https
sub _get_tls_ctx {
   my ($self) = @_;
   my %ssl_opts = %{ $self->{ua}{ssl_opts} || {} };
   my %tls_ctx;

   # Convert various ssl_opts values to corresponding AnyEvent::TLS tls_ctx values.
   $tls_ctx{ verify          } = $ssl_opts{SSL_verify_mode};
   $tls_ctx{ verify_peername } = 'http'                   if defined($ssl_opts{SSL_verifycn_scheme}) && $ssl_opts{SSL_verifycn_scheme} eq 'www';
   $tls_ctx{ ca_file         } = $ssl_opts{SSL_ca_file}   if exists($ssl_opts{SSL_ca_file});
   $tls_ctx{ ca_path         } = $ssl_opts{SSL_ca_path}   if exists($ssl_opts{SSL_ca_path});
   $tls_ctx{ cert_file       } = $ssl_opts{SSL_cert_file} if exists($ssl_opts{SSL_cert_file});
   $tls_ctx{ cert            } = $ssl_opts{SSL_cert}      if exists($ssl_opts{SSL_cert});
   $tls_ctx{ key_file        } = $ssl_opts{SSL_key_file}  if exists($ssl_opts{SSL_key_file});
   $tls_ctx{ key             } = $ssl_opts{SSL_key}       if exists($ssl_opts{SSL_key});

   if ($ssl_opts{verify_hostname}) {
      $tls_ctx{verify} ||= 1;
      $tls_ctx{verify_peername} = 'http';
   }

   # We are verifying certificates, but don't have any CA specified, so we try using Mozilla::CA.
   if ($tls_ctx{verify} && !( exists($tls_ctx{ca_file}) || exists($tls_ctx{ca_path}) )) {
      if (!eval { require Mozilla::CA }) {
         if ($@ !~ /^Can\'t locate Mozilla\/CA\.pm/) {
            die  'Unable to find a list of Certificate Authorities to trust. '
               . 'To fix this error, either install Mozilla::CA or configure '
               . 'the ssl_opts as documented in LWP::UserAgent';
         } else {
            die $@;
         }
      }

      $tls_ctx{ca_file} = Mozilla::CA::SSL_ca_file();
   }

   return \%tls_ctx;
}


sub _set_response_headers {
   my ($response, $headers) = @_;

   my %headers = %$headers;

   $response->protocol( "HTTP/".delete($headers{ HTTPVersion }) )
      if $headers{ HTTPVersion };
   $response->code(             delete($headers{ Status      }) );
   $response->message(          delete($headers{ Reason      }) );

   # Uppercase headers are pseudo headers added by AnyEvent::HTTP.
   $headers{"X-AE-$_"} = delete($headers{$_}) for grep /^(?!X-)[A-Z]/, keys(%headers);

   if (exists($headers->{'set-cookie'})) {
      # Set-Cookie headers are very non-standard.
      # They cannot be safely joined.
      # Try to undo their joining for HTTP::Cookies.
      $headers{'set-cookie'} = [
         split(/,(?=\s*\w+\s*(?:[=,;]|\z))/, $headers{'set-cookie'})
      ];
   }

   # Imitate Net::HTTP's removal of newlines.
   s/\s*\n\s+/ /g
      for values %headers;

   $response->header(%headers);
}


sub request {
   my ($self, $request, $proxy, $arg, $size, $timeout) = @_;

   my $method = $request->method();
   my $url    = $request->uri();

   my %headers;
   {
      my $headers_obj = $request->headers->clone();

      # Convert user:pass in url into an Authorization header.
      LWP::Protocol::http->_fixup_header($headers_obj, $url, $proxy);

      $headers_obj->scan(sub {
         my ($k, $v) = @_;
         # Imitate LWP::Protocol::http's removal of newlines.
         $v =~ s/\n/ /g;
         $headers{ lc($k) } = $v;
      });
   }

   my $body = $request->content_ref();

   # Fix AnyEvent::HTTP setting Referer to the request URL
   $headers{referer} = undef unless exists $headers{referer};

   # The status code will be replaced.
   my $response = HTTP::Response->new(599, 'Internal Server Error');
   $response->request($request);

   my $headers_avail = AnyEvent->condvar();
   my $data_avail    = AnyEvent->condvar();
   my @data_queue;

   my %handle_opts;
   $handle_opts{read_size}     = $size if defined($size);
   $handle_opts{max_read_size} = $size if defined($size);

   my %opts = ( handle_params => \%handle_opts );
   $opts{body}    = $$body   if defined($body);
   $opts{timeout} = $timeout if defined($timeout);

   if ($url->scheme eq 'https') {
      $opts{tls_ctx} = $self->_get_tls_ctx();
   }

   if ($proxy) {
      my $proxy_uri = URI->new($proxy);
      $opts{proxy} = [ $proxy_uri->host, $proxy_uri->port, $proxy_uri->scheme ];
   }

   # Let LWP handle redirects and cookies.
   http_request(
      $method => $url,
      headers => \%headers,
      %opts,
      recurse => 0,
      on_header => sub {
         #my ($headers) = @_;
         _set_response_headers($response, $_[0]);
         $headers_avail->send();
         return 1;
      },
      on_body => sub {
         #my ($chunk, $headers) = @_;
         push @data_queue, \$_[0];
         $data_avail->send();
         return 1;
      },
      sub { # On completion
         # On successful completion: @_ = ( '',    $headers )
         # On error:                 @_ = ( undef, $headers )

         # It is possible for the request to complete without
         # calling the header callback in the event of error.
         # It is also possible for the Status to change as the
         # result of an error. This handles these events.
         _set_response_headers($response, $_[1]);
         $headers_avail->send();

         push @data_queue, \'';    # '
         $data_avail->send();
      },
   );

   # We need to wait for the headers so the response code
   # is set up properly. LWP::Protocol decides on ->is_success
   # whether to call the :content_cb or not.
   $headers_avail->recv();

   return $self->collect($arg, $response, sub {
      if (!@data_queue) {
         # Re-prime our channel, in case there is more.
         $data_avail = AnyEvent->condvar();

         # Wait for more data to arrive
         $data_avail->recv();
      };

      return shift(@data_queue);
   });
}


1;


__END__