Merge pull request #45 from metacpan/mickey/purge

Added purge script

Author: mickeyn

bin/purge.pl

@@ -0,0 +1,85 @@
+use strict;
+use warnings;
+use v5.36;
+
+use Getopt::Long;
+use MetaCPAN::Logger qw< :log :dlog >;
+
+use MetaCPAN::ES;
+use MetaCPAN::Ingest qw<
+    are_you_sure
+    author_dir
+>;
+
+# args
+my ( $author, $release, $force );
+GetOptions(
+    "author=s"  => \$author,
+    "release=s" => \$release,
+    "force"     => \$force,
+);
+
+# setup
+my $type2index = {
+    release      => 'cpan',
+    file         => 'cpan',
+    author       => 'cpan',
+    favorite     => 'cpan',
+    permission   => 'cpan',
+    contributor  => 'contributor',
+};
+
+
+purge_author() if $author;
+
+log_info {'Done'};
+
+sub purge_author () {
+    # confirm
+    $release
+        ? are_you_sure( sprintf("%s's %s release is about to be purged!", $author, $release), $force )
+        : are_you_sure( sprintf("All of %s's releases are about to be purged!", $author), $force );
+
+    my $query = {
+        bool => {
+            must => [
+                { term => { author => $author } },
+                ( $release
+                  ? { term => { release => $release } }
+                  : ()
+                )
+            ]
+        }
+    };
+
+    purge_ids( type => 'favorite', query => $query);
+    purge_ids( type => 'file',     query => $query);
+    purge_ids( type => 'release',  query => $query);
+    if ( !$release ) {
+        purge_ids( type => 'author', id => $author );
+        purge_ids( type => 'contributor', id => $author );
+    }
+}
+
+sub purge_ids ( %args ) {
+    my $type = $args{type};
+    my $es = MetaCPAN::ES->new(
+        index => $type2index->{$type},
+        type => $type
+    );
+
+    my $bulk = $es->bulk;
+
+    my $id = $args{id};
+    my $ids = $id
+        ? [ $id ]
+        : $es->get_ids( query => $args{query} );
+
+    $bulk->delete_ids(@$ids);
+
+    $bulk->flush;
+}
+
+1;
+
+__END__

cpanfile

@@ -31,6 +31,7 @@ requires 'Search::Elasticsearch';
 requires 'Search::Elasticsearch::Client::2_0';
 requires 'Sub::Exporter';
 requires 'Text::CSV_XS';
+requires 'Term::ANSIColor';
 requires 'URI';
 requires 'XML::Simple';
 

lib/MetaCPAN/ES.pm

@@ -109,25 +109,37 @@ sub count ( $self, %args ) {
     );
 }
 
-sub clear_type ( $self ) {
-    my $bulk = $self->bulk;
+sub get_ids ( $self, %args ) {
+    my $query = $args{query};
+
     my $scroll = $self->scroll(
-        query => { match_all => {} },
+        query => $query // { match_all => {} },
         sort  => '_doc',
     );
 
     my @ids;
+
     while ( my $search = $scroll->next ) {
         push @ids => $search->{_id};
-        log_debug { "deleting id=" . $search->{_id} };
-        if ( @ids == 500 ) {
-            $bulk->delete_ids(@ids);
-            @ids = ();
-        }
     }
-    $bulk->delete_ids(@ids);
+
+    return \@ids;
+}
+
+sub delete_ids ( $self, $ids ) {
+    my $bulk = $self->bulk;
+
+    while ( my @batch = splice(@$ids, 0, 500) ) {
+        $bulk->delete_ids(@batch);
+    }
 
     $bulk->flush;
 }
 
+sub clear_type ( $self ) {
+    my $ids = $self->get_ids();
+
+    $self->delete_ids(@$ids);
+}
+
 1;

lib/MetaCPAN/Ingest.pm

@@ -12,6 +12,7 @@ use LWP::UserAgent;
 use Path::Tiny qw< path >;
 use PAUSE::Permissions ();
 use Ref::Util qw< is_ref is_plain_arrayref is_plain_hashref >;
+use Term::ANSIColor qw< colored >;
 use XML::Simple qw< XMLin >;
 
 use MetaCPAN::Config;
@@ -56,7 +57,9 @@ $config->init_logger;
 
 sub config () {$config}
 
-sub are_you_sure ( $msg ) {
+sub are_you_sure ( $msg, $force=0 ) {
+    return 1 if $force;
+
     my $iconfirmed = 0;
 
     if ( -t *STDOUT ) {