mldistwatch: forbid tarbombs from being indexed

lib/PAUSE/dist.pm

@@ -961,20 +961,48 @@ sub chown_unsafe {
   $self->{CHOWN_UNSAFE_DONE}++;
 }
 
+sub has_consistent_prefix {
+  my ($self, $files) = @_;
+  my ($prefix) = split m{/}, $files->[0];
+
+  unless (-d $prefix) {
+    $Logger->log([ 'top level entry %s is not a directory', $prefix ]);
+    return undef;
+  }
+
+  for my $file (@$files) {
+    my ($file_prefix) = split m{/}, $file;
+
+    next if $file_prefix eq $prefix;
+
+    $Logger->log([ 'inconsistent file prefix between %s and %s', $prefix, $file ]);
+    return undef;
+  }
+
+  return 1;
+}
+
 sub read_dist {
   my $self = shift;
 
   my @manifind;
   my $ok = eval { @manifind = sort keys %{ExtUtils::Manifest::manifind()}; 1 };
+
   $self->{MANIFOUND} = \@manifind;
   unless ($ok) {
     my $error = $@;
     $Logger->log([ "errors in manifind: %s", $error ]);
     return;
   }
 
+  unless ($self->has_consistent_prefix(\@manifind)) {
+    $self->{SKIP} = 1;
+    $self->{REASON_TO_SKIP} = PAUSE::mldistwatch::Constants::ETARBOMB;
+    return;
+  }
+
   my $manifound = @manifind;
-  my $dist = $self->{DIST};
+
   unless (@manifind) {
     $Logger->log("!? no files in dist");
     return;

lib/PAUSE/mldistwatch.pm

@@ -457,19 +457,20 @@ sub maybe_index_dist {
         }
     }
 
-    $dio->examine_dist; # checks for perl, developer, version, etc. and untars
+    for my $step (qw( examine_dist read_dist )) {
+        $dio->$step;
 
-    if ($dio->skip) {
-        delete $self->{ALLlasttime}{$dist};
-        delete $self->{ALLfound}{$dist};
+      if ($dio->skip) {
+          delete $self->{ALLlasttime}{$dist};
+          delete $self->{ALLfound}{$dist};
 
-        if ($dio->{REASON_TO_SKIP}) {
-          $dio->mail_summary;
-        }
-        return;
+          if ($dio->{REASON_TO_SKIP}) {
+              $dio->mail_summary;
+          }
+          return;
+      }
     }
 
-    $dio->read_dist;
     $dio->extract_readme_and_meta;
 
     if ($dio->{META_CONTENT}{distribution_type}

lib/PAUSE/mldistwatch/Constants.pm

@@ -13,6 +13,7 @@ use constant EMISSPERM => 20;
 use constant ELONGVERSION => 13;
 use constant EBADVERSION => 12;
 use constant EPARSEVERSION => 10;
+use constant ETARBOMB    => 8;
 use constant E_DB_XACTFAIL => 7;
 use constant EMETAUNSTABLE => 6;
 use constant EBAREPMFILE => 5;
@@ -37,6 +38,7 @@ our $heading = {
   EOPENFILE() => "Problem while reading the distribtion",
   EMETAUNSTABLE() => "META release_status is not stable, will not index",
   EPARSEVERSION() => "Version parsing problem",
+  ETARBOMB() => "Archive contents aren't all under a common top-level directory",
   EVERFALLING() => "Decreasing version number",
   OK() => "Successfully indexed",
 };
@@ -48,5 +50,3 @@ sub heading ($) {
 }
 
 1;
-
-

t/mldistwatch-misc.t

@@ -494,6 +494,42 @@ EOT
   });
 };
 
+subtest "tarbombs" => sub {
+  my $pause = PAUSE::TestPAUSE->init_new;
+
+  $pause->upload_author_file('WEIRDO', 'corpus/tarbombs/Tarbomb-0.001.tar.gz');
+  $pause->upload_author_file('WEIRDO', 'corpus/tarbombs/Xyzzy-1.000.tar.gz');
+
+  my $result = $pause->test_reindex;
+
+  $pause->file_not_updated_ok(
+    $result->tmpdir
+           ->file(qw(cpan modules 02packages.details.txt.gz)),
+    "there were no things to update",
+  );
+
+  my $tarbomb_message = sub {
+    like(
+      $_[0]{email}->object->body_str,
+      qr/common top-level directory/,
+      "email contains ETARBOMB string",
+    );
+  };
+
+  $result->email_ok(
+    [
+      {
+        subject  => 'Failed: PAUSE indexer report WEIRDO/Tarbomb-0.001.tar.gz',
+        callbacks => [ $tarbomb_message ],
+      },
+      {
+        subject  => 'Failed: PAUSE indexer report WEIRDO/Xyzzy-1.000.tar.gz',
+        callbacks => [ $tarbomb_message ],
+      },
+    ],
+  );
+};
+
 done_testing;
 
 # Local Variables: