]> Sergey Matveev's repositories - public-inbox.git/blob - examples/unsubscribe.milter
truncate Message-IDs and References consistently
[public-inbox.git] / examples / unsubscribe.milter
1 #!/usr/bin/perl -w
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>
4 use strict;
5 use warnings;
6 use Sendmail::PMilter qw(:all);
7 use IO::Socket;
8 use Crypt::CBC;
9 use MIME::Base64 qw(encode_base64url);
10
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";
13 my ($key, $iv);
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";
17 }
18
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,
22                         -iv => $iv,
23                         -header => 'none',
24                         -cipher => 'Blowfish');
25 $fh = $iv = $key = undef;
26
27 my %cbs;
28 $cbs{connect} = sub {
29         my ($ctx) = @_;
30         eval { $ctx->setpriv({ header => {}, envrcpt => {} }) };
31         warn $@ if $@;
32         SMFIS_CONTINUE;
33 };
34
35 $cbs{envrcpt} = sub {
36         my ($ctx, $addr) = @_;
37         eval {
38                 $addr =~ tr!<>!!d;
39                 $ctx->getpriv->{envrcpt}->{$addr} = 1;
40         };
41         warn $@ if $@;
42         SMFIS_CONTINUE;
43 };
44
45 $cbs{header} = sub {
46         my ($ctx, $k, $v) = @_;
47         eval {
48                 my $k_ = lc $k;
49                 if ($k_ eq 'list-unsubscribe') {
50                         my $header = $ctx->getpriv->{header} ||= {};
51                         my $ary = $header->{$k_} ||= [];
52
53                         # we create placeholders in case there are
54                         # multiple headers of the same name
55                         my $cur = [];
56                         push @$ary, $cur;
57
58                         # This relies on mlmmj convention:
59                         #       $LIST+unsubscribe@$DOMAIN
60                         if ($v =~ /\A<mailto:([^@]+)\+unsubscribe@([^>]+)>\z/) {
61                                 @$cur = ($k, $v, $1, $2);
62
63                         # Mailman convention:
64                         #       $LIST-request@$DOMAIN?subject=unsubscribe
65                         } elsif ($v =~ /\A<mailto:([^@]+)-request@
66                                         ([^\?]+)\?subject=unsubscribe>\z/x) {
67                                 # @$cur = ($k, $v, $1, $2);
68                         }
69                 }
70         };
71         warn $@ if $@;
72         SMFIS_CONTINUE;
73 };
74
75 # We don't want people unsubscribing archivers:
76 sub archive_addr {
77         my ($addr) = @_;
78         return 1 if ($addr =~ /\@m\.gmane\.org\z/);
79         return 1 if ($addr eq 'archive@mail-archive.com');
80         0
81 }
82
83 $cbs{eom} = sub {
84         my ($ctx) = @_;
85         eval {
86                 my $priv = $ctx->getpriv;
87                 $ctx->setpriv({ header => {}, envrcpt => {} });
88                 my @rcpt = keys %{$priv->{envrcpt}};
89
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]));
93
94                 my $unsub = $priv->{header}->{'list-unsubscribe'} || [];
95                 my $n = 0;
96                 foreach my $u (@$unsub) {
97                         # Milter indices are 1-based,
98                         # not 0-based like Perl arrays
99                         my $index = ++$n;
100                         my ($k, $v, $list, $domain) = @$u;
101
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>";
106
107                         $ctx->chgheader($k, $index, $v);
108                 }
109         };
110         warn $@ if $@;
111         SMFIS_CONTINUE;
112 };
113
114 my $milter = Sendmail::PMilter->new;
115
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;
120         my $start_fd = 3;
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);
124 } else {
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);
130         umask $umask;
131 }
132
133 $milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);
134 $milter->main();