examples/unsubscribe.milter

   1 #!/usr/bin/perl -w
   2 # Copyright (C) all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 use strict;
   5 use Sendmail::PMilter qw(:all);
   6 use IO::Socket;
   7 use Crypt::CBC;
   8 use MIME::Base64 qw(encode_base64url);
   9
  10 my $key_file = shift @ARGV or die "Usage: $0 KEY_FILE\n";
  11 open my $fh, '<', $key_file or die "failed to open $key_file\n";
  12 my ($key, $iv);
  13 if (read($fh, $key, 8) != 8 || read($fh, $iv, 8) != 8 ||
  14                         read($fh, my $end, 8) != 0) {
  15         die "KEY_FILE must be 16 bytes\n";
  16 }
  17
  18 # optionally support unique mailto: subject in List-Unsubscribe,
  19 # requires a custom rule in front of mlmmj, see __END__
  20 my $unique_mailto = $ENV{UNIQUE_MAILTO};
  21
  22 # these parameters were chosen to generate shorter parameters
  23 # to reduce the possibility of copy+paste errors
  24 my $crypt = Crypt::CBC->new(-key => $key,
  25                         -iv => $iv,
  26                         -header => 'none',
  27                         -cipher => 'Blowfish');
  28 $fh = $iv = $key = undef;
  29
  30 my %cbs;
  31 $cbs{connect} = sub {
  32         my ($ctx) = @_;
  33         eval { $ctx->setpriv({ header => {}, envrcpt => {} }) };
  34         warn $@ if $@;
  35         SMFIS_CONTINUE;
  36 };
  37
  38 $cbs{envrcpt} = sub {
  39         my ($ctx, $addr) = @_;
  40         eval {
  41                 $addr =~ tr!<>!!d;
  42                 $ctx->getpriv->{envrcpt}->{$addr} = 1;
  43         };
  44         warn $@ if $@;
  45         SMFIS_CONTINUE;
  46 };
  47
  48 $cbs{header} = sub {
  49         my ($ctx, $k, $v) = @_;
  50         eval {
  51                 my $k_ = lc $k;
  52                 if ($k_ eq 'list-unsubscribe') {
  53                         my $header = $ctx->getpriv->{header} ||= {};
  54                         my $ary = $header->{$k_} ||= [];
  55
  56                         # we create placeholders in case there are
  57                         # multiple headers of the same name
  58                         my $cur = [];
  59                         push @$ary, $cur;
  60
  61                         # This relies on mlmmj convention:
  62                         #       $LIST+unsubscribe@$DOMAIN
  63                         if ($v =~ /\A<mailto:([^@]+)\+unsubscribe@([^>]+)>\z/) {
  64                                 @$cur = ($k, $v, $1, $2);
  65
  66                         # Mailman convention:
  67                         #       $LIST-request@$DOMAIN?subject=unsubscribe
  68                         } elsif ($v =~ /\A<mailto:([^@]+)-request@
  69                                         ([^\?]+)\?subject=unsubscribe>\z/x) {
  70                                 # @$cur = ($k, $v, $1, $2);
  71                         }
  72                 }
  73         };
  74         warn $@ if $@;
  75         SMFIS_CONTINUE;
  76 };
  77
  78 # We don't want people unsubscribing archivers:
  79 sub archive_addr {
  80         my ($addr) = @_;
  81         return 1 if ($addr =~ /\@m\.gmane(?:-mx)?\.org\z/);
  82         return 1 if ($addr eq 'archive@mail-archive.com');
  83         0
  84 }
  85
  86 $cbs{eom} = sub {
  87         my ($ctx) = @_;
  88         eval {
  89                 my $priv = $ctx->getpriv;
  90                 $ctx->setpriv({ header => {}, envrcpt => {} });
  91                 my @rcpt = keys %{$priv->{envrcpt}};
  92
  93                 # one recipient, one unique HTTP(S) URL
  94                 return SMFIS_CONTINUE if @rcpt != 1;
  95                 return SMFIS_CONTINUE if archive_addr(lc($rcpt[0]));
  96
  97                 my $unsub = $priv->{header}->{'list-unsubscribe'} || [];
  98                 my $n = 0;
  99                 my $added;
 100                 foreach my $u (@$unsub) {
 101                         # Milter indices are 1-based,
 102                         # not 0-based like Perl arrays
 103                         my $index = ++$n;
 104                         my ($k, $v, $list, $domain) = @$u;
 105
 106                         next unless $k && $v && $list && $domain;
 107                         my $u = $crypt->encrypt($rcpt[0]);
 108                         $u = encode_base64url($u);
 109                         if ($unique_mailto) {
 110                                 # $u needs to be in the Subject: header since
 111                                 # +$EXTENSION is case-insensitive
 112                                 my $s = "subject=$u";
 113                                 $v = "<mailto:$list+unique-unsub\@$domain?$s>";
 114                         }
 115                         $v .= ",\n <https://$domain/u/$u/$list>";
 116
 117                         $ctx->chgheader($k, $index, $v);
 118                         $added = 1;
 119                 }
 120                 # RFC 8058
 121                 $added and $ctx->addheader('List-Unsubscribe-Post',
 122                                         'List-Unsubscribe=One-Click');
 123         };
 124         warn $@ if $@;
 125         SMFIS_CONTINUE;
 126 };
 127
 128 my $milter = Sendmail::PMilter->new;
 129
 130 # Try to inherit a socket from systemd or similar:
 131 my $fds = $ENV{LISTEN_FDS};
 132 if ($fds && (($ENV{LISTEN_PID} || 0) == $$)) {
 133         die "$0 can only listen on one FD\n" if $fds != 1;
 134         my $start_fd = 3;
 135         my $s = IO::Socket->new_from_fd($start_fd, 'r') or
 136                 die "inherited bad FD from LISTEN_FDS: $!\n";
 137         $milter->set_socket($s);
 138 } else {
 139         # fall back to binding a socket:
 140         my $sock = 'unix:/var/spool/postfix/unsubscribe/unsubscribe.sock';
 141         $milter->set_listen(1024);
 142         my $umask = umask 0000;
 143         $milter->setconn($sock);
 144         umask $umask;
 145 }
 146
 147 $milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);
 148 $milter->main();
 149 __END__
 150 # TMPMSG comes from dc-dlvr, it's populated before the above runs:
 151 # TMPMSG=$(mktemp -t dc-dlvr.orig.$USER.XXXXXX || exit 1)
 152 # cat >$TMPMSG
 153
 154 # I use something like this in front of mlmmj for UNIQUE_MAILTO
 155 # $EXTENSION and $ORIGINAL_RECIPIENT are set by postfix, $list
 156 # is a local mapping of addresses to mailing list names.
 157 case $ORIGINAL_RECIPIENT in
 158 foo+*) list=foo ;;
 159 # ...
 160 esac
 161
 162 case $EXTENSION in
 163 unique-unsub)
 164         u="$(formail -z -c -x Subject <$TMPMSG)"
 165         d=$(expr "$ORIGINAL_RECIPIENT" : '^.*@\(.*\)')
 166
 167         # forward this to the unsubscribe.psgi service
 168         curl -sSf https://$d/u/$u/$list >/dev/null
 169         exit
 170         ;;
 171 esac
 172 /usr/bin/mlmmj-receive -L /path/to/mlmmj-spool/$list <"$TMPMSG"
 173 exit