Some stuff

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: