2 # Copyright (C) 2016 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 # only whitelist a few users for testing:
76 my $whitelist = '/etc/unsubscribe-milter.whitelist';
77 my %TEST_WHITELIST = map { $_ => 1 } eval {
78 open my $fh, '<', $whitelist or
79 die "Failed to open $whitelist: $!";
81 chomp(my @lines = (<$fh>));
84 die "No whitelist at $whitelist\n" unless scalar keys %TEST_WHITELIST;
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 unless $TEST_WHITELIST{$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 $v .= ",\n <https://$domain/u/$u/$list>";
110 $ctx->chgheader($k, $index, $v);
117 my $milter = Sendmail::PMilter->new;
119 # Try to inherit a socket from systemd or similar:
120 my $fds = $ENV{LISTEN_FDS};
121 if ($fds && (($ENV{LISTEN_PID} || 0) == $$)) {
122 die "$0 can only listen on one FD\n" if $fds != 1;
124 my $s = IO::Socket->new_from_fd($start_fd, 'r') or
125 die "inherited bad FD from LISTEN_FDS: $!\n";
126 $milter->set_socket($s);
128 # fall back to binding a socket:
129 my $sock = 'unix:/var/spool/postfix/unsubscribe/unsubscribe.sock';
130 $milter->set_listen(1024);
131 my $umask = umask 0000;
132 $milter->setconn($sock);
136 $milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);
137 my $dispatcher = Sendmail::PMilter::prefork_dispatcher(max_children => 2);
138 $milter->set_dispatcher($dispatcher);