Current File : //data/old/usr/share/opendmarc/contrib/rddmarc/rddmarc
#!/usr/bin/perl
# -*- perl -*-
# $Header: /home/johnl/hack/dmarc/RCS/rddmarc,v 1.5 2013/05/12 17:08:20 johnl Exp johnl $
#
# Script to read DMARC aggregate reports and put summary info
# into a database
# Options:
# -d print debug info
# -x read XML files rather than mail messages
# -r replace existing report rather than failing
# -u database user
# -p database password
# -n database name
# Copyright 2012-2013, Taughannock Networks. All rights reserved.
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
# OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
# AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
# WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
use strict;
use Getopt::Std;
use MIME::Parser;
use MIME::Words qw(:all);
use XML::Simple;
use DBI;
use Socket qw{:addrinfo inet_ntop inet_pton AF_INET6 AF_INET};
use PerlIO::gzip;
use vars qw{$opt_d $opt_r $opt_x $opt_u $opt_p $opt_n};
getopts('drxu:p:n:');
if (!defined($opt_u)) {
$opt_u = "opendmarc";
}
if (!defined($opt_p)) {
$opt_p = "opendmarc";
}
if (!defined($opt_n)) {
$opt_n = "opendmarc";
}
my $dbh = DBI->connect("DBI:mysql:database=$opt_n", $opt_u, $opt_p)
or die "Cannot connect to database\n";
foreach my $i (@ARGV) {
my ($zip, $ent, $isgzip);
print "parsing $i\n";
if($opt_x) {
open(XML, $i) or die "Cannot open XML file $i";
} else {
my $parser = new MIME::Parser;
$parser->output_dir("/tmp");
$ent = $parser->parse_open($i);
my $body = $ent->bodyhandle;
$zip = $body;
my $mtype = $ent->mime_type;
my $subj = decode_mimewords($ent->get('subject'));
print " $subj";
# if multipart/whatever, look through the parts to find a ZIP
if(lc $mtype =~ "multipart/") {
print "Look through $mtype\n";
$zip = undef;
my $npart = $ent->parts;
for my $n (0..($npart-1)) {
my $part = $ent->parts($n);
if(lc $part->mime_type eq "application/gzip") {
$zip = $part->bodyhandle;
$isgzip = 1;
last;
} elsif(lc $part->mime_type eq "application/zip"
or lc $part->mime_type eq "application/x-zip-compressed"
or lc $part->mime_type eq "application/octet-stream") {
$zip = $part->bodyhandle;
last;
} else {
$part->bodyhandle->purge; # not useful
}
}
die "no zip" unless $zip;
} elsif(lc $mtype ne "application/zip") {
print "don't understand $mtype\n";
next;
}
if(defined($zip->path)) {
print "body is in " . $zip->path . "\n" if $opt_d;
} else {
print "body is nowhere\n";
next;
}
if($isgzip) {
open(XML, "<:gzip", $zip->path)
or die "cannot ungzip $zip->path";
} else {
open(XML,"unzip -p " . $zip->path . " |")
or die "cannot unzip $zip->path";
}
}
my $xml = "";
$xml .= $_ while <XML>;
close XML;
$ent->purge if $ent;
$zip->purge if $zip;
my $xs = XML::Simple->new();
print "XML is ======\n$xml\n=====\n" if $opt_d;
my $ref = $xs->XMLin($xml);
my %xml = %{$ref};
#print join "\n",keys %xml;
#print "\n";
my $from = $xml{'report_metadata'}->{'date_range'}->{'begin'};
my $to = $xml{'report_metadata'}->{'date_range'}->{'end'};
my $org = $xml{'report_metadata'}->{'org_name'};
my $id = $xml{'report_metadata'}->{'report_id'};
my $domain = $xml{'policy_published'}->{'domain'};
print "report $org ($id) $from to $to for $domain\n" if $opt_d;
# see if already stored
my ($xorg, $xid, $serial) = $dbh->selectrow_array(qq{SELECT org,reportid,serial FROM report WHERE reportid=?}, undef, $id);
if($xorg) {
if($opt_r) {
print "Replacing $xorg $xid\n";
$dbh->do(qq{DELETE from rptrecord WHERE serial=?}, undef, $serial)
or die "cannot delete old records" . $dbh->errstr;
} else {
print "Already have $xorg $xid, skipped\n";
next;
}
}
my $sql = qq{INSERT INTO report(serial,mindate,maxdate,domain,org,reportid)
VALUES(NULL,FROM_UNIXTIME(?),FROM_UNIXTIME(?),?,?,?)};
$sql = qq{REPLACE INTO report(serial,mindate,maxdate,domain,org,reportid)
VALUES('$serial',FROM_UNIXTIME(?),FROM_UNIXTIME(?),?,?,?)} if $xorg;
$dbh->do($sql, undef, $from, $to, $domain, $org, $id)
or die "cannot make report" . $dbh->errstr;
$serial = $dbh->{'mysql_insertid'} || $dbh->{'insertid'} unless $xorg;
print " serial $serial ";
my $record = $xml{'record'};
sub dorow($$) {
my ($serial,$recp) = @_;
my %r = %$recp;
my $ip = $r{'row'}->{'source_ip'};
my $count = $r{'row'}->{'count'};
my $disp = $r{'row'}->{'policy_evaluated'}->{'disposition'};
print "\nip $ip, count $count, disp $disp" if $opt_d;
my ($dkim, $dkimresult, $spf, $spfresult, $reason);
my $rp = $r{'auth_results'}->{'dkim'};
printf " rp $rp\n" if $opt_d;
if(ref $rp eq "HASH") {
$dkim = $rp->{'domain'};
$dkim = undef if ref $dkim eq "HASH";
$dkimresult = $rp->{'result'};
} else { # array
# glom sigs together, report first result
$dkim = join '/',map { my $d = $_->{'domain'}; ref $d eq "HASH"?"": $d } @$rp;
$dkimresult = $rp->[0]->{'result'};
}
$rp = $r{'auth_results'}->{'spf'};
if(ref $rp eq "HASH") {
$spf = $rp->{'domain'};
$spfresult = $rp->{'result'};
} else { # array
# glom domains together, report first result
$spf = join '/',map { my $d = $_->{'domain'}; ref $d eq "HASH"? "": $d } @$rp;
$spfresult = $rp->[0]->{'result'};
}
$rp = $r{'row'}->{'policy_evaluated'}->{'reason'};
if(ref $rp eq "HASH") {
$reason = $rp->{'type'};
} else {
$reason = join '/',map { $_->{'type'} } @$rp;
}
#print "ip=$ip, count=$count, disp=$disp, r=$reason,";
#print "dkim=$dkim/$dkimresult, spf=$spf/$spfresult\n";
# figure out if it's IPv4 or IPv6
my ($nip, $iptype, $ipval);
if($nip = inet_pton(AF_INET, $ip)) {
$ipval = unpack "N", $nip;
$iptype = "ip";
} elsif($nip = inet_pton(AF_INET6, $ip)) {
$ipval = "X'" . unpack("H*",$nip) . "'";
$iptype = "ip6";
} else {
print "??? mystery ip $ip\n";
next;
}
print "$iptype = $ipval\n" if $opt_d;
$dbh->do(qq{INSERT INTO rptrecord(serial,$iptype,rcount,disposition,reason,dkimdomain,dkimresult,spfdomain,spfresult)
VALUES(?,$ipval,?,?,?,?,?,?,?)},undef, $serial,$count,$disp,$reason,$dkim,$dkimresult,$spf,$spfresult)
or die "cannot insert record " . $dbh->{'mysql_error'};
} # dorow
if(ref $record eq "HASH") {
print "single record\n";
dorow($serial,$record);
} elsif(ref $record eq "ARRAY") {
print "multi record\n";
foreach my $row (@$record) {
dorow($serial,$row);
}
} else {
print "mystery type " . ref($record) . "\n";
}
}
Mini Shell