about summary refs log tree commit homepage
path: root/examples/unsubscribe.milter
diff options
context:
space:
mode:
authorEric Wong <e@80x24.org>2016-06-07 12:57:42 +0000
committerEric Wong <e@80x24.org>2016-06-07 12:57:42 +0000
commit3f779258173530ca88f31e1dc5332f951d2c44cd (patch)
treed7e9d0884d1787068627c411577cb5ba99a5c8c9 /examples/unsubscribe.milter
parente2adc947edc895da70a3a86ff6e9e13e5693be13 (diff)
parent852df982d88dcfaa49a1398cd6ef30973bcaaa09 (diff)
downloadpublic-inbox-3f779258173530ca88f31e1dc5332f951d2c44cd.tar.gz
* unsubscribe:
  unsubscribe.milter: use default postfork dispatcher
  unsubscribe: prevent decrypt from showing random crap
  examples/unsubscribe-psgi@.service: disable worker processes
  unsubscribe: bad URL fixup
  unsubscribe: get off mah lawn^H^H^Hist
Diffstat (limited to 'examples/unsubscribe.milter')
-rw-r--r--examples/unsubscribe.milter137
1 files changed, 137 insertions, 0 deletions
diff --git a/examples/unsubscribe.milter b/examples/unsubscribe.milter
new file mode 100644
index 00000000..eb1717ba
--- /dev/null
+++ b/examples/unsubscribe.milter
@@ -0,0 +1,137 @@
+#!/usr/bin/perl -w
+# Copyright (C) 2016 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+use strict;
+use warnings;
+use Sendmail::PMilter qw(:all);
+use IO::Socket;
+use Crypt::CBC;
+use MIME::Base64 qw(encode_base64url);
+
+my $key_file = shift @ARGV or die "Usage: $0 KEY_FILE\n";
+open my $fh, '<', $key_file or die "failed to open $key_file\n";
+my ($key, $iv);
+if (read($fh, $key, 8) != 8 || read($fh, $iv, 8) != 8 ||
+                        read($fh, my $end, 8) != 0) {
+        die "KEY_FILE must be 16 bytes\n";
+}
+
+# these parameters were chosen to generate shorter parameters
+# to reduce the possibility of copy+paste errors
+my $crypt = Crypt::CBC->new(-key => $key,
+                        -iv => $iv,
+                        -header => 'none',
+                        -cipher => 'Blowfish');
+$fh = $iv = $key = undef;
+
+my %cbs;
+$cbs{connect} = sub {
+        my ($ctx) = @_;
+        eval { $ctx->setpriv({ header => {}, envrcpt => {} }) };
+        warn $@ if $@;
+        SMFIS_CONTINUE;
+};
+
+$cbs{envrcpt} = sub {
+        my ($ctx, $addr) = @_;
+        eval {
+                $addr =~ tr!<>!!d;
+                $ctx->getpriv->{envrcpt}->{$addr} = 1;
+        };
+        warn $@ if $@;
+        SMFIS_CONTINUE;
+};
+
+$cbs{header} = sub {
+        my ($ctx, $k, $v) = @_;
+        eval {
+                my $k_ = lc $k;
+                if ($k_ eq 'list-unsubscribe') {
+                        my $header = $ctx->getpriv->{header} ||= {};
+                        my $ary = $header->{$k_} ||= [];
+
+                        # we create placeholders in case there are
+                        # multiple headers of the same name
+                        my $cur = [];
+                        push @$ary, $cur;
+
+                        # This relies on mlmmj convention:
+                        #        $LIST+unsubscribe@$DOMAIN
+                        if ($v =~ /\A<mailto:([^@]+)\+unsubscribe@([^>]+)>\z/) {
+                                @$cur = ($k, $v, $1, $2);
+
+                        # Mailman convention:
+                        #        $LIST-request@$DOMAIN?subject=unsubscribe
+                        } elsif ($v =~ /\A<mailto:([^@]+)-request@
+                                        ([^\?]+)\?subject=unsubscribe>\z/x) {
+                                # @$cur = ($k, $v, $1, $2);
+                        }
+                }
+        };
+        warn $@ if $@;
+        SMFIS_CONTINUE;
+};
+
+# only whitelist a few users for testing:
+my $whitelist = '/etc/unsubscribe-milter.whitelist';
+my %TEST_WHITELIST = map { $_ => 1 } eval {
+                open my $fh, '<', $whitelist or
+                        die "Failed to open $whitelist: $!";
+                local $/ = "\n";
+                chomp(my @lines = (<$fh>));
+                @lines;
+        };
+die "No whitelist at $whitelist\n" unless scalar keys %TEST_WHITELIST;
+
+$cbs{eom} = sub {
+        my ($ctx) = @_;
+        eval {
+                my $priv = $ctx->getpriv;
+                $ctx->setpriv({ header => {}, envrcpt => {} });
+                my @rcpt = keys %{$priv->{envrcpt}};
+
+                # one recipient, one unique HTTP(S) URL
+                return SMFIS_CONTINUE if @rcpt != 1;
+                return SMFIS_CONTINUE unless $TEST_WHITELIST{$rcpt[0]};
+
+                my $unsub = $priv->{header}->{'list-unsubscribe'} || [];
+                my $n = 0;
+                foreach my $u (@$unsub) {
+                        # Milter indices are 1-based,
+                        # not 0-based like Perl arrays
+                        my $index = ++$n;
+                        my ($k, $v, $list, $domain) = @$u;
+
+                        next unless $k && $v && $list && $domain;
+                        my $u = $crypt->encrypt($rcpt[0]);
+                        $u = encode_base64url($u);
+                        $v .= ",\n <https://$domain/u/$u/$list>";
+
+                        $ctx->chgheader($k, $index, $v);
+                }
+        };
+        warn $@ if $@;
+        SMFIS_CONTINUE;
+};
+
+my $milter = Sendmail::PMilter->new;
+
+# Try to inherit a socket from systemd or similar:
+my $fds = $ENV{LISTEN_FDS};
+if ($fds && (($ENV{LISTEN_PID} || 0) == $$)) {
+        die "$0 can only listen on one FD\n" if $fds != 1;
+        my $start_fd = 3;
+        my $s = IO::Socket->new_from_fd($start_fd, 'r') or
+                die "inherited bad FD from LISTEN_FDS: $!\n";
+        $milter->set_socket($s);
+} else {
+        # fall back to binding a socket:
+        my $sock = 'unix:/var/spool/postfix/unsubscribe/unsubscribe.sock';
+        $milter->set_listen(1024);
+        my $umask = umask 0000;
+        $milter->setconn($sock);
+        umask $umask;
+}
+
+$milter->register('unsubscribe', \%cbs, SMFI_CURR_ACTS);
+$milter->main();