scripts/ssoma-replay

   1 #!/usr/bin/perl -w
   2 # Copyright (C) 2015-2020 all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 #
   5 # A work-in-progress, but one day I hope this script is no longer
   6 # necessary and users will all pull from public-inboxes instead
   7 # of having mail pushed to them via mlmmj.
   8 #
   9 # This is for use with ssoma, using "command:" delivery mechanism
  10 # (as opposed to normal Maildir or mbox).
  11 # It assumes mlmmj-process is in /usr/bin (mlmmj requires absolute paths)
  12 # and assumes FOO@domain.example.com has web archives available at:
  13 # https://domain.example.com/FOO/
  14 #
  15 # The goal here is _anybody_ can setup a mirror of any public-inbox
  16 # repository and run their own mlmmj instance to replay traffic.
  17 =begin usage with ssoma:
  18
  19 NAME=meta
  20 URL=https://public-inbox.org/meta/
  21 ssoma add $NAME $URL "command:/path/to/ssoma-replay -L /path/to/spool/$NAME"
  22
  23 ; $GIT_DIR/ssoma.state should have something like the following target:
  24 ; (where GIT_DIR is ~/.ssoma/meta.git/ in the above example)
  25 [target "local"]
  26         command = /path/to/ssoma-replay -L /path/to/spool/meta
  27 =cut
  28 use strict;
  29 use Email::Simple;
  30 use URI::Escape qw/uri_escape_utf8/;
  31 use File::Temp qw/tempfile/;
  32 my ($fh, $filename) = tempfile('ssoma-replay-XXXXXXXX', TMPDIR => 1);
  33 my $msg = Email::Simple->new(do { local $/; <STDIN> });
  34 select $fh;
  35
  36 # Note: the archive URL makes assumptions about where the
  37 # archive is hosted.  It is currently true of all the domains
  38 # hosted by me.
  39
  40 my $header_obj = $msg->header_obj;
  41 my $body = $msg->body;
  42 my $list_id = $header_obj->header('List-Id');
  43 my ($archive_url, $user, $domain);
  44 if (defined $list_id) {
  45         # due to a bug in old versions of public-inbox, <user@domain> was used
  46         # as the list-Id instead of <user.domain> as recommended in RFC2919
  47         ($user, $domain) = ($list_id =~ /<([^\.@]+)[\.@](.+)>/g);
  48
  49         if (defined $domain) {
  50                 $archive_url = "https://$domain/$user/";
  51                 my $mid = $header_obj->header('Message-Id');
  52                 if ($mid =~ /<[ \t]*([^>]+)?[ \t]*>/s) {
  53                         $mid = $1;
  54                 }
  55                 $mid = uri_escape_utf8($mid,
  56                                 '^A-Za-z0-9\-\._~!\$\&\';\(\)\*\+,;=:@');
  57                 $header_obj->header_set('List-Archive', "<$archive_url>");
  58
  59                 foreach my $h (qw(Help Unsubscribe Subscribe Owner)) {
  60                         my $lch = lc $h;
  61                         my $v = "<mailto:$user+$lch\@$domain>";
  62                         $header_obj->header_set("List-$h", $v);
  63                 }
  64                 $header_obj->header_set('List-Post', "<mailto:$user\@$domain>");
  65
  66                 # RFC 5064
  67                 $header_obj->header_set('Archived-At', "<$archive_url$mid/>");
  68                 $header_obj->header_set('X-Archived-At');
  69         }
  70 }
  71
  72 print $header_obj->as_string, $msg->crlf, $body;
  73
  74 # don't break inline signatures
  75 goto out if ($body =~ /^-----BEGIN PGP SIG.+-----/sm);
  76
  77 # try not to break dkim/dmarc/spf crap, either
  78 foreach (qw(domainkey-signature dkim-signature authentication-results)) {
  79         goto out if defined $header_obj->header($_);
  80 }
  81
  82 my $ct = $header_obj->header('Content-Type');
  83
  84 if (!defined($ct) || $ct =~ m{\A\s*text/plain\b}i) {
  85         print "\n" unless $body =~ /\n\z/s;
  86         defined $archive_url or goto out;
  87         # Do not add a space after '--' as is standard for user-generated
  88         # signatures, we want to preserve the "-- \n" in original user sigs
  89         # for mail software which splits on that.
  90         print "--\n", "unsubscribe: $user+unsubscribe\@$domain\n",
  91                  "archive: $archive_url\n";
  92 }
  93 out:
  94 $| = 1;
  95 exec '/usr/bin/mlmmj-process', @ARGV, '-m', $filename;