Pull release tarballs via https if not available locally

cpanfile

@@ -10,7 +10,6 @@ requires 'Catalyst', '5.90128';
 requires 'Catalyst::Action::RenderView', '0.16';
 requires 'Catalyst::Controller::REST', '1.21';
 requires 'Catalyst::Plugin::Authentication';
-requires 'Catalyst::Plugin::ConfigLoader';
 requires 'Catalyst::Plugin::Session', '0.43';
 requires 'Catalyst::Plugin::Session::State::Cookie';
 requires 'Catalyst::Plugin::Session::Store';
@@ -29,6 +28,7 @@ requires 'CPAN::Meta::YAML', '0.018';
 requires 'CPAN::Repository::Perms';
 requires 'Cwd';
 requires 'Data::Dumper';
+requires 'Data::Visitor::Callback';
 requires 'DateTime', '1.54';
 requires 'DateTime::Format::ISO8601';
 requires 'DBD::SQLite', '1.66';

lib/MetaCPAN/Server/Config.pm

@@ -3,8 +3,9 @@ package MetaCPAN::Server::Config;
 use warnings;
 use strict;
 
-use Config::ZOMG   ();
-use MetaCPAN::Util qw(root_dir);
+use Config::ZOMG            ();
+use MetaCPAN::Util          qw(root_dir);
+use Data::Visitor::Callback ();
 
 sub config {
     my $root   = root_dir();
@@ -30,6 +31,16 @@ sub _zomg {
     if ( defined $c->{logger} && ref $c->{logger} ne 'ARRAY' ) {
         $c->{logger} = [ $c->{logger} ];
     }
+
+    my $root = root_dir();
+    my $v    = Data::Visitor::Callback->new(
+        plain_value => sub {
+            return unless defined $_;
+            s{__HOME__}{$root}ge;
+        }
+    );
+    $v->visit($c);
+
     return keys %{$c} ? $c : undef;
 }
 

lib/MetaCPAN/Server/Controller/Source.pm

@@ -21,13 +21,11 @@ sub get : Chained('index') : PathPart('') : Args {
     $c->add_author_key($author);
     $c->cdn_max_age('1y');
 
-    my $path = join( '/', @path );
-    my $file = $c->model('Source')->path( $author, $release, $path )
+    my $file = $c->model('Source')->path( $author, $release, @path )
         or $c->detach( '/not_found', [] );
     if ( $file->is_dir ) {
-        $path = "/source/$author/$release/$path";
-        $path =~ s/\/$//;
-        my $env = $c->req->env;
+        my $path = '/source/' . join( '/', $author, $release, @path );
+        my $env  = $c->req->env;
         local $env->{PATH_INFO}   = '/';
         local $env->{SCRIPT_NAME} = $path;
         my $res = Plack::App::Directory->new( { root => $file->stringify } )

lib/MetaCPAN/Server/Model/Source.pm

@@ -1,85 +1,188 @@
 package MetaCPAN::Server::Model::Source;
-
 use strict;
 use warnings;
 
-use File::Find::Rule          ();
-use MetaCPAN::Model::Archive  ();
-use MetaCPAN::Types::TypeTiny qw( Path );
+use Archive::Any              ();
+use MetaCPAN::Types::TypeTiny qw( Path Uri );
 use MetaCPAN::Util            ();
 use Moose;
 use Path::Tiny ();
 
 extends 'Catalyst::Model';
 
 has base_dir => (
-    is       => 'ro',
-    isa      => Path,
-    coerce   => 1,
-    required => 1,
+    is      => 'ro',
+    isa     => Path,
+    coerce  => 1,
+    default => 'var/tmp/source',
 );
 
 has cpan => (
-    is       => 'ro',
-    isa      => Path,
-    coerce   => 1,
-    required => 1,
+    is     => 'ro',
+    isa    => Path,
+    coerce => 1,
+);
+
+has remote_cpan => (
+    is     => 'ro',
+    isa    => Uri,
+    coerce => 1,
+);
+
+has es_query => (
+    is     => 'ro',
+    writer => '_set_es_query',
+);
+
+has http_cache_dir => (
+    is      => 'ro',
+    isa     => Path,
+    coerce  => 1,
+    default => 'var/tmp/http',
+);
+
+has ua => (
+    is      => 'ro',
+    default => sub {
+        LWP::UserAgent->new( agent => 'metacpan-api/1.0', );
+    },
 );
 
 sub COMPONENT {
     my $self = shift;
     my ( $app, $config ) = @_;
+    my $app_config = $app->config;
+
     $config = $self->merge_config_hashes(
         {
-            cpan     => $app->config->{cpan},
-            base_dir => $app->config->{source_base}
-                || $self->_default_base_dir,
+            ( $app_config->{cpan} ? ( cpan => $app_config->{cpan} ) : () ),
+            (
+                $app_config->{base_dir}
+                ? ( base_dir => $app_config->{base_dir} )
+                : ()
+            ),
+            (
+                $app_config->{remote_cpan}
+                ? ( remote_cpan => $app_config->{remote_cpan} )
+                : ()
+            ),
         },
-        $config
+        $config,
     );
     return $self->SUPER::COMPONENT( $app, $config );
 }
 
-sub _default_base_dir {
-    return Path::Tiny::path(qw(var tmp source));
+sub ACCEPT_CONTEXT {
+    my ( $self, $c ) = @_;
+    if ( !$self->es_query ) {
+        $self->_set_es_query( $c->model('ESQuery') );
+    }
+    return $self;
 }
 
 sub path {
-    my ( $self, $pauseid, $distvname, $file ) = @_;
-    $file ||= q{};
-    my $base       = $self->base_dir;
-    my $source_dir = Path::Tiny::path( $base, $pauseid, $distvname );
-    my $source     = $self->find_file( $source_dir, $file );
-    return $source if ($source);
-    return if -e $source_dir;  # previously extracted, but file does not exist
-
-    my $author = MetaCPAN::Util::author_dir($pauseid);
-    my $http   = Path::Tiny::path( qw(var tmp http authors), $author );
-    $author = $self->cpan . "/authors/$author";
-
-    my ($archive_file)
-        = File::Find::Rule->new->file->name(
-        qr/^\Q$distvname\E\.(tgz|tbz|tar[\._-]gz|tar\.bz2|tar\.Z|zip|7z)$/)
-        ->in( $author, $http );
-    return unless ( $archive_file && -e $archive_file );
-
-    $source_dir->mkpath;
-    my $archive = MetaCPAN::Model::Archive->new(
-        file        => $archive_file,
-        extract_dir => $source_dir
-    );
+    my ( $self, $pauseid, $distvname, @file ) = @_;
+    my $base        = $self->base_dir;
+    my $source_base = Path::Tiny::path( $base, $pauseid, $distvname );
+    my $source      = $source_base->child( $distvname, @file );
+    return $source
+        if -e $source;
+    return undef
+        if -e $source_base;    # previously extracted, but file does not exist
+
+    my $release_data
+        = $self->es_query->release->by_author_and_name( $pauseid, $distvname )
+        ->{release}
+        or return undef;
+
+    my $author_path = MetaCPAN::Util::author_dir($pauseid);
+
+    my $http_author_dir
+        = $self->http_cache_dir->child( 'authors', $author_path );
+
+    my $local_cpan = $self->cpan;
+    my $cpan_author_dir
+        = $local_cpan && $local_cpan->child( 'authors', $author_path );
+
+    my $archive = $release_data->{archive};
+    my ($local_archive)
+        = grep -e,
+        map $_->child($archive),
+        grep defined,
+        ( $cpan_author_dir, $http_author_dir );
 
-    return if $archive->is_naughty;
-    $archive->extract;
+    if ( !$local_archive ) {
+        $local_archive = $http_author_dir->child($archive);
+        $self->fetch_from_cpan( $release_data->{download_url},
+            $local_archive )
+            or return undef;
+    }
+    my $extracted
+        = $self->extract_in( $local_archive, $source_base, $distvname );
 
-    return $self->find_file( $source_dir, $file );
+    return undef
+        if !-e $source;
+
+    return $source;
 }
 
-sub find_file {
-    my ( $self, $dir, $file ) = @_;
-    my ($source) = glob "$dir/*/$file";    # file can be in any subdirectory
-    ($source) ||= glob "$dir/$file";       # file can be in any subdirectory
-    return $source && -e $source ? Path::Tiny::path($source) : undef;
+sub extract_in {
+    my ( $self, $archive_file, $base, $child_name ) = @_;
+
+    my $archive = Archive::Any->new($archive_file);
+
+    return undef
+        if $archive->is_naughty;
+
+    my $extract_root = $base;
+    my $extract_dir  = $base->child($child_name);
+
+    if ( $archive->is_impolite ) {
+        $extract_root = $extract_dir;
+    }
+
+    $extract_root->mkpath;
+    $archive->extract($extract_root);
+
+    my @children = $extract_root->children;
+    if ( @children == 1 && -d $children[0] ) {
+
+        # one directory, but with wrong name
+        if ( $children[0]->basename ne $child_name ) {
+            $children[0]->move($extract_dir);
+        }
+    }
+    else {
+        my $temp = Path::Tiny->tempdir(
+            TEMPLATE => 'cpan-extract-XXXXXXX',
+            TMPDIR   => 0,
+            DIR      => $extract_root,
+            CLEANUP  => 0,
+        );
+
+        for my $child (@children) {
+            $child->move($temp);
+        }
+
+        $temp->move($extract_dir);
+    }
+
+    return $extract_dir;
+}
+
+sub fetch_from_cpan {
+    my ( $self, $download_url, $local_archive ) = @_;
+    $local_archive->parent->mkpath;
+
+    if ( my $remote_cpan = $self->remote_cpan ) {
+        $remote_cpan =~ s{/\z}{};
+        $download_url
+            =~ s{\Ahttps?://(?:(?:backpan|cpan)\.metacpan\.org|(?:backpan\.|www\.)?cpan\.org|backpan\.cpantesters\.org)/}{$remote_cpan/};
+    }
+
+    my $ua       = $self->ua;
+    my $response = $ua->mirror( $download_url, $local_archive );
+    return $response->is_success;
 }
 
 __PACKAGE__->meta->make_immutable;

metacpan_server.yaml

@@ -2,6 +2,7 @@
 git: /usr/bin/git
 
 cpan: /CPAN
+remote_cpan: https://cpan.metacpan.org/
 secret: "the stone roses"
 level: info
 elasticsearch_servers:

metacpan_server_testing.yaml

@@ -1,5 +1,6 @@
 git: /usr/bin/git
 cpan: var/t/tmp/fakecpan
+remote_cpan: file://__HOME__/var/t/tmp/fakecpan
 die_on_error: 1
 level: warn
 port: 5000