2 # Copyright (C) 2016-2018 all contributors <meta@public-inbox.org>
3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
6 use Sendmail::PMilter qw(:all);
9 use MIME::Base64 qw(encode_base64url);
11 my $key_file = shift @ARGV or die "Usage: $0 KEY_FILE\n";
12 open my $fh, '<', $key_file or die "failed to open $key_file\n";
14 if (read($fh, $key, 8) != 8 || read($fh, $iv, 8) != 8 ||
15 read($fh, my $end, 8) != 0) {
16 die "KEY_FILE must be 16 bytes\n";
19 # these parameters were chosen to generate shorter parameters
20 # to reduce the possibility of copy+paste errors
21 my $crypt = Crypt::CBC->new(-key => $key,
24 -cipher => 'Blowfish');
25 $fh = $iv = $key = undef;
30 eval { $ctx->setpriv({ header => {}, envrcpt => {} }) };
36 my ($ctx, $addr) = @_;
39 $ctx->getpriv->{envrcpt}->{$addr} = 1;
46 my ($ctx, $k, $v) = @_;
49 if ($k_ eq 'list-unsubscribe') {
50 my $header = $ctx->getpriv->{header} ||= {};
51 my $ary = $header->{$k_} ||= [];
53 # we create placeholders in case there are
54 # multiple headers of the same name
58 # This relies on mlmmj convention:
59 # $LIST+unsubscribe@$DOMAIN
60 if ($v =~ /\A<mailto:([^@]+)\+unsubscribe@([^>]+)>\z/) {
61 @$cur = ($k, $v, $1, $2);
64 # $LIST-request@$DOMAIN?subject=unsubscribe
65 } elsif ($v =~ /\A<mailto:([^@]+)-request@
66 ([^\?]+)\?subject=unsubscribe>\z/x) {
67 # @$cur = ($k, $v, $1, $2);
75 # We don't want people unsubscribing archivers:
78 return 1 if ($addr =~ /\@m\.gmane\.org\z/);
79 return 1 if ($addr eq 'archive@mail-archive.com');
86 my $priv = $ctx->getpriv;
87 $ctx->setpriv({ header => {}, envrcpt => {} });
88 my @rcpt = keys %{$priv->{envrcpt}};
90 # one recipient, one unique HTTP(S) URL
91 return SMFIS_CONTINUE if @rcpt != 1;
92 return SMFIS_CONTINUE if archive_addr(lc($rcpt[0]));
94 my $unsub = $priv->{header}->{'list-unsubscribe'} || [];
96 foreach my $u (@$unsub) {
97 # Milter indices are 1-based,
98 # not 0-based like Perl arrays
100 my ($k, $v, $list, $domain) = @$u;
102 next unless $k && $v && $list && $domain;
103 my $u = $crypt->encrypt($rcpt[0]);
104 $u = encode_base64url($u);
105 $v .= ",\n <https://$domain/u/$u/$list>";
107 $ctx->chgheader($k, $index, $v);
114 my $milter = Sendmail::PMilter->new;
116 # Try to inherit a socket from systemd or similar:
117 my $fds = $ENV{LISTEN_FDS};
118 if ($fds && (($ENV{LISTEN_PID} || 0) == $$)) {
119 die "$0 can only listen on one FD\n" if $fds != 1;
121 my $s = IO::Socket->new_from_fd($start_fd, 'r') or
122 die "inherited bad FD from LISTEN_FDS: $!\n";
123 $milter->set_socket($s);
125 # fall back to binding a socket:
126 my $sock = 'unix:/var/spool/postfix/unsubscribe/unsubscribe.sock';
127 $milter->set_listen(1024);
128 my $umask = umask 0000;
129 $milter->setconn($sock);
133 $milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);