trAvis - MANAGER

Edit File: 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

# 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";
    }
}