script/public-inbox-purge

   1 #!/usr/bin/perl -w
   2 # Copyright (C) 2019 all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 #
   5 # Used for purging messages entirely from a public-inbox.  Currently
   6 # supports v2 inboxes only, for now.
   7 use strict;
   8 use warnings;
   9 use Getopt::Long qw(:config gnu_getopt no_ignore_case auto_abbrev);
  10 use PublicInbox::AdminEdit;
  11 PublicInbox::Admin::check_require('-index');
  12 require PublicInbox::Filter::Base;
  13 require PublicInbox::Config;
  14 require PublicInbox::MIME;
  15 require PublicInbox::V2Writable;
  16
  17 { no warnings 'once'; *REJECT = *PublicInbox::Filter::Base::REJECT }
  18
  19 my $usage = "$0 [--all] [INBOX_DIRS] </path/to/message";
  20 my $config = eval { PublicInbox::Config->new };
  21 my $cfgfile = PublicInbox::Config::default_file();
  22 my $opt = { verbose => 1 };
  23 GetOptions($opt, @PublicInbox::AdminEdit::OPT) or
  24         die "bad command-line args\n$usage\n";
  25
  26 # TODO: clean this up and share code with -index via ::Admin
  27 my %dir2ibx; # ( path => Inbox object )
  28 my @inboxes;
  29 $config and $config->each_inbox(sub {
  30         my ($ibx) = @_;
  31         push @inboxes, $ibx if $opt->{all} && $ibx->{version} != 1;
  32         $dir2ibx{$ibx->{mainrepo}} = $ibx;
  33 });
  34
  35 if ($opt->{all}) {
  36         $config or die "--all specified, but $cfgfile not readable\n";
  37         @ARGV and die "--all specified, but directories specified\n";
  38 } else {
  39         my @err;
  40         my @dirs = scalar(@ARGV) ? @ARGV : ('.');
  41         my $u = 0;
  42
  43         foreach my $dir (@dirs) {
  44                 my $v;
  45                 my $dir = PublicInbox::Admin::resolve_repo_dir($dir, \$v);
  46                 if ($v == 1) {
  47                         push @err, $dir;
  48                         next;
  49                 }
  50                 my $ibx = $dir2ibx{$dir} ||= do {
  51                         warn "$dir not configured in $cfgfile\n";
  52                         $u++;
  53                         my $name = "unconfigured-$u";
  54                         PublicInbox::Inbox->new({
  55                                 version => 2,
  56                                 name => $name,
  57                                 -primary_address => "$name\@example.com",
  58                                 mainrepo => $dir,
  59                         });
  60                 };
  61                 push @inboxes, $ibx;
  62         }
  63
  64         if (@err) {
  65                 die "v1 inboxes currently not supported by -purge\n\t",
  66                     join("\n\t", @err), "\n";
  67         }
  68 }
  69
  70 foreach my $ibx (@inboxes) {
  71         my $lvl = $ibx->{indexlevel};
  72         if (defined $lvl) {
  73                 PublicInbox::Admin::indexlevel_ok_or_die($lvl);
  74                 next;
  75         }
  76
  77         # Undefined indexlevel, so `full'...
  78         # Search::Xapian exists and the DB can be read, at least, fine
  79         $ibx->search and next;
  80
  81         # it's possible for a Xapian directory to exist, but Search::Xapian
  82         # to go missing/broken.  Make sure it's purged in that case:
  83         $ibx->over or die "no over.sqlite3 in $ibx->{mainrepo}\n";
  84
  85         # $ibx->{search} is populated by $ibx->over call
  86         my $xdir_ro = $ibx->{search}->xdir(1);
  87         my $npart = 0;
  88         foreach my $part (<$xdir_ro/*>) {
  89                 if (-d $part && $part =~ m!/[0-9]+\z!) {
  90                         my $bytes = 0;
  91                         $bytes += -s $_ foreach glob("$part/*");
  92                         $npart++ if $bytes;
  93                 }
  94         }
  95         if ($npart) {
  96                 PublicInbox::Admin::require_or_die('-search');
  97         } else {
  98                 # somebody could "rm -r" all the Xapian directories;
  99                 # let them purge the overview, at least
 100                 $ibx->{indexlevel} ||= 'basic';
 101         }
 102 }
 103
 104 my $data = do { local $/; scalar <STDIN> };
 105 $data =~ s/\A[\r\n]*From [^\r\n]*\r?\n//s;
 106 my $n_purged = 0;
 107
 108 foreach my $ibx (@inboxes) {
 109         my $mime = PublicInbox::MIME->new($data);
 110         my $v2w = PublicInbox::V2Writable->new($ibx, 0);
 111
 112         my $commits = $v2w->purge($mime) || [];
 113
 114         if (my $scrub = $ibx->filter($v2w)) {
 115                 my $scrubbed = $scrub->scrub($mime, 1);
 116
 117                 if ($scrubbed && $scrubbed != REJECT()) {
 118                         my $scrub_commits = $v2w->purge($scrubbed);
 119                         push @$commits, @$scrub_commits if $scrub_commits;
 120                 }
 121         }
 122
 123         $v2w->done;
 124
 125         if ($opt->{verbose}) { # should we consider this machine-parseable?
 126                 print "$ibx->{mainrepo}:";
 127                 if (scalar @$commits) {
 128                         print join("\n\t", '', @$commits), "\n";
 129                 } else {
 130                         print " NONE\n";
 131                 }
 132         }
 133         $n_purged += scalar @$commits;
 134 }
 135
 136 # behave like "rm -f"
 137 exit(0) if ($opt->{force} || $n_purged);
 138
 139 warn "Not found\n" if $opt->{verbose};
 140 exit(1);