path: root/dmarc_milter.pl

#!/usr/bin/perl

use strict;
use warnings;
use feature 'say';

no warnings 'experimental::signatures';
use feature 'signatures';

use Find::Lib '.';

use Getopt::Long;
use Pod::Usage;
use Sendmail::PMilter;
use Spline::DMARC qw(check_addresses);
use Spline::Data;
use Spline::Log qw(set_verbose set_stderr debug info);


# This is the mainloop. This method will not exit before shutdown of
# the milter interface.
sub main($listen, $mailman, $message) {

    my $milter = new Sendmail::PMilter;

    umask(0002);
    $milter->setconn($listen);

    # Setup the callbacks
    $milter->register('dmarc_milter', {
        'envfrom' => sub($ctx, $from, @) {
            # We only need this callback to initialize the private
            # data and the logging context.
            my $data = Spline::Data->new($ctx);
            $data->set('counter', 0);

            debug "MAIL FROM: $from";
            return Sendmail::PMilter::SMFIS_CONTINUE;
        },

        'envrcpt' => sub($ctx, $rcpt_to, @) {
            my $data = Spline::Data->load($ctx);
            debug "RCPT TO: $rcpt_to";

            my $next_hop = $ctx->getsymval('{rcpt_host}');
            if ($next_hop eq $mailman) {
                info "Mailinglist address: $rcpt_to";
                $data->set('counter', 1);
            }

            return Sendmail::PMilter::SMFIS_CONTINUE;
        },

        'header' => sub($ctx, $name, $value) {
            my $data = Spline::Data->load($ctx);

            # If there was no Mailinglist address, we can simply
            # accept this mail and skip all following callbacks
            return Sendmail::PMilter::SMFIS_ACCEPT if $data->get('counter') == 0;

            debug "HEADER '$name': $value";
            if (lc($name) eq 'from') {
                my $reject = check_addresses($value);
                if ($reject) {
                    info 'Rejecting mail!';
                    $ctx->setreply('550', '5.7.2', $message);

                    # REJECT here. No more callbacks, are called for
                    # this message.
                    return Sendmail::PMilter::SMFIS_REJECT;
                }
            }

            return Sendmail::PMilter::SMFIS_CONTINUE;
        },

        'eoh' => sub($ctx) {
            my $data = Spline::Data->load($ctx);
            debug 'END OF HEADER';

            # If we did not reject this message during the headers, we
            # can now accept it and do not call anymore callbacks for
            # this message.
            return Sendmail::PMilter::SMFIS_ACCEPT;
        },

        'close' => sub($ctx) {
            my $data = Spline::Data->load($ctx);
            return Sendmail::PMilter::SMFIS_CONTINUE unless defined $data->get('counter');

            # Free the connection-private memory.
            $ctx->setpriv(undef);

            debug 'CLOSE';
            return Sendmail::PMilter::SMFIS_CONTINUE;
        },
    });

    # Use prefork dispatcher (should be faster then the default
    # postfork variant)
    $milter->set_dispatcher(Sendmail::PMilter::prefork_dispatcher(
        "max_children" => 30,
        "max_requests_per_child" => 100,
    ));

    # Start the mainloop:
    $milter->main();
}

my $help;
my $verbose;
my $stderr;
my $message = 'Your provider does not permit sending to ' .
              'mailing lists (DMARC policy)';
my $mailman = '[lists.spline.inf.fu-berlin.de]';

# work on options
GetOptions(
    "verbose|v"   => \$verbose,
    "help|h|?"    => \$help,
    "stderr|s"    => \$stderr,
    "message|r=s" => \$message,
    "mailman|m=s" => \$mailman,
);

# show help
if ($help) {
    if ($verbose) {
        pod2usage(-verbose => 2,
                  -noperldoc => 1);
    }
    else {
        pod2usage();
    }

    exit;
}

# check argument count
if ($#ARGV < 0) {
    say STDERR 'SOCKET, PORT or CONNECTION_INFO required!';
    pod2usage();
    exit;
}

# Setup logging
if ($verbose) {
    set_verbose(1);
}

if ($stderr) {
    set_stderr(1);
}

# Build the connection info if only a PORT or Path is given
my $arg = shift;
my $listen;
if ($arg =~ /^\d+$/ ) {
    $listen = "inet:$arg\@localhost";
}
elsif ($arg =~ /^\//) {
    $listen = "local:$arg";
}
else {
    $listen = "$arg";
}

# Start the mainloop
info "Listening on $listen..." if $stderr;
main($listen, $mailman, $message);

__END__

=head1 NAME

dmarc_milter.pl - Milter to check if a mailinglist mail would be rejected because of DMARC.

=head1 SYNOPSIS

dmarc_milter [options] ( SOCKET | PORT | CONNECTION_INFO )

 Options:
   --help|-h|-?       show usage info and exit
   --verbose|-v       enable more output (even for --help)

   --stderr|-s        log to stderr
   --mailman|-m HOST  specify an alternativ mailman host
   --message|-r MSG   specify an alternativ reject message

You have to specify where the milter should listen for connections
from your MTA. You can specify a single TCP port (on localhost) or an
absolute path to a socket file. If you have special requirements you
could specify a full connection info string. The format is described
in the Milter documentation. Some examples are
C<local:/var/run/f1.sock>, C<inet6:999@localhost>,
C<inet:3333@localhost>.

(Note: The format of the connection string in the postfix config is
different.)

=head1 DESCRIPTION

B<dmarc_milter.pl> is a Perl script that listen on a socket or tcp
port and retrieves requests from a MTA via the milter protocol
(originaly by sendmail).

The script will scan all emails and check if there are destination
addresses "Envelope To" of mailinglists. If there is at least one, all
the milter will check if any address in the "From" header has
specified a DMARC reject policy.

Such mail would be bounced by all MTAs that respect DMARC, after
mailman resends the message.

=head1 OPTIONS

=over 8

=item B<--verbose>, B<-v>

More verbose output. It will log DEBUG messages, too.

=item B<--help>, B<-h>, B<-?>

Print brief help message and exit.

=item B<--stderr>, B<-s>

Log to stderr instead of syslog.

=item B<--mailman>, B<-m> C<HOST>

Set the mailman host to the specified value. This is the value of the
I<{rtpc_host}> macro for the mailinglist mails. It should be in the
same format as set by the MTA. The default value is:
C<[lists.spline.inf.fu-berlin.de]>.

=item B<--message>, B<-r> C<MESSAGE>

Set the message, if rejecting a mail. The default messages is: "Your
provider does not permit sending to mailing lists (DMARC policy)."

=back

=head1 AUTHORS

Alexander Sulfrian <alex@spline.inf.fu-berlin.de>

=head1 SEE ALSO

Sendmail::Milter(3pm), postconf(7)

=cut

# vim: set et tabstop=4 tw=70: