scripts/import_slrnspool

   1 #!/usr/bin/perl -w
   2 # Copyright (C) 2015, all contributors <meta@public-inbox.org>
   3 # License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt)
   4 #
   5 # Incremental (or one-shot) importer of a slrnpull news spool
   6 =begin usage
   7         export ORIGINAL_RECIPIENT=address@example.com
   8         public-inbox-init $LISTNAME $GIT_DIR $HTTP_URL $ORIGINAL_RECIPIENT
   9         ./import_slrnspool SLRNPULL_ROOT/news/foo/bar
  10 =cut
  11 use strict;
  12 use warnings;
  13 use PublicInbox::Config;
  14 use Email::Filter;
  15 use Email::LocalDelivery;
  16 sub usage { "Usage:\n".join('',grep(/\t/, `head -n 10 $0`)) }
  17 my $spool = shift @ARGV or die usage();
  18 my $recipient = $ENV{ORIGINAL_RECIPIENT};
  19 defined $recipient or die usage();
  20 my $config = PublicInbox::Config->new;
  21 my $cfg = $config->lookup($recipient);
  22 defined $cfg or exit(1);
  23 my @mda = (qw(ssoma-mda -1), $cfg->{mainrepo});
  24
  25 sub get_min {
  26         my ($cfg) = @_;
  27         $cfg->{importslrnspoolstate} || 0;
  28 }
  29
  30 sub set_min {
  31         my ($cfg, $num) = @_;
  32         my $f = PublicInbox::Config->default_file;
  33         my @cmd = (qw/git config/, "--file=$f",
  34                    "publicinbox.$cfg->{listname}.importslrnspoolstate", $num);
  35         system(@cmd) == 0 or die join(' ', @cmd). " failed: $?\n";
  36 }
  37
  38 my $n = get_min();
  39 my $ok;
  40 my $max_gap = 10000;
  41 my $max = $n + $max_gap;
  42
  43 for (; $n < $max; $n++) {
  44         my $fn = "$spool/$n";
  45         print STDERR $fn, "\n";
  46         open(my $fh, '<', $fn) or next;
  47         $max = $n + $max_gap;
  48         my $f = Email::Filter->new(data => eval { local $/; <$fh> });
  49         my $s = $f->simple;
  50
  51         # gmane rewrites Received headers, which increases spamminess
  52         # Some older archives set Original-To
  53         foreach my $x (qw(Received To)) {
  54                 my @h = $s->header("Original-$x");
  55                 if (@h) {
  56                         $s->header_set($x, @h);
  57                         $s->header_set("Original-$x");
  58                 }
  59         }
  60
  61         # triggers for the SA HEADER_SPAM rule
  62         foreach my $drop (qw(Approved)) { $s->header_set($drop) }
  63
  64         # appears to be an old gmane bug:
  65         $s->header_set('connect()');
  66
  67         $f->exit(0);
  68         $f->pipe(@mda);
  69         $ok = $n + 1;
  70         set_min($cfg, $ok);
  71 }