diff options
-rw-r--r-- | Spline/DMARC.pm | 118 | ||||
-rw-r--r-- | Spline/Data.pm | 157 | ||||
-rw-r--r-- | Spline/Log.pm | 147 | ||||
-rwxr-xr-x | dmarc_milter.pl | 116 |
4 files changed, 538 insertions, 0 deletions
diff --git a/Spline/DMARC.pm b/Spline/DMARC.pm new file mode 100644 index 0000000..4264dd5 --- /dev/null +++ b/Spline/DMARC.pm @@ -0,0 +1,118 @@ +#!/usr/bin/perl +=pod + +=head1 NAME + +Spline::DMARC - Methods to check the DMARC policy of mails. + +=head1 SYNOPSIS + + use Spline::DMARC qw(...); + + $policy = get_dmarc_policy($domain); + $would_reject = check_addresses($from); + +=head1 DESCRIPTION + +=cut + +package Spline::DMARC; + +use strict; +use warnings; + +use Mail::DMARC::PurePerl; +use Email::Address; +use Spline::Log qw(info debug); + +use base 'Exporter'; +our @EXPORT = qw(); +our @EXPORT_OK = qw( + check_addresses + get_dmarc_policy +); + +=head2 get_dmarc_policy + + $policy = get_dmarc_policy($domain); + +Get the DMARC policy for the specified domain. It will only return the +"p" value ('reject', 'none', ...) or the "sp" value (if the policy is +defined on a parent domain). + +If there is no DMARC policy defined, 'none' is returned. + +=cut + +sub get_dmarc_policy($) { + my $domain = shift; + my $effective_p = 'none'; + + my $dmarc = Mail::DMARC::PurePerl->new( + header_from => $domain, + ); + + debug "Checking DMARC policy for $domain"; + if ($dmarc->exists_in_dns()) { + my $policy = $dmarc->discover_policy(); + + if (defined $policy && $policy->is_valid()) { + if ($dmarc->is_subdomain && defined $policy->sp) { + debug 'Found policy on parent domain, using sp: ' . $policy->sp; + $effective_p = $policy->sp; + } + else { + debug 'Found policy: ' . $policy->p; + $effective_p = $policy->p; + } + } + } + else { + debug 'No policy found'; + } + + return $effective_p; +} + +=head2 check_addresses + + $would_reject = check_addresses($from); + +Check if any of the addresses in the specified from header has a DMARC +policy with the value 'reject'. This would cause the messasge to +bounce on all DMARC respecting receivers (like hotmail) after mailman +resends it. + +We do not try to validate the DMARC policy, because it will always +fail after mailman, because the Envelop-From and From header will not +match. + +If there is a policy defined with the value 'reject', this method +returns 1. If there is no policy or a policy with any other value then +'reject', this method returns 0. + +=cut + +sub check_addresses($) { + my $from = shift; + + my @addresses = Email::Address->parse($from); + foreach my $addr (@addresses) { + my $policy = get_dmarc_policy($addr->host); + if ($policy eq 'reject') { + info '"' . $addr->host . '" has reject policy!'; + return 1; + } + } + + return 0; +} + +=head1 AUTHOR + +Alexander Sulfrian <alex@spline.inf.fu-berlin.de> + +=cut + +1; +# vim: set et tabstop=4 tw=70: diff --git a/Spline/Data.pm b/Spline/Data.pm new file mode 100644 index 0000000..beae3fa --- /dev/null +++ b/Spline/Data.pm @@ -0,0 +1,157 @@ +#!/usr/bin/perl +=pod + +=head1 NAME + +Spline::Data - Per Message data + +=head1 SYNOPSIS + + use Spline::Data; + + my $data = Spline::Data->new($ctx); + my $value = $data->get($key); + $data->set($key, $value); + + my $data = Spline::Data->load($ctx); + +=head1 DESCRIPTION + +=cut + +package Spline::Data; + +use strict; +use warnings; + +use Spline::Log qw(set_log_context); +use Data::Dumper; + +use base 'Exporter'; +our @EXPORT = qw(); +our @EXPORT_OK = qw(); + +=head2 _generate_id + + my $id = _gernerate_id(); + +Generate a random string to tag interleaving log lines belonging to +the same message. + +=cut + +sub _generate_id() { + my @chars = ('A'..'Z', 'a'..'z', '0'..'9'); + my $id = ''; + $id .= $chars[rand @chars] for 1..10; + + return $id; +}; + +=head2 new + + my $data = Spline::Data::new($ctx); + +=cut + +sub new { + my $class = shift; + my $ctx = shift; + + my $id = _generate_id(); + my $self = { + ctx => $ctx, + data => { + log_ctx => $id, + } + }; + set_log_context($id); + + return bless $self, $class; +} + +=head2 get + + my $value = $data->get($key); + +Get the matching value for the supplied key as scalar. If there is no +such key in the data, return undef. + +=cut + +sub get($$) { + my $self = shift; + my $key = shift; + + return $self->{data}->{$key} if defined $self->{data}->{$key}; + return undef; +} + +=head2 set + + $data->set($key, $value); + +Set the supplied value for the key and save the data in the Milter +context. This method will silently create new keys and overwrite +possible existent values. + +=cut + +sub set($$$) { + my $self = shift; + my ($key, $value) = @_; + + $self->{data}->{$key} = $value; + $self->_save(); +} + +=head2 _save + + $data->_save(); + +Save the data in the Milter context. + +=cut + +sub _save($) { + my $self = shift; + + $self->{ctx}->setpriv($self->{data}); +} + +=head2 load + + my $data = Spline::Data->load($ctx); + +Get the data from the Milter context and return a Spline::Data object. +The data is saved again after receiving it, so that it will persist +even if no value is changed. + +=cut + +sub load { + my $class = shift; + my $ctx = shift; + + my $self = { + ctx => $ctx, + data => {}, + }; + $self->{data} = $ctx->getpriv(); + _save($self); + + if (defined $self->{data}->{log_ctx}) { + set_log_context($self->{data}->{log_ctx}); + } + + return bless $self, $class; +} + +=head1 AUTHOR + +Alexander Sulfrian <alex@spline.inf.fu-berlin.de> + +=cut + +1; +# vim: set et tabstop=4 tw=70: diff --git a/Spline/Log.pm b/Spline/Log.pm new file mode 100644 index 0000000..f56d5f0 --- /dev/null +++ b/Spline/Log.pm @@ -0,0 +1,147 @@ +#!/usr/bin/perl +=pod + +=head1 NAME + +Spline::Log - Utilities for logging + +=head1 SYNOPSIS + + use Spline::Log qw(...); + + set_verbose($bool); + set_log_context($context); + debug($message); + info($message); + +=head1 DESCRIPTION + +=cut + +package Spline::Log; + +use strict; +use warnings; +use feature 'say'; + +use base 'Exporter'; +our @EXPORT = qw(); +our @EXPORT_OK = qw( + set_verbose + set_log_context + debug + info +); + +my $context = undef; +my $verbose = 0; + +=head2 set_verbose + + set_verbose($bool); + +Specify if you want to see the debug messages. If the supplied value +is true, you will see this messages, otherwise only the info messages +are logged. + +=cut + +sub set_verbose($) { + my $value = shift; + + if ($value) { + $verbose = 1; + } + else { + $verbose = 0; + } +} + +=head2 set_log_context + + set_log_context($context); + +Set the logging context, that should be added to all messages. If you +may have interleaving log lines, you could use this context to tag the +correlating lines. + +This method set the new context and returns the previous value. + +=cut + +sub set_log_context($) { + my $old = $context; + $context = '' . shift; + return $old; +} + +=head2 debug + + debug($message); + +Lop the supplied message, but only if verbose is set. The message is +prepended with the logging context (if defined). + +=cut + +sub debug($) { + my $msg = shift; + + if ($verbose) { + _log($msg); + } +} + +=head2 info + + info($message); + +Log the supplied message, regardless of the verbosity. The message is +prepended with the logging context (if defined). + +=cut + +sub info($) { + my $msg = shift; + _log($msg); +} + +=head2 _get_context + + $context = _get_context(); + +If the logging context is defined, return the context followd by a +colon and a space (ready for output). If the context is undefined an +empty space is returned. + +=cut + +sub _get_context() { + return '' unless defined $context; + return "$context: "; +} + +=head2 _log + + _log($msg); + +Log the supplied message. The message is prepended with the logging +context (if defined). So the log format is something like this: + + CONTEXT: MESSAGE + +=cut + +sub _log($) { + my $msg = shift; + say _get_context() . $msg; +} + +=head1 AUTHOR + +Alexander Sulfrian <alex@spline.inf.fu-berlin.de> + +=cut + +1; +# vim: set et tabstop=4 tw=70: diff --git a/dmarc_milter.pl b/dmarc_milter.pl new file mode 100755 index 0000000..bdb6e0b --- /dev/null +++ b/dmarc_milter.pl @@ -0,0 +1,116 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use feature 'say'; + +use lib '.'; + +use Sendmail::Milter; +use Spline::DMARC qw(check_addresses); +use Spline::Log qw(set_verbose debug info); +use Spline::Data; + +use Data::Dumper; + +my %milter_callbacks = ( + 'envfrom' => \&from_callback, + 'envrcpt' => \&rcpt_callback, + 'header' => \&header_callback, + 'eoh' => \&eom_callback, + 'abort' => \&abort_callback, + 'close' => \&close_callback, +); + +sub from_callback($$@) { + my $ctx = shift; + my $from = shift; + + my $data = Spline::Data->new($ctx); + $data->set('counter', 0); + + debug "MAIL FROM: $from"; + return SMFIS_CONTINUE; +} + +sub rcpt_callback($$@) { + my $ctx = shift; + my $rcpt_to = shift; + + my $data = Spline::Data->load($ctx); + debug "RCPT TO: $rcpt_to"; + + my $next_hop = $ctx->getsymval('{rcpt_host}'); + if ($next_hop eq '[lists.spline.inf.fu-berlin.de]') { + info "Mailinglist address: $rcpt_to"; + $data->set('counter', 1); + } + + return SMFIS_CONTINUE; +} + +sub header_callback($$$) { + my $ctx = shift; + my ($field, $value) = @_; + + my $data = Spline::Data->load($ctx); + debug "HEADER '$field': $value"; + + if (lc($field) eq 'from') { + return SMFIS_CONTINUE if $data->get('counter') == 0; + + my $reject = check_addresses($value); + if ($reject) { + info 'Rejecting mail'; + $ctx->setreply('550', '5.7.2', 'Your provider does not permit sending to mailing lists (DMARC policy)'); + return SMFIS_REJECT; + } + } + + # We cannot SMFIS_ACCEPT here, because there could + # be multiple From headers. + return SMFIS_CONTINUE; +} + +sub eoh_callback($) { + my $ctx = shift; + + my $data = Spline::Data->load($ctx); + $data->set('counter', 0); + + debug 'END OF HEADER'; + return SMFIS_ACCEPT; +} + +sub abort_callback($) { + my $ctx = shift; + + my $data = Spline::Data->load($ctx); + $data->set('counter', 0); + + debug 'ABORT'; + return SMFIS_CONTINUE; +} + +sub close_callback($) { + my $ctx = shift; + + Spline::Data->load($ctx); + $ctx->setpriv(undef); + + debug 'CLOSE'; + return SMFIS_CONTINUE; +} + +sub main($) { + my $listen = shift; + + Sendmail::Milter::setconn($listen); + Sendmail::Milter::register("dmarc_lists_filter", + \%milter_callbacks, SMFI_CURR_ACTS); + Sendmail::Milter::main(); +} + +main('inet:12345@localhost'); + +# vim: set et tabstop=4 tw=70: |