examples/unsubscribe.milter

#!/usr/bin/perl -w
# Copyright (C) all contributors <meta@public-inbox.org>
# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
use strict;
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";
}

# optionally support unique mailto: subject in List-Unsubscribe,
# requires a custom rule in front of mlmmj, see __END__
my $unique_mailto = $ENV{UNIQUE_MAILTO};

# 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 $allow_domains = '/etc/unsubscribe-milter.allow_domains';
my $ALLOW_DOMAINS;
if (open my $fh, '<', $allow_domains) {
	local $/ = "\n";
	chomp(my @l = <$fh>);
	die "close: $!" unless eof($fh) && close($fh);
	my %l = map { lc($_) => 1 } @l;
	$ALLOW_DOMAINS = \%l;
} else {
	warn <<EOM;
W: open $allow_domains: $! (all domains allowed)
W: all mlmmj-looking messages will have List-Unsubscribe added,
W: this is probably not what you want.
EOM
}

# only allow users hitting SMTP server locally:
# Is a config file necessary?  Regexps are ugly for IP addresses
# but Net::Patricia (or similar) seems like overkill.  Ugly it is:
my @ALLOW_ADDR = (qr/\A::1\z/, qr/\A127\./);
my $ALLOW_ADDR = join('|', @ALLOW_ADDR);

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;
};

# We don't want people unsubscribing archivers:
sub archive_addr {
	my ($addr) = @_;
	return 1 if ($addr =~ /\@m\.gmane(?:-mx)?\.org\z/);
	return 1 if ($addr eq 'archive@mail-archive.com');
	0
}

$cbs{eom} = sub {
	my ($ctx) = @_;
	eval {
		my $priv = $ctx->getpriv;
		$ctx->setpriv({ header => {}, envrcpt => {} });

		# XXX my postfix (3.5.18-0+deb11u1) + Sendmail::PMilter
		# instance doesn't seem to get {client_addr}, but
		# {daemon_addr} seems to make sense since I only want it
		# to apply to users connecting to postfix locally:
		if ($ALLOW_ADDR) {
			my $x = $ctx->getsymval('{daemon_addr}');
			return SMFIS_CONTINUE if $x && $x !~ /$ALLOW_ADDR/;
		}

		# one recipient, one unique HTTP(S) URL
		my @rcpt = keys %{$priv->{envrcpt}};
		return SMFIS_CONTINUE if @rcpt != 1;
		if ($ALLOW_DOMAINS) {
			my $addr = $ctx->getsymval('{mail_addr}');
			my (undef, $d) = split /\@/, $addr;
			return SMFIS_CONTINUE if !$ALLOW_DOMAINS->{$d};
		}
		return SMFIS_CONTINUE if archive_addr(lc($rcpt[0]));

		my $unsub = $priv->{header}->{'list-unsubscribe'} || [];
		my $n = 0;
		my $added;
		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);
			if ($unique_mailto) {
				# $u needs to be in the Subject: header since
				# +$EXTENSION is case-insensitive
				my $s = "subject=$u";
				$v = "<mailto:$list+unique-unsub\@$domain?$s>";
			}
			$v .= ",\n <https://$domain/u/$u/$list>";

			$ctx->chgheader($k, $index, $v);
			$added = 1;
		}
		# RFC 8058
		$added and $ctx->addheader('List-Unsubscribe-Post',
					'List-Unsubscribe=One-Click');
	};
	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();
__END__
# TMPMSG comes from dc-dlvr, it's populated before the above runs:
# TMPMSG=$(mktemp -t dc-dlvr.orig.$USER.XXXXXX || exit 1)
# cat >$TMPMSG

# I use something like this in front of mlmmj for UNIQUE_MAILTO
# $EXTENSION and $ORIGINAL_RECIPIENT are set by postfix, $list
# is a local mapping of addresses to mailing list names.
case $ORIGINAL_RECIPIENT in
foo+*) list=foo ;;
# ...
esac

case $EXTENSION in
unique-unsub)
	u="$(formail -z -c -x Subject <$TMPMSG)"
	d=$(expr "$ORIGINAL_RECIPIENT" : '^.*@\(.*\)')

	# forward this to the unsubscribe.psgi service
	curl -sSf https://$d/u/$u/$list >/dev/null
	exit
	;;
esac
/usr/bin/mlmmj-receive -L /path/to/mlmmj-spool/$list <"$TMPMSG"
exit