1 files changed, 118 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: