diff --git a/cpanfile b/cpanfile
index c5cc81365..ad67e1179 100644
--- a/cpanfile
+++ b/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';
diff --git a/lib/MetaCPAN/Server/Config.pm b/lib/MetaCPAN/Server/Config.pm
index 7fb428fdd..4bf51f97a 100644
--- a/lib/MetaCPAN/Server/Config.pm
+++ b/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;
}
diff --git a/lib/MetaCPAN/Server/Controller/Source.pm b/lib/MetaCPAN/Server/Controller/Source.pm
index 868e177cd..8144782d5 100644
--- a/lib/MetaCPAN/Server/Controller/Source.pm
+++ b/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 } )
diff --git a/lib/MetaCPAN/Server/Model/Source.pm b/lib/MetaCPAN/Server/Model/Source.pm
index 56d5115a8..954a0ce43 100644
--- a/lib/MetaCPAN/Server/Model/Source.pm
+++ b/lib/MetaCPAN/Server/Model/Source.pm
@@ -1,11 +1,9 @@
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 ();
@@ -13,73 +11,178 @@ 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;
diff --git a/metacpan_server.yaml b/metacpan_server.yaml
index 0d34cb7c1..b4ee70242 100644
--- a/metacpan_server.yaml
+++ b/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:
diff --git a/metacpan_server_testing.yaml b/metacpan_server_testing.yaml
index ce10c7ed7..f47e101d5 100644
--- a/metacpan_server_testing.yaml
+++ b/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