#!/usr/bin/perl
#
=head1 NAME
DMARC.pl
v1.0 24-Jun-2013
=head1 DESCRIPTION
DMARC (Domain-based Message Authentication, Reporting and Conformance)
implementation for CommuniGate Pro mail server
Implemented as an external filtering helper based on public Perl modules.
What it does:
1) checks the incoming message's "From:" header address.
If the header is missing or the address is invalid - the message is rejected
2) checks the domain part of the "From:" address.
If the domain can't be resolved (no A/AAAA/MX record) - the message is rejected.
If there is no organizational domain for that domain - the message is rejected.
3) retrieves DMARC record for the domain.
If there's no DMARC record - the message is released with OK answer.
4) checks the message's "Received-SPF:" header (should be added by CommuniGate)
5) checks the message's DKIM signature (if presents) using Mail::DKIM::Verifier module
If either SPF or DKIM check passed - adds "DMARC: pass" header.
If both failed - adds "DMARC: reject" (or rejects the message) or "quarantine" or "none" header according to DMARC policy.
6) saves the message data and periodically sends aggregate reports to the domain owner according to DMARC policy.
=head1 INSTALLATION
Modify the script's settings below the "YOU SHOLD REDEFINE THESE VARIABLES" line.
Configuring CommuniGate Pro:
1) In Settings->Mail->SMTP->Receiving page switch the "Check SPF records" to "Add Header".
This is important because the script doesn't check SPF on its own but relies on CommuniGate's functionality.
2) Create a helper:
Name: DMARC-scan
Program Path: /usr/bin/perl DMARC.pl
3) Create a server-wide mail rule:
Data:
[Submit Address] [is] [SMTP*]
[Source] [is not] [authenticated]
Action:
[ExternalFilter] DMARC-scan
=head1 AUTHORS
Roman Prokhorov
=cut
use strict;
use Net::DNS::Resolver;
use Email::Address;
use MIME::Base64 qw(encode_base64);
use Mail::DKIM::Verifier; # http://search.cpan.org/~jaslong/Mail-DKIM/lib/Mail/DKIM/Verifier.pm
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
#### YOU SHOLD REDEFINE THESE VARIABLES !!!
my $applyRejectPolicy=0; # Really reject if directed by DMARC policy or just add header
my $rejectBadFroms=1; # reject messages with bad "From:" headers
my $sendReports=1; # send aggregate reports
my $Header="DMARC";
# the below parameters are required if $sendReports is true
my $reportOrg='MyCompany, Inc';
my $reportDomain='company.com';
my $reportEmail="noreply-dmarc-support\@$reportDomain";
my $reportsDir="DMARC_reports"; # a directory for collecting the reported data
my $SubmittedDir="Submitted"; # /var/CommuniGate/Submitted
#### end of the customizeable variables list
my $DNS_res;
my $publicSuffixList;
my $reportProcPID;
my $lockName="$reportsDir/file.lock";
$SIG{CHLD}='IGNORE';
$| = 1;
print "* DMARC.pl started.\n";
if($sendReports) {
#require Archive::Zip;
#import Archive::Zip qw( :ERROR_CODES :CONSTANTS );
if($reportDomain eq 'company.com') {
die "you must configure the script's parameters before launching it\n";
}
unless(-d $reportsDir) {
unless(mkdir($reportsDir)) {
die "can't create directory $reportsDir: @!";
}
}
unless($reportProcPID=fork()) {
die "cannot fork: $!" unless defined $reportProcPID;
processReports();
exit;
}
}
get_public_suffix_list();
while() {
chomp;
my ($command,$prefix);
my @args;
($prefix,$command,@args) = split(/ /);
if($command eq 'INTF') {
print "$prefix INTF 3\n";
} elsif($command eq 'QUIT') {
print "$prefix OK\n";
last;
} elsif($command eq 'KEY') {
print "$prefix OK\n";
} elsif($command eq 'FILE') {
unless(my $pid = fork()) {
die "cannot fork: $!" unless defined $pid;
processFILE($prefix,$args[0]);
exit;
}
} else {
print "$prefix ERROR unexpected command: $command\n";
}
}
kill('TERM', $reportProcPID) if($reportProcPID);
print "* stoppig DMARC.pl\n";
exit(0);
my @messageText;
my %DMARC_policy;
my ($fromDomain,$orgDomain,$returnPathDomain,$receivedSPF,$hasDKIMsignature,);
my ($dkimResult,$spfResult,$appliedPolicy)=('fail','fail','none');
my ($dkimResult2,$dkimHumanResult,$dkimDomain)=('none','','');
my ($spfResult2,$spfDomain)=('none','');
my @statusMessages;
sub processFILE {
my ($prefix,$fileName) = @_;
my ($fromAddress,$senderAddress,$isReport);
my @envelopeRecipients;
unless( open (FILE,"$fileName")) {
print qq/$prefix REJECTED can't open $fileName: $!\n/;
return undef;
}
my $sourceIP='';
while() { #read the envelope
chomp;
last if($_ eq '');
if(/^P .*\@(.+)>/) {
$returnPathDomain=lc($1);
} elsif(/^R .*\@(.+)>/) {
push(@envelopeRecipients,lc($1));
} elsif(/^S .*\[(.+)\]/) {
$sourceIP=$1;
}
}
while() { #read the mesage
chomp;
s/\015$//;
push(@messageText,$_);
}
close(FILE);
for(my $i=0;$iparse($fromAddress);
if($addresses[0]) {
$fromDomain=$addresses[0]->host;
} else {
if($rejectBadFroms) {
print qq/$prefix ERROR "malformed From: address"\n/;
} else {
print qq/$prefix ADDHEADER "$Header: malformed From: address"\n/;
}
return undef;
}
}
$DNS_res = Net::DNS::Resolver->new(
# nameservers => [qw(10.1.0.1)],
tcp_timeout => 10,
udp_timeout => 10,
);
unless(check_if_domain_exists($fromDomain)) {
if($rejectBadFroms) {
print qq/$prefix ERROR "non-existent domain ($fromDomain) in From:"\n/;
} else {
print qq/$prefix ADDHEADER "$Header: non-existent domain ($fromDomain) in From:"\n/;
}
return undef;
}
$orgDomain=get_organizational_domain($fromDomain);
unless($orgDomain) {
if($rejectBadFroms) {
print qq/$prefix ERROR "can't find organizational domain for '$fromDomain'"\n/;
} else {
print qq/$prefix ADDHEADER "$Header: can't find organizational domain for '$fromDomain'"\n/;
}
return undef;
}
my $DMARC_rec;
my $dmarcDomain=$fromDomain;
# use organizational domain if DMARC record isn't found
$DMARC_rec=get_DMARC_record($dmarcDomain);
unless($DMARC_rec) {
$dmarcDomain=$orgDomain;
$DMARC_rec=get_DMARC_record($dmarcDomain);
}
unless($DMARC_rec) {
#print qq/* ($prefix) no DMARC record for $fromDomain\n/;
print qq/$prefix OK\n/;
return undef;
}
print "* ($prefix) $fromDomain DMARC: $DMARC_rec\n";
%DMARC_policy=map { /^(.*?)\s*=\s*(.*)$/ } split /\s*;\s*/, $DMARC_rec;
#foreach(keys %DMARC_policy) { print " policy[$_]='$DMARC_policy{$_}'\n"; }
if($DMARC_policy{pct}) {
if($DMARC_policy{pct}!=100 && int(rand(100)) >= $DMARC_policy{pct}) {
print qq/* ($prefix) not checked due to pct=$DMARC_policy{pct}\n/;
print qq/$prefix OK\n/;
return undef;
}
}
verify_SPF();
verify_DKIM();
my $result=join("; ",@statusMessages);
print "* ($prefix) DMARC result: $result\n";
my ($policy,$disposition)=('none','none');
$policy=$DMARC_policy{p} if($DMARC_policy{p});
if($dmarcDomain ne $fromDomain) { #we're in dubdomain
$policy=$DMARC_policy{sp} if($DMARC_policy{sp});
}
if($dkimResult ne 'pass' && $spfResult ne 'pass') {
if($policy eq 'reject') {
if($applyRejectPolicy) {
print qq/$prefix ERROR "DMARC check failed"\n/;
$disposition='reject';
} else {
print qq/$prefix ADDHEADER "DMARC: reject"\n/;
$disposition='quarantine';
}
}elsif($policy eq 'quarantine') {
print qq/$prefix ADDHEADER "DMARC: quarantine"\n/;
$disposition='quarantine';
} else { #$policy==none
print qq/$prefix ADDHEADER "DMARC: none"\n/;
}
} else {
#print qq/$prefix OK\n/;
print qq/$prefix ADDHEADER "DMARC: pass"\n/;
$sendReports=0 if($isReport); #prevent adding report to reports
}
if($sendReports && $DMARC_policy{rua}) {
my @recipients;
foreach(split /,/,$DMARC_policy{rua}) {
if(/mailto:(\S*)/) {
my ($addr0,$addr)=($1,$1);
$addr=$1 if($addr0=~/(.*)!/);
$addr=~/\@(.+)/;
my $domain=$1;
if($domain ne $fromDomain && $domain ne $orgDomain) {
my $extRec=get_DMARC_record($domain,"$dmarcDomain._report.");
unless($extRec) {
print "* can't verify record for $dmarcDomain._report._dmarc.$domain\n";
next;
} else {
my %extPolicy=map { /^(.*?)\s*=\s*(.*)$/ } split /\s*;\s*/, $extRec;
if($extPolicy{rua}) {
foreach(split /,/,$extPolicy{rua}) {
if(/mailto:(\S*)/) {
my ($extAddr,$extAddr0)=($1,$1);
$extAddr=$1 if($extAddr0=~/(.*)!/);
$extAddr=~/\@(.+)/;
my $extDomain=$1;
if($extDomain eq $domain) {
push(@recipients,$extAddr0);
} else {
print "* external recipient $extAddr0 isn't in $domain\n";
}
}
}
} else {
push(@recipients,$addr0);
}
}
} else {
push(@recipients,$addr0);
}
}
}
if(@recipients) {
unless( open(LOCK_FILE,">$lockName") ) {
print "* ($prefix) can't open $lockName: $!\n";
return;
}
flock(LOCK_FILE, 1 ); # shared lock
my $fileName="$reportsDir/$dmarcDomain.data";
unless( open(FILE,">>$fileName") ) {
print "* ($prefix) can't open $fileName: $!\n";
} else {
flock(FILE, 2 ); # exclusive lock
if(-z $fileName) {
# version; domain; report time start/end;policy;recipients;
my @policy;
push(@policy,"adkim=$DMARC_policy{adkim}") if($DMARC_policy{adkim});
push(@policy,"aspf=$DMARC_policy{aspf}") if($DMARC_policy{aspf});
push(@policy,"p=$DMARC_policy{p}") if($DMARC_policy{p});
push(@policy,"sp=$DMARC_policy{sp}") if($DMARC_policy{sp});
push(@policy,"pct=$DMARC_policy{pct}") if($DMARC_policy{pct});
print FILE "1;$dmarcDomain;".time().";". (time + ($DMARC_policy{ri} ? $DMARC_policy{ri} : 86400)).";".join(",",@policy).";".join(",",@recipients)."\n";
}
foreach(@envelopeRecipients) {
print FILE "$sourceIP;$disposition;$dkimResult;$spfResult;$_;$fromDomain;$dkimDomain;$dkimResult2;$dkimHumanResult;$spfDomain;$spfResult2\n";
}
close(FILE);
}
close(LOCK_FILE);
}
}
return undef;
}#processFile
sub verify_SPF {
$spfResult='fail';
$spfResult2=($receivedSPF=~/(^\S+)/)[0] || 'none';
unless($spfResult2=~/^(none|neutral|pass|fail|softfail|temperror|permerror)$/) {
if($spfResult2=~/error/) {
$spfResult2='permerror';
} else {
$spfResult2='none';
}
}
$spfDomain=$returnPathDomain;
if($receivedSPF=~/^pass/) { # SPF check
if($DMARC_policy{aspf} && $DMARC_policy{aspf} eq 's') { #check SPF alignment, strict policy
if($fromDomain eq $returnPathDomain) {
$spfResult='pass';
} else {
push(@statusMessages,"SPF strict alignment check failed");
}
} else { # relaxed policy
if($orgDomain eq get_organizational_domain($returnPathDomain)) {
$spfResult='pass';
} else {
push(@statusMessages,"SPF relaxed alignment check failed");
}
}
} else { # SPF check failed or missing
push(@statusMessages,($receivedSPF=~/^none/) ? "SPF result is \"none\"" : "SPF check failed");
}
}
sub verify_DKIM {
$dkimResult='fail';$dkimResult2='none';
unless($hasDKIMsignature) { # if we have DKIM signature
push(@statusMessages,"DKIM signature absent");
} else {
my $dkim = Mail::DKIM::Verifier->new();
$dkim->PRINT("$_\015\012") foreach(@messageText);
$dkim->CLOSE;
my $result = $dkim->result;
$dkimResult2=$result;
unless($dkimResult2=~/^(none|pass|fail|policy|neutral|temperror|permerror)$/) {
if($spfResult2=~/invalid/) {
$spfResult2='permerror';
} else {
$spfResult2='fail';
}
}
$dkimHumanResult = $dkim->result_detail;
if($result eq 'pass') {
$dkimDomain = $dkim->signature->domain();
#print "* DKIM domain=$sigDomain\n";
if($DMARC_policy{adkim} && $DMARC_policy{adkim} eq 's') { #check DKIM alignment, strict policy
if($fromDomain eq $dkimDomain) {
$dkimResult='pass';
} else {
push(@statusMessages,"DKIM strict alignment check failed");
}
} else { # relaxed policy
if($orgDomain eq get_organizational_domain($dkimDomain)) {
$dkimResult='pass';
} else {
push(@statusMessages,"DKIM relaxed alignment check failed");
}
}
} else { # DKIM check failed
push(@statusMessages,"DKIM check failed");
}
}
}
sub check_host {
my ($host,$type)=@_;
my $query=$DNS_res->query($host,$type);
return 0 unless ($query);
return 0 if($DNS_res->errorstring eq 'NXDOMAIN');
1;
}
sub check_if_domain_exists {
my ($host)=@_;
return 1 if(check_host($host,'A'));
return 1 if(check_host($host,'MX'));
return 1 if(check_host($host,'AAAA'));
0;
}
sub get_organizational_domain {
my ($domain) = @_;
my @labels = reverse split(/\./,$domain);
my $greatest = 0;
my $i;
for ($i=0; $i=2) {
$greatest=1;
} else {
return '';
}
}
return join('.', reverse((@labels)[0 .. $greatest]));
}
sub get_DMARC_record {
my ($host,$prefix)=@_;
$prefix='' unless($prefix);
my $query = $DNS_res->send($prefix."_dmarc.$host", 'TXT');
if($query) {
foreach($query->answer) {
next if $_->type ne 'TXT';
my $data=$_->txtdata;
return $data if($data=~/^v\s*=\s*DMARC1/); #skip records which don't start with v=DMARC
}
}
undef;
}
sub get_public_suffix_list {
if(0) { # either read one form file or getch from Internet
my $fileName="effective_tld_names.txt";
open(FILE,$fileName) || die "Can't open $fileName: $!\n";
$publicSuffixList.=$_ while();
close(FILE);
} else {
require LWP::UserAgent;
require HTTP::Request;
my $url='https://publicsuffix.org/list/effective_tld_names.dat';
my $ua = LWP::UserAgent->new(
ssl_opts => { verify_hostname => 0 },
);
# $ua->proxy(['http', 'ftp'], $ProxyURL) if($ProxyURL);
my $req = HTTP::Request->new('GET',$url);
my $res = $ua->request($req);
if($res->code != 200) {
die "Error: " . $res->code . " " . $res->message;
}
$publicSuffixList=$res->content();
}
$publicSuffixList =~s|^//.*||mg; #remove comments
$publicSuffixList =~s|\n{2,}|\n|g; #remove empty lines
}
my %fileCache;
my $reportCnt=0;
sub processReports {
$SIG{TERM}= sub {
print "* reports daemon stopped\n";
exit(0);
};
print "* reports daemon started\n";
while(1) {
opendir(my $dh, $reportsDir) || die "can't opendir $reportsDir: $!";
my @filelist = grep { /\.data$/ && -f "$reportsDir/$_" } readdir($dh);
closedir $dh;
foreach my $fName (@filelist) {
processReportFile($fName);
}
sleep(60);
}
}
sub processReportFile {
my ($fName)=@_;
my ($vers,$dmarcDomain,$reportStartTime,$reportEndTime,$policy,$recipients);
#print "* processing $fName\n";
unless($fileCache{$fName}) {
open(FILE,"$reportsDir/$fName");
my $line=;
close(FILE);
($vers,$dmarcDomain,$reportStartTime,$reportEndTime,$policy,$recipients)=split(/;/,$line);
$fileCache{$fName}=$reportEndTime;
}
if($fileCache{$fName} < time()) { # it's time to send the report
$fName=~/(.*)\.data$/;
print "* composing report for $1\n";
my %reportData;
if(open(LOCK_FILE,">$lockName")) {
flock(LOCK_FILE, 2 ); # exclusive
if(open(FILE,"$reportsDir/$fName")) {
flock(FILE, 2 ); # exclusive
my $line=;
chomp($line);
($vers,$dmarcDomain,$reportStartTime,$reportEndTime,$policy,$recipients)=split(/;/,$line);
if($vers==1) {
while($line=) {
chomp($line);
if($reportData{$line}) {
$reportData{$line}++;
} else {
$reportData{$line}=1;
}
}
}
delete $fileCache{$fName};
close(FILE);
unlink("$reportsDir/$fName");
}
close(LOCK_FILE);
}
if(keys %reportData) { # have something to report
$reportEndTime=time();
my $reportFileName="$reportDomain!$dmarcDomain!$reportStartTime!$reportEndTime";
unless(open(XML_FILE,">$reportsDir/$reportFileName.xml")) {
print "* can't create $reportsDir/$reportFileName.xml: $!\n";
return;
}
my $reportID=int(rand(10000)).":".time()."\@$reportDomain";
my $reportH1=<
$reportOrg
$reportEmail
$reportID
$reportStartTime
$reportEndTime
$dmarcDomain
EOT
print XML_FILE $reportH1;
my %hPolicy=map { /^(.*?)=(.*)$/ } split /,/, $policy;
print XML_FILE " $hPolicy{adkim}\n" if($hPolicy{adkim});
print XML_FILE " $hPolicy{aspf}\n" if($hPolicy{aspf});
print XML_FILE " $hPolicy{p}
\n" if($hPolicy{p});
print XML_FILE " $hPolicy{sp}\n" if($hPolicy{sp});
print XML_FILE " $hPolicy{pct}\n" if($hPolicy{pct});
print XML_FILE " \n";
foreach(keys %reportData) {
my $count=$reportData{$_};
my ($sourceIP,$disposition,$dkimResult,$spfResult,$envelopeTo,$fromDomain,$dkimDomain,$dkimResult2,$dkimHumanResult,$spfDomain,$spfResult2)=split(";",$_);
my $reportH2=<
$sourceIP
$count
$disposition
$dkimResult
$spfResult
$envelopeTo
$fromDomain
$dkimDomain
$dkimResult2
$dkimHumanResult
$spfDomain
$spfResult2
EOT
print XML_FILE $reportH2;
}
print XML_FILE "\n";
close(XML_FILE);
my $zip = Archive::Zip->new();
my $file_member = $zip->addFile( "$reportsDir/$reportFileName.xml", "$reportFileName.xml" );
$file_member->desiredCompressionLevel( COMPRESSION_LEVEL_BEST_COMPRESSION );
# Save the Zip file
my $zipResult=$zip->writeToFileNamed("$reportsDir/$reportFileName.zip");
unlink("$reportsDir/$reportFileName.xml");
unless ( $zipResult == AZ_OK ) {
print "* unable to compress ZIP file\n";
return;
}
unless(open(FILE,"$reportsDir/$reportFileName.zip")) {
print "* can't open $reportsDir/$reportFileName.zip: $!\n";
return;
}
unless(binmode(FILE)) {
print "* can't switch $reportsDir/$reportFileName.zip to binmode: $!\n";
return;
}
my $base64data="";
while (read(FILE, my $buf, 60*57)) {
$base64data.=encode_base64($buf);
}
close(FILE);
unlink("$reportsDir/$reportFileName.zip");
my @recipients1= split(/,/,$recipients);
my @recipients2;
foreach(@recipients1) {
if(/(.*)!(\d+)(.)/) {
my ($rcpt,$limit)=($1,$2);
$limit*=1024 if($3=~/k/i);
$limit*=1024*1024 if($3=~/m/i);
$limit*=1024*1024*1024 if($3=~/g/i);
$limit*=1024*1024*1024*1024 if($3=~/t/i);
if($limit > length($base64data) + 1024) {
push(@recipients2,$rcpt);
} else {
print "* the data is too large for $_\n";
}
} else {
push(@recipients2,$_);
}
}
unless(@recipients2) {
print "* no recipients for the report to $dmarcDomain\n";
return;
}
my $recipients3=join(",",@recipients2);
my $boundary="===_".$reportID;
my $reportH3=<
Subject: Report Domain: $dmarcDomain Submitter: $reportDomain Report-ID: $reportID
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="$boundary"
This is a multipart message in MIME format.
--$boundary
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: 7bit
This is an aggregate report from $reportOrg.
--$boundary
Content-Type: application/zip
Content-Transfer-Encoding: base64
Content-Disposition: attachment; filename="$reportFileName.zip"
EOT
my $subFName="$SubmittedDir/DMARC-report-$$-".++$reportCnt;
unless(open(FILE,">$subFName.tmp")) {
print "* can't create $subFName.tmp: $!\n";
return;
}
print FILE $reportH3;
print FILE $base64data;
print FILE "\n--$boundary--\n";
close(FILE);
rename("$subFName.tmp","$subFName.sub");
}#have something to report
}
}
__END__