2 # Copyright (C) 2016-2021 all contributors <meta@public-inbox.org>
3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
5 use Sendmail::PMilter qw(:all);
8 use MIME::Base64 qw(encode_base64url);
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";
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";
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};
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,
27 -cipher => 'Blowfish');
28 $fh = $iv = $key = undef;
33 eval { $ctx->setpriv({ header => {}, envrcpt => {} }) };
39 my ($ctx, $addr) = @_;
42 $ctx->getpriv->{envrcpt}->{$addr} = 1;
49 my ($ctx, $k, $v) = @_;
52 if ($k_ eq 'list-unsubscribe') {
53 my $header = $ctx->getpriv->{header} ||= {};
54 my $ary = $header->{$k_} ||= [];
56 # we create placeholders in case there are
57 # multiple headers of the same name
61 # This relies on mlmmj convention:
62 # $LIST+unsubscribe@$DOMAIN
63 if ($v =~ /\A<mailto:([^@]+)\+unsubscribe@([^>]+)>\z/) {
64 @$cur = ($k, $v, $1, $2);
67 # $LIST-request@$DOMAIN?subject=unsubscribe
68 } elsif ($v =~ /\A<mailto:([^@]+)-request@
69 ([^\?]+)\?subject=unsubscribe>\z/x) {
70 # @$cur = ($k, $v, $1, $2);
78 # We don't want people unsubscribing archivers:
81 return 1 if ($addr =~ /\@m\.gmane(?:-mx)?\.org\z/);
82 return 1 if ($addr eq 'archive@mail-archive.com');
89 my $priv = $ctx->getpriv;
90 $ctx->setpriv({ header => {}, envrcpt => {} });
91 my @rcpt = keys %{$priv->{envrcpt}};
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]));
97 my $unsub = $priv->{header}->{'list-unsubscribe'} || [];
99 foreach my $u (@$unsub) {
100 # Milter indices are 1-based,
101 # not 0-based like Perl arrays
103 my ($k, $v, $list, $domain) = @$u;
105 next unless $k && $v && $list && $domain;
106 my $u = $crypt->encrypt($rcpt[0]);
107 $u = encode_base64url($u);
108 if ($unique_mailto) {
109 # $u needs to be in the Subject: header since
110 # +$EXTENSION is case-insensitive
111 my $s = "subject=$u";
112 $v = "<mailto:$list+unique-unsub\@$domain?$s>";
114 $v .= ",\n <https://$domain/u/$u/$list>";
116 $ctx->chgheader($k, $index, $v);
123 my $milter = Sendmail::PMilter->new;
125 # Try to inherit a socket from systemd or similar:
126 my $fds = $ENV{LISTEN_FDS};
127 if ($fds && (($ENV{LISTEN_PID} || 0) == $$)) {
128 die "$0 can only listen on one FD\n" if $fds != 1;
130 open(my $s, '<&=', $start_fd) or
131 die "inherited bad FD from LISTEN_FDS: $!\n";
132 $milter->set_socket($s);
134 # fall back to binding a socket:
135 my $sock = 'unix:/var/spool/postfix/unsubscribe/unsubscribe.sock';
136 $milter->set_listen(1024);
137 my $umask = umask 0000;
138 $milter->setconn($sock);
142 $milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);
145 # TMPMSG comes from dc-dlvr, it's populated before the above runs:
146 # TMPMSG=$(mktemp -t dc-dlvr.orig.$USER.XXXXXX || exit 1)
149 # I use something like this in front of mlmmj for UNIQUE_MAILTO
150 # $EXTENSION and $ORIGINAL_RECIPIENT are set by postfix, $list
151 # is a local mapping of addresses to mailing list names.
152 case $ORIGINAL_RECIPIENT in
159 u="$(formail -z -c -x Subject <$TMPMSG)"
160 d=$(expr "$ORIGINAL_RECIPIENT" : '^.*@\(.*\)')
162 # forward this to the unsubscribe.psgi service
163 curl -sSf https://$d/u/$u/$list >/dev/null
167 /usr/bin/mlmmj-receive -L /path/to/mlmmj-spool/$list <"$TMPMSG"