File Coverage

blib/lib/Alien/Base/ModuleBuild/Repository/HTTP.pm

Criterion	Covered	Total	%
statement	117	129	90.7
branch	32	48	66.6
condition	22	34	64.7
subroutine	19	19	100.0
pod	0	10	0.0
total	190	240	79.1

package Alien::Base::ModuleBuild::Repository::HTTP;

use strict;
use warnings;
use Carp;
use HTTP::Tiny;
use Scalar::Util qw( blessed );
use URI;
use Alien::Base::ModuleBuild::Utils;
use parent 'Alien::Base::ModuleBuild::Repository';

# ABSTRACT: HTTP repository handler
our $VERSION = '1.16_01'; # TRIAL VERSION
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)

our $Has_HTML_Parser = eval { require HTML::LinkExtor; 1 };

sub is_network_fetch { 1 }

sub is_secure_fetch {
  my($self) = @_;

  (defined $self->{exact_filename} && $self->{exact_filename} =~ /^https:/) || ($self->{protocol}||'http') eq 'https';
}

sub connection {

  my $self = shift;

  return $self->{connection}
    if $self->{connection};

  # allow easy use of HTTP::Tiny subclass
  $self->{protocol_class} ||= 'HTTP::Tiny';
  my $module = $self->{protocol_class};
  $module =~ s{::}{/}g;
  $module .= '.pm';
  eval { require $module; 1 }
    or croak "Could not load protocol_class '$self->{protocol_class}': $@";

  my %args;

  if($self->{protocol_class}->isa('HTTP::Tiny'))
  {
    $args{agent} = "Alien-Base-ModuleBuild/HTTP::Tiny/@{[ $Alien::Base::ModuleBuild::VERSION || 'dev' ]}";
    require Alien::Base::ModuleBuild;
    $args{verify_SSL} = 1 if Alien::Base::ModuleBuild->alien_download_rule =~ /encrypt/;
  }
  elsif($self->{protocol_class}->isa('LWP::UserAgent'))
  {
    $args{agent} = "Alien-Base-ModuleBuild/LWP::UserAgent/@{[ $Alien::Base::ModuleBuild::VERSION || 'dev' ]}";
    # Note this is the default for recent LWP
    $args{ssl_opts} = { verify_hostname => 1 } if Alien::Base::ModuleBuild->alien_download_rule =~ /encrypt/;
  }
  else
  {
    die "unsupported protocol class: @{[ $self->{protocol_class} ]}";
  }

  my $http = $self->{protocol_class}->new(%args);

  $self->{connection} = $http;

  return $http;

}

sub get_file {
  my $self = shift;
  my $file = shift || croak "Must specify file to download";

  my $protocol = $self->protocol;
  my $host = $self->{host};
  my $from = $self->location;

  my $uri = $self->build_uri($protocol, $host, $from, $file);
  $file = ($uri->path_segments())[-1];

  die "Attempted downgrad from https to http on URL $uri" if $self->is_secure_fetch && $uri !~ /^https:/;

  my $res = $self->connection->mirror($uri, $file);
  my ( $is_error, $content, $headers ) = $self->check_http_response( $res );
  croak "Download failed: " . $content if $is_error;

  my $disposition = $headers->{"content-disposition"};
  if ( defined($disposition) && ($disposition =~ /filename="([^"]+)"/ || $disposition =~ /filename=([^\s]+)/)) {
    my $new_filename = $1;
    rename $file, $new_filename;
    $self->{new_filename} = $new_filename;
  }

  return $file;
}

sub list_files {
  my $self = shift;

  my $protocol = $self->protocol;
  my $host = $self->host;
  my $location = $self->location;
  my $uri = $self->build_uri($protocol, $host, $location);

  die "Attempted downgrad from https to http on URL $uri" if $self->is_secure_fetch && $uri !~ /^https:/;

  my $res = $self->connection->get($uri);

  my ( $is_error, $content, undef, $base_url ) = $self->check_http_response( $res );
  if ( $is_error ) {
    carp $content;
    return ();
  }

  $self->{base_url} = $base_url;

  my @links = $self->find_links($content);

  return @links;
}

sub find_links {
  my $self = shift;
  my ($html) = @_;

  my @links;
  if ($Has_HTML_Parser) {
    push @links, $self->find_links_preferred($html)
  } else {
    push @links, $self->find_links_textbalanced($html)
  }

  return @links;
}

sub find_links_preferred {
  my $self = shift;
  my ($html) = @_;

  my @links;

  my $extor = HTML::LinkExtor->new(
    sub {
      my ($tag, %attrs) = @_;
      return unless $tag eq 'a';
      return unless defined $attrs{href};
      push @links, $attrs{href};
    },
  );

  $extor->parse($html);

  return @links;
}

sub find_links_textbalanced {
  my $self = shift;
  my ($html) = @_;
  return Alien::Base::ModuleBuild::Utils::find_anchor_targets($html);
}

sub build_uri {
  my $self = shift;
  my ($protocol, $host, $path, $target) = @_;

  my $uri;
  if (defined $host) {
    my $base = $self->{base_url};
    unless($base)
    {
      $base = URI->new($host);
      unless (defined $base->scheme) {
        $base = URI->new(($protocol || 'http') ."://$host");
      }
      $base->path($path) if defined $path;
    }
    $uri = URI->new_abs($target, $base);
  }
  else {
    $uri = URI->new($target);
  }
  return $uri->canonical;
}

sub check_http_response {
  my ( $self, $res ) = @_;
  if ( blessed $res && $res->isa( 'HTTP::Response' ) ) {
    my %headers = map { lc $_ => $res->header($_) } $res->header_field_names;
    if ( !$res->is_success ) {
      return ( 1, $res->status_line . " " . $res->decoded_content, \%headers, $res->request->uri );
    }
    return ( 0, $res->decoded_content, \%headers, $res->request->uri );
  }
  else {
    if ( !$res->{success} ) {
      my $reason = $res->{status} == 599 ? $res->{content} : "@{[ $res->{status} ]} @{[ $res->{reason} ]}";
      if($res->{status} == 599 && $reason =~ /https support/)
      {
        $reason .= "See https://github.com/PerlAlien/Alien-Base-ModuleBuild/issues/6#issuecomment-417097485";
      }
      return ( 1, $reason, $res->{headers}, $res->{url} );
    }
    return ( 0, $res->{content}, $res->{headers}, $res->{url} );
  }
}

1;

__END__