]> Sergey Matveev's repositories - public-inbox.git/blob - examples/unsubscribe.milter
recv_cmd: do not undef recvmsg buffer arg on errors
[public-inbox.git] / examples / unsubscribe.milter
1 #!/usr/bin/perl -w
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>
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                 foreach my $u (@$unsub) {
100                         # Milter indices are 1-based,
101                         # not 0-based like Perl arrays
102                         my $index = ++$n;
103                         my ($k, $v, $list, $domain) = @$u;
104
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>";
113                         }
114                         $v .= ",\n <https://$domain/u/$u/$list>";
115
116                         $ctx->chgheader($k, $index, $v);
117                 }
118         };
119         warn $@ if $@;
120         SMFIS_CONTINUE;
121 };
122
123 my $milter = Sendmail::PMilter->new;
124
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;
129         my $start_fd = 3;
130         open(my $s, '<&=', $start_fd) or
131                 die "inherited bad FD from LISTEN_FDS: $!\n";
132         $milter->set_socket($s);
133 } else {
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);
139         umask $umask;
140 }
141
142 $milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);
143 $milter->main();
144 __END__
145 # TMPMSG comes from dc-dlvr, it's populated before the above runs:
146 # TMPMSG=$(mktemp -t dc-dlvr.orig.$USER.XXXXXX || exit 1)
147 # cat >$TMPMSG
148
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
153 foo+*) list=foo ;;
154 # ...
155 esac
156
157 case $EXTENSION in
158 unique-unsub)
159         u="$(formail -z -c -x Subject <$TMPMSG)"
160         d=$(expr "$ORIGINAL_RECIPIENT" : '^.*@\(.*\)')
161
162         # forward this to the unsubscribe.psgi service
163         curl -sSf https://$d/u/$u/$list >/dev/null
164         exit
165         ;;
166 esac
167 /usr/bin/mlmmj-receive -L /path/to/mlmmj-spool/$list <"$TMPMSG"
168 exit