#!/usr/bin/perl
#
# Copyright (c) 2012-2016, 2017-2018, The Trusted Domain Project.
#   All rights reserved.
#
# Script to generate regular DMARC reports.

###
### Setup
###

use strict;
use warnings;

use Switch;

use DBI;
use File::Basename;
use File::Temp;
use Net::Domain qw(hostfqdn hostdomain);
use Getopt::Long;
use IO::Handle;
use IO::Compress::Zip qw(zip);
use POSIX;
use MIME::Base64;
use Net::SMTP;
use Time::Local;
use Net::DNS;
use Domain::PublicSuffix;

require DBD::mysql;

require HTTP::Request;

# general
my $progname      = basename($0);
my $version       = "1.4.2";
my $verbose       = 0;
my $helponly      = 0;
my $showversion   = 0;

my $interval;

my $gen;

my $buf;

my $mailout;
my $boundary;

my $tmpout;

my $repfile;
my $zipfile;

my $zipin;

my $now = time();

my $repstart;
my $repend;

my $domain;
my $domainid;
my $domainset;
my $forcedomain;
my @skipdomains;

my $poldomain;
my $policy;
my $spolicy;
my $policystr;
my $spolicystr;
my $pct;

my $repuri;
my @repuris;
my $lastsent;

my $aspf;
my $aspfstr;
my $adkim;
my $adkimstr;
my $align_dkim;
my $align_dkimstr;
my $align_spf;
my $align_spfstr;
my $spfresult;
my $dkimresult;
my $disp;
my $spfresultstr;
my $dkimresultstr;
my $dispstr;
my $ipaddr;
my $fromdomain;
my $envdomain;
my $dkimdomain;
my $dkimselector;
my $arc;
my $arcstr;
my $arcpolicy;
my $arcpolicystr;

my $smtpstatus;
my $smtpfail;

my $doupdate = 1;
my $testmode = 0;
my $keepfiles = 0;
my $use_utc = 0;
my $daybound = 0;
my $report_maxbytes_global = 15728640; # default: 15M, per spec

my $msgid;

my $rowcount;

my $dbi_h;
my $dbi_s;
my $dbi_s2;
my $dbi_a;
my $dbi_hash;

# DB parameters
my $def_dbhost    = "localhost";
my $def_dbname    = "opendmarc";
my $def_dbuser    = "opendmarc";
my $def_dbpasswd  = "opendmarc";
my $def_dbport    = "3306";
my $def_interval  = "86400";
my $dbhost;
my $dbname;
my $dbuser;
my $dbpasswd;
my $dbport;

my $dbscheme     = "mysql";

my $repdom       = hostdomain();
my $repemail     = "postmaster@" . $repdom;

my $smtp_server  = '127.0.0.1';
my $smtp_port    = 25;
my $smtp;

my $answer;

my $suffix;
my $publicsuffixlist = "/etc/opendmarc/public_suffix_list.dat";
if (-r $publicsuffixlist) {
	$suffix = Domain::PublicSuffix->new(
		{ 'data_file' => $publicsuffixlist }
	);
}
else
{
	$suffix = Domain::PublicSuffix->new();
}

###
### NO user-serviceable parts beyond this point
###

sub usage
{
	print STDERR "$progname: usage: $progname [options]\n";
	print STDERR "\t--day              send yesterday's data\n";
	print STDERR "\t--dbhost=host      database host [$def_dbhost]\n";
	print STDERR "\t--dbname=name      database name [$def_dbname]\n";
	print STDERR "\t--dbpasswd=passwd  database password [$def_dbpasswd]\n";
	print STDERR "\t--dbport=port      database port [$def_dbport]\n";
	print STDERR "\t--dbuser=user      database user [$def_dbuser]\n";
	print STDERR "\t--domain=name      force a report for named domain\n";
	print STDERR "\t--help             print help and exit\n";
	print STDERR "\t--interval=secs    report interval [$def_interval]\n";
	print STDERR "\t--keepfiles        keep xml files (in local directory)\n";
	print STDERR "\t -n                synonym for --test\n";
	print STDERR "\t--nodomain=name    omit a report for named domain\n";
	print STDERR "\t--skipdomains=file list of domains to omit a report for\n";
	print STDERR "\t--noupdate         don't record report transmission\n";
	print STDERR "\t--report-email     reporting contact [$repemail]\n";
	print STDERR "\t--report-org       reporting organization [$repdom]\n";
	print STDERR "\t--smtp-port        smtp server port [$smtp_port]\n";
	print STDERR "\t--smtp-server      smtp server [$smtp_server]\n";
	print STDERR "\t--test             don't send reports\n";
	print STDERR "\t                   (implies --keepfiles --noupdate)\n";
	print STDERR "\t--utc              operate in UTC\n";
	print STDERR "\t--verbose          verbose output\n";
	print STDERR "\t                   (repeat for increased output)\n";
	print STDERR "\t--version          print version and exit\n";
}

sub check_size_restriction
{
	my ($destination, $size) = @_;
	my $report_maxbytes = $report_maxbytes_global;

	# check for max report size
	if ($destination =~ m/^(\S+)!(\d{1,15})([kmgt])?$/i)
	{
		$destination = $1;
		$report_maxbytes = $2;
		if ($3)
		{
			my $letter = lc($3);
			if ($letter eq 'k')
			{
				$report_maxbytes = $report_maxbytes * 1024;
			}
			if ($letter eq 'm')
			{
				$report_maxbytes = $report_maxbytes * 1048576;
			}
			if ($letter eq 'g')
			{
				$report_maxbytes = $report_maxbytes * (2**30);
			}
			if ($letter eq 't')
			{
				$report_maxbytes = $report_maxbytes * (2**40);
			}
		}

		if ($size > $report_maxbytes)
		{
			return 0;
		}
	}
	return 1;
}

sub check_uri
{
	my $uri = URI->new($_[0]);
	if (!defined($uri) ||
	    !defined($uri->scheme) ||
	    $uri->opaque eq "")
	{
		print STDERR "$progname: can't parse reporting URI for domain $domain\n";
		return "";
	}
	# ensure a scheme is present
	elsif (!defined($uri->scheme))
	{
		if ($verbose >= 2)
		{
			print STDERR "$progname: unknown URI scheme in '$repuri' for domain $domain\n";
		}
		return "";
	}
	elsif ($uri->scheme eq "mailto")
	{
		return $uri->opaque;
	}
	return "";
}

# set locale
setlocale(LC_ALL, 'C');

sub loadskipdomains
{
	die "Could not open domains file $_[1]" unless open FILE,"<",$_[1];
	while (my $line = <FILE>)
	{
		$line =~ s/\s*#.*//;
		$line =~ s/^\s+//;
		$line =~ s/\s+//;
		push(@skipdomains, $line);
	}
	close FILE;
}

# parse command line arguments
my $opt_retval = &Getopt::Long::GetOptions ('day!' => \$daybound,
                                            'dbhost=s' => \$dbhost,
                                            'dbname=s' => \$dbname,
                                            'dbpasswd=s' => \$dbpasswd,
                                            'dbport=s' => \$dbport,
                                            'dbuser=s' => \$dbuser,
                                            'domain=s' => \$forcedomain,
                                            'help!' => \$helponly,
                                            'interval=i' => \$interval,
                                            'keepfiles' => \$keepfiles,
                                            'n|test' => \$testmode,
                                            'nodomain=s' => \@skipdomains,
                                            'skipdomains=s' => \&loadskipdomains,
                                            'report-email=s' => \$repemail,
                                            'report-org=s' => \$repdom,
                                            'smtp-server=s' => \$smtp_server,
                                            'smtp-port=i' => \$smtp_port,
                                            'update!' => \$doupdate,
                                            'utc!' => \$use_utc,
                                            'verbose+' => \$verbose,
                                            'version!' => \$showversion,
                                           );

if (!$opt_retval || $helponly)
{
	usage();

	if ($helponly)
	{
		exit(0);
	}
	else
	{
		exit(1);
	}
}

if ($showversion)
{
	print STDOUT "$progname v$version\n";
	exit(0);
}

# apply defaults
if (!defined($dbhost))
{
	if (defined($ENV{'OPENDMARC_DBHOST'}))
	{
		$dbhost = $ENV{'OPENDMARC_DBHOST'};
	}
	else
	{
		$dbhost = $def_dbhost;
	}
}

if (!defined($dbname))
{
	if (defined($ENV{'OPENDMARC_DB'}))
	{
		$dbname = $ENV{'OPENDMARC_DB'};
	}
	else
	{
		$dbname = $def_dbname;
	}
}

if (!defined($dbpasswd))
{
	if (defined($ENV{'OPENDMARC_PASSWORD'}))
	{
		$dbpasswd = $ENV{'OPENDMARC_PASSWORD'};
	}
	else
	{
		$dbpasswd = $def_dbpasswd;
	}
}

if (!defined($dbport))
{
	if (defined($ENV{'OPENDMARC_PORT'}))
	{
		$dbport = $ENV{'OPENDMARC_PORT'};
	}
	else
	{
		$dbport = $def_dbport;
	}
}

if (!defined($dbuser))
{
	if (defined($ENV{'OPENDMARC_USER'}))
	{
		$dbuser = $ENV{'OPENDMARC_USER'};
	}
	else
	{
		$dbuser = $def_dbuser;
	}
}

if (defined($interval) && $daybound)
{
	print STDERR "$progname: WARN: --day overrides --interval\n";
}

if (!defined($interval) || $daybound)
{
	$interval = $def_interval;
}

# Test mode requested, don't update last sent and keep xml files
$doupdate  = ($testmode == 1) ? 0 : $doupdate;
$keepfiles = ($testmode == 1) ? 1 : $keepfiles;

if ($verbose)
{
	print STDERR "$progname: started at " . localtime($now) . "\n";
}

my $dbi_dsn = "DBI:" . $dbscheme . ":database=" . $dbname .
              ";host=" . $dbhost . ";port=" . $dbport;

$dbi_h = DBI->connect($dbi_dsn, $dbuser, $dbpasswd, { PrintError => 0 });
if (!defined($dbi_h))
{
	print STDERR "$progname: unable to connect to database: $DBI::errstr\n";
	exit(1);
}

if ($verbose >= 2)
{
	print STDERR "$progname: connected to database\n";
}

if ($use_utc)
{
	$dbi_s = $dbi_h->prepare("SET TIME_ZONE='+00:00'");

	if (!$dbi_s->execute())
	{
		print STDERR "$progname: failed to change to UTC: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}
}

#
# Select domains on which to report
#

if ($verbose >= 2)
{
	print STDERR "$progname: selecting target domains\n";
}

if (defined($forcedomain))
{
	$dbi_s = $dbi_h->prepare("SELECT name FROM domains WHERE name = ?");

	if (!$dbi_s->execute($forcedomain))
	{
		print STDERR "$progname: failed to test for database entry: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}
}
elsif ($daybound)
{
	$dbi_s = $dbi_h->prepare("SELECT domains.name FROM requests JOIN domains ON requests.domain = domains.id WHERE DATE(lastsent) < DATE(FROM_UNIXTIME(?))");

	if (!$dbi_s->execute($now))
	{
		print STDERR "$progname: failed to collect domain names: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}
}
else
{
	$dbi_s = $dbi_h->prepare("SELECT domains.name FROM requests JOIN domains ON requests.domain = domains.id WHERE lastsent <= DATE_SUB(FROM_UNIXTIME(?), INTERVAL ? SECOND)");

	if (!$dbi_s->execute($now, $interval))
	{
		print STDERR "$progname: failed to collect domain names: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}
}

$domainset = $dbi_s->fetchall_arrayref([0]);
$dbi_s->finish;

if ($verbose)
{
	print STDERR "$progname: selected " . scalar(@$domainset) . " domain(s)\n";
}

#
# For each domain:
# 	-- extract reporting address
# 	-- extract messages/signatures to report
# 	-- generate and send report
# 	-- update "last sent" timestamp
#

$smtp = Net::SMTP->new($smtp_server,
                       'Port' => $smtp_port,
                       'Hello' => hostfqdn());
if (!defined($smtp))
{
	print STDERR "$progname: open SMTP server $smtp_server:$smtp_port failed\n";
	exit(1);
}

foreach (@$domainset)
{
	$domain = $_->[0];

	if (!defined($domain))
	{
		next;
	}

	if (@skipdomains && grep({$_ eq $domain} @skipdomains) != 0)
	{
		next;
	}

	if ($verbose >= 2)
	{
		print STDERR "$progname: processing $domain\n";
	}

	# extract this domain's reporting parameters
	$dbi_s = $dbi_h->prepare("SELECT id FROM domains WHERE name = ?");
	if (!$dbi_s->execute($domain))
	{
		print STDERR "$progname: can't get ID for domain $domain: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}

	undef $domainid;
	while ($dbi_a = $dbi_s->fetchrow_arrayref())
	{
		if (defined($dbi_a->[0]))
		{
			$domainid = $dbi_a->[0];
		}
	}
	$dbi_s->finish;

	if (!defined($domainid))
	{
		print STDERR "$progname: ID for domain $domain not found\n";
		next;
	}

	$dbi_s = $dbi_h->prepare("SELECT repuri, adkim, aspf, requests.policy, spolicy, pct, UNIX_TIMESTAMP(lastsent), domains.name FROM requests JOIN messages ON messages.from_domain=requests.domain LEFT JOIN domains ON messages.policy_domain = domains.id WHERE domain = ? GROUP BY policy_domain");
	if (!$dbi_s->execute($domainid))
	{
		print STDERR "$progname: can't get reporting URI for domain $domain: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}

	undef $repuri;
	$poldomain=$domain;

	while ($dbi_a = $dbi_s->fetchrow_arrayref())
	{
		if (defined($dbi_a->[0]))
		{
			$repuri = $dbi_a->[0];
		}
		if (defined($dbi_a->[1]))
		{
			$adkim = $dbi_a->[1];
		}
		if (defined($dbi_a->[2]))
		{
			$aspf = $dbi_a->[2];
		}
		if (defined($dbi_a->[3]))
		{
			$policy = $dbi_a->[3];
		}
		if (defined($dbi_a->[4]))
		{
			$spolicy = $dbi_a->[4];
		}
		if (defined($dbi_a->[5]))
		{
			$pct = $dbi_a->[5];
		}
		if (defined($dbi_a->[6]))
		{
			$lastsent = $dbi_a->[6];
		}
		if (defined($dbi_a->[7]))
		{
			$poldomain = $dbi_a->[7];
		}
	}

	$dbi_s->finish;

	if (!defined($repuri) || ("" eq $repuri))
	{
		if ($verbose >= 2)
		{
			print STDERR "$progname: no reporting URI for domain $domain; skipping\n";
		}

		next;
	}

	if ($daybound)
	{
		my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($now - $interval);
		$repstart = timelocal(0, 0, 0, $mday, $mon, $year);
		($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($now);
		$repend = timelocal(0, 0, 0, $mday, $mon, $year);
	}
	else
	{
		$repstart = $now - $interval;
		$repend = $now;
	}

	# construct the temporary file
	$repfile = $repdom . "!" . $domain . "!" . $repstart . "!" . $repend . ".xml";
	$zipfile = $repdom . "!" . $domain . "!" . $repstart . "!" . $repend . ".zip";
	if (!open($tmpout, ">", $repfile))
	{
		print STDERR "$progname: can't create report file for domain $domain\n";
		next;
	}

	switch ($adkim)
	{
		case ord("r")	{ $adkimstr = "r"; }
		case ord("s")	{ $adkimstr = "s"; }
		else		{ $adkimstr = "unknown"; }
	}

	switch ($aspf)
	{
		case ord("r")	{ $aspfstr = "r"; }
		case ord("s")	{ $aspfstr = "s"; }
		else		{ $aspfstr = "unknown"; }
	}

	switch ($policy)
	{
		case ord("n")	{ $policystr = "none"; }
		case ord("q")	{ $policystr = "quarantine"; }
		case ord("r")	{ $policystr = "reject"; }
		else		{ $policystr = "unknown"; }
	}

 	switch ($spolicy)
 	{
 		case 0		{ $spolicystr = $policystr; }
 		case ord("n")	{ $spolicystr = "none"; }
 		case ord("q")	{ $spolicystr = "quarantine"; }
 		case ord("r")	{ $spolicystr = "reject"; }
 		else		{ $spolicystr = "unknown"; }
 	}


	print $tmpout "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n";
	print $tmpout "<feedback>\n";

	print $tmpout "    <report_metadata>\n";
	print $tmpout "        <org_name>$repdom</org_name>\n";
	print $tmpout "         <email>$repemail</email>\n";
	print $tmpout "         <report_id>$domain:$now</report_id>\n";
	print $tmpout "         <date_range>\n";
	print $tmpout "         <begin>$repstart</begin>\n";
	print $tmpout "         <end>$repend</end>\n";
	print $tmpout "         </date_range>\n";
	print $tmpout "    </report_metadata>\n";

	print $tmpout "    <policy_published>\n";
	print $tmpout "        <domain>$poldomain</domain>\n";
	print $tmpout "        <adkim>$adkimstr</adkim>\n";
	print $tmpout "        <aspf>$aspfstr</aspf>\n";
	print $tmpout "        <p>$policystr</p>\n";
	print $tmpout "        <sp>$spolicystr</sp>\n";
	print $tmpout "        <pct>$pct</pct>\n";
	print $tmpout "    </policy_published>\n";

	if ($daybound)
	{
		$dbi_s = $dbi_h->prepare(q{
		                         SELECT messages.id, ipaddr.addr, messages.disp, d1.name, d2.name,
		                                 messages.spf, messages.align_spf, messages.align_dkim,
		                                 messages.arc, messages.arc_policy
		                         FROM messages
		                         JOIN ipaddr ON messages.ip = ipaddr.id
		                         JOIN domains d1 ON messages.from_domain = d1.id
		                         JOIN domains d2 ON messages.env_domain = d2.id
		                         WHERE messages.from_domain = ?
		                                 AND DATE(messages.date) >= DATE(FROM_UNIXTIME(?))
		                                 AND DATE(messages.date) < DATE(FROM_UNIXTIME(?))
		});
	}
	else
	{
		$dbi_s = $dbi_h->prepare(q{
		                         SELECT messages.id, ipaddr.addr, messages.disp, d1.name, d2.name,
		                                 messages.spf, messages.align_spf, messages.align_dkim,
		                                 messages.arc, messages.arc_policy
		                         FROM messages
		                         JOIN ipaddr ON messages.ip = ipaddr.id
		                         JOIN domains d1 ON messages.from_domain = d1.id
		                         JOIN domains d2 ON messages.env_domain = d2.id
		                         WHERE messages.from_domain = ?
		                                 AND messages.date > FROM_UNIXTIME(?)
		                                 AND messages.date <= FROM_UNIXTIME(?)
		});
	}

	if (!$dbi_s->execute($domainid, $repstart, $repend))
	{
		print STDERR "$progname: can't extract report for domain $domain: " . $dbi_h->errstr . "\n";
		$dbi_s->finish;
		$dbi_h->disconnect;
		exit(1);
	}

	$rowcount = 0;

	while ($dbi_a = $dbi_s->fetchrow_arrayref())
	{
		undef $msgid;

		if (defined($dbi_a->[0]))
		{
			$msgid = $dbi_a->[0];
		}
		if (defined($dbi_a->[1]))
		{
			$ipaddr = $dbi_a->[1];
		}
		if (defined($dbi_a->[2]))
		{
			$disp = $dbi_a->[2];
		}
		if (defined($dbi_a->[3]))
		{
			$fromdomain = $dbi_a->[3];
		}
		if (defined($dbi_a->[4]))
		{
			$envdomain = $dbi_a->[4];
		}
		if (defined($dbi_a->[5]))
		{
			$spfresult = $dbi_a->[5];
		}
		if (defined($dbi_a->[6]))
		{
			$align_spf = $dbi_a->[6];
		}
		if (defined($dbi_a->[7]))
		{
			$align_dkim = $dbi_a->[7];
		}
		if (defined($dbi_a->[8]))
		{
			$arc = $dbi_a->[8];
		}
		if (defined($dbi_a->[9]))
		{
			$arcpolicy = $dbi_a->[9];
		}

		if (!defined($msgid))
		{
			next;
		}

		$rowcount++;

		switch ($disp)
		{
			case 0	{ $dispstr = "reject"; }
			case 1	{ $dispstr = "reject"; }
			case 2	{ $dispstr = "none"; }
			case 4	{ $dispstr = "quarantine"; }
			else	{ $dispstr = "unknown"; }
		}

		switch ($spfresult)
		{
			case 0	{ $spfresultstr = "pass"; }
			case 2	{ $spfresultstr = "softfail"; }
			case 3	{ $spfresultstr = "neutral"; }
			case 4	{ $spfresultstr = "temperror"; }
			case 5	{ $spfresultstr = "permerror"; }
			case 6	{ $spfresultstr = "none"; }
			case 7	{ $spfresultstr = "fail"; }
			case 8	{ $spfresultstr = "policy"; }
			case 9	{ $spfresultstr = "nxdomain"; }
			case 10	{ $spfresultstr = "signed"; }
			case 12	{ $spfresultstr = "discard"; }
			else	{ $spfresultstr = "unknown"; }
		}

		switch ($align_dkim)
		{
			case 4	{ $align_dkimstr = "pass"; }
			case 5	{ $align_dkimstr = "fail"; }
			else	{ $align_dkimstr = "unknown"; }
		}

		switch ($align_spf)
		{
			case 4	{ $align_spfstr = "pass"; }
			case 5	{ $align_spfstr = "fail"; }
			else	{ $align_spfstr = "unknown"; }
		}

		switch ($arc)
		{
			case 1	{ $arcstr = "pass"; }
			else	{ $arcstr = "fail"; }
		}

		switch ($arcpolicy)
		{
			case 0	{ $arcpolicystr = "pass"; }
			else	{ $arcpolicystr = "fail"; }
		}

		# retrieve arc_policy seals, join arcauthresults.arc_client_addr (smtp.client_ip)
		$dbi_s2 = $dbi_h->prepare(q{
		                          SELECT arcseals.instance, domains.name AS domain,
						selectors.name AS selector,
						arcauthresults.arc_client_addr as client_ip
		                          FROM arcseals
		                          JOIN domains on arcseals.domain = domains.id
		                          JOIN selectors on arcseals.selector = selectors.id
					  JOIN arcauthresults on arcseals.message = arcauthresults.message
					  	AND arcseals.instance = arcauthresults.instance
		                          WHERE arcseals.message = ?
		                          ORDER BY arcseals.instance DESC
		});
		if (!$dbi_s2->execute($msgid))
		{
			print STDERR "$progname: can't extract report for message $msgid: " . $dbi_h->errstr . "\n";
			$dbi_s2->finish;
			$dbi_s->finish;
			$dbi_h->disconnect;
			exit(1);
		}

		my $arc_policy_output = "arc=$arcpolicystr";
		while ($dbi_hash = $dbi_s2->fetchrow_hashref())
		{
			$arc_policy_output .= " as[$dbi_hash->{instance}].d=$dbi_hash->{domain}";
			$arc_policy_output .= " as[$dbi_hash->{instance}].s=$dbi_hash->{selector}";
			if ($dbi_hash->{instance} == 1 && (defined($dbi_hash->{client_ip}) && $dbi_hash->{client_ip} ne ""))
			{
				$arc_policy_output .= " client-ip[$dbi_hash->{instance}]=$dbi_hash->{client_ip}";
			}
		}

		$dbi_s2->finish;

		print $tmpout "    <record>\n";
		print $tmpout "        <row>\n";
		print $tmpout "            <source_ip>$ipaddr</source_ip>\n";
		print $tmpout "            <count>1</count>\n";
		print $tmpout "            <policy_evaluated>\n";
		print $tmpout "                <disposition>$dispstr</disposition>\n";
		print $tmpout "                <dkim>$align_dkimstr</dkim>\n";
		print $tmpout "                <spf>$align_spfstr</spf>\n";
		print $tmpout "                <reason>\n";
		print $tmpout "                    <type>local_policy</type>\n";
		print $tmpout "                    <comment>$arc_policy_output</comment>\n";
		print $tmpout "                </reason>\n";
		print $tmpout "            </policy_evaluated>\n";
		print $tmpout "        </row>\n";
		print $tmpout "        <identifiers>\n";
		print $tmpout "            <header_from>$fromdomain</header_from>\n";
		print $tmpout "        </identifiers>\n";
		print $tmpout "        <auth_results>\n";
		print $tmpout "            <spf>\n";
		print $tmpout "                <domain>$envdomain</domain>\n";
		print $tmpout "                <result>$spfresultstr</result>\n";
		print $tmpout "            </spf>\n";

		$dbi_s2 = $dbi_h->prepare(q{
		                          SELECT domains.name, selectors.name, pass
		                          FROM signatures
		                          JOIN domains ON signatures.domain = domains.id
		                          JOIN selectors ON signatures.selector = selectors.id
		                          WHERE signatures.message = ?
		});
		if (!$dbi_s2->execute($msgid))
		{
			print STDERR "$progname: can't extract report for message $msgid: " . $dbi_h->errstr . "\n";
			$dbi_s2->finish;
			$dbi_s->finish;
			$dbi_h->disconnect;
			exit(1);
		}

		my %dkim_domain_result_cache = ();
		while ($dbi_a = $dbi_s2->fetchrow_arrayref())
		{
			undef $dkimdomain;

			if (defined($dbi_a->[0]))
			{
				$dkimdomain = $dbi_a->[0];
			}
			if (defined($dbi_a->[1]))
			{
				$dkimselector = $dbi_a->[1];
			}
			if (defined($dbi_a->[2]))
			{
				$dkimresult = $dbi_a->[2];
			}

			if (!defined($dkimdomain))
			{
				next;
			}
			if (defined($dkim_domain_result_cache{$dkimdomain}{$dkimselector}{$dkimresult}))
			{
				next; # no duplicate per-record auth_result dkim sections
			}
			$dkim_domain_result_cache{$dkimdomain}{$dkimselector}{$dkimresult}++;

			switch ($dkimresult)
			{
				case 0	{ $dkimresultstr = "pass"; }
				case 2	{ $dkimresultstr = "softfail"; }
				case 3	{ $dkimresultstr = "neutral"; }
				case 4	{ $dkimresultstr = "temperror"; }
				case 5	{ $dkimresultstr = "permerror"; }
				case 6	{ $dkimresultstr = "none"; }
				case 7	{ $dkimresultstr = "fail"; }
				case 8	{ $dkimresultstr = "policy"; }
				case 9	{ $dkimresultstr = "nxdomain"; }
				case 10	{ $dkimresultstr = "signed"; }
				case 12	{ $dkimresultstr = "discard"; }
				else	{ $dkimresultstr = "unknown"; }
			}

			print $tmpout "            <dkim>\n";
			print $tmpout "                <domain>$dkimdomain</domain>\n";
			print $tmpout "                <selector>$dkimselector</selector>\n";
			print $tmpout "                <result>$dkimresultstr</result>\n";
			print $tmpout "            </dkim>\n";
		}

		$dbi_s2->finish;

		print $tmpout "        </auth_results>\n";
		print $tmpout "    </record>\n";
	}

	$dbi_s->finish;

	print $tmpout "</feedback>\n";

	close($tmpout);

	if ($rowcount == 0)
	{
		if ($verbose >= 2)
		{
			print STDERR "$progname: no activity selected for $domain; skipping\n";
		}

		unlink($repfile);
		next;
	}

	# zip the report
	if (!zip [ $repfile ] => $zipfile)
	{
		print STDERR "$progname: can't zip report for domain $domain: $!\n";
		next;
	}

	if ($keepfiles)
	{
		print STDERR "$progname: keeping report file \"$repfile\"\n";
	}

	if (!open($zipin, $zipfile))
	{
		print STDERR "$progname: can't read zipped report for $domain: $!\n";
		next;
	}
	my $encoded_report;
	while (read($zipin, $buf, 60*57))
	{
		$encoded_report .= encode_base64($buf);
	}
	close($zipin);
	my $reportsize = length($encoded_report);

	my $repdest = "";
	my $repdest_fallback = "";

	# decode the URI
	@repuris = split(',', $repuri);

	for $repuri (@repuris)
	{
		my $raw_address = check_uri($repuri);
		if ($raw_address eq "")
		{
			next;
		}
		else
		{
			my $domain_orgdom = $suffix->get_root_domain(lc($domain));
			my $address = $raw_address;
			$address =~ s/!\d{1,15}([kmgt])?$//i;
			my $repdestdomain = $address;
			$repdestdomain =~ s/.*@//;
			my $repdest_orgdom = $suffix->get_root_domain(lc($repdestdomain));

			if (defined($domain_orgdom) && defined($repdest_orgdom) && $domain_orgdom eq $repdest_orgdom)
			{
				if (check_size_restriction($raw_address, $reportsize))
				{
					$repdest .= $address . ", ";
				}
				else
				{
					$repdest_fallback .= $address . ", ";
				}
			}
			else
			{
				# validate external report destinations:
				my $replaced = 0;	# external address replaced
				my $authorized = 0;	# external address authorized
				my $temprepuri;
				my $res = Net::DNS::Resolver->new(udp_timeout => 15);
				my $reply = $res->query("$domain._report._dmarc.$repdestdomain", "TXT");
				if ($reply)
				{
					foreach my $txt ($reply->answer)
					{
						next unless $txt->type eq "TXT";
						my @parts = split(';', $txt->txtdata);
						my $type = shift @parts;
						next unless $type =~ m/^\s*v\s*=\s*DMARC1\s*/;
						$authorized = 1;
						# just for debugging:
						if ($txt->txtdata ne "v=DMARC1")
						{
							print STDERR "$progname: DEBUG: $domain._report._dmarc.$repdestdomain: query answer: ", $txt->txtdata, "\n";
						}
						foreach my $parts (@parts)
						{
							if ($parts =~ m/^\s*rua\s*=/)
							{
								$replaced = 1;
								$parts =~ s/^\s*rua\s*=\s*//;
								foreach my $tempuri (split(',', $parts))
								{
									$raw_address = check_uri($tempuri);
									if ($raw_address eq "")
									{
										next;
									}
									my $uridomain = lc($raw_address);
									$uridomain =~ s/.*@//;
									$uridomain =~ s/!\d{15}([kmgt])?$//;
									if ($repdestdomain eq $uridomain)
									{
										$address =~ s/!\d([kmgt])?$//i;
										if ($verbose)
										{
											print STDERR "$progname: adding new reporting URI for domain $domain: $address\n";
										}
										if (check_size_restriction($raw_address, $reportsize))
										{
											$repdest .= $address . ", ";
										}
										else
										{
											$repdest_fallback .= $address . ", ";
										}
									}
									else
									{
										if ($verbose)
										{
											print STDERR "$progname: ignoring new reporting URI due to differing host parts: $repdestdomain != $uridomain!\n";
										}
									}
								}
								# there should be only one part with "rua=", so stop here
								last;
							}
						}
						# there should be only one TXT record starting with "v=DMARC1", so stop here
						last;
					}
				}
				else
				{
					switch ($res->errorstring)
					{
						case "NXDOMAIN" { }				# definitely not authorized
						case "SERVFAIL" { $authorized = 1; }		# not a definite answer, so be kind
						case "query timed out" { $authorized = 1; }	# not a definite answer, so be kind
						else { $authorized = 1; }			# for now we authorize anything else
					}
				}

				if ($authorized && !$replaced)
				{

					$repdest .= $address . ", ";
				}
				elsif (!$authorized)
				{
					if ($verbose)
					{
						print STDERR "$progname: $domain is NOT authorized to send reports to $address, dropping address! (" . $res->errorstring . ")\n";
					}
					next;
				}
			}
		}
	}
	$repdest =~ s/, $//;
	$repdest_fallback =~ s/, $//;

	# Test mode, just report what would have been done
	if ($testmode)
	{
		if ($repdest ne "")
		{
			print STDERR "$progname: would email $domain report for " .
				     "$rowcount records to $repdest\n";
		}
		elsif ($repdest_fallback ne "")
		{
			print STDERR "$progname: would email an error report for " .
				     "$domain to $repdest_fallback\n";
		}
	}
	else
	{
		if ($repdest ne "")
		{
			# send out the report:
			$boundary = hostfqdn() . "/" . time();

			my $report_id = $domain . "-" . $now . "@" . $repdom;
			my $datestr = strftime("%a, %e %b %Y %H:%M:%S %z (%Z)", localtime);

			$mailout  = "To: $repdest\n";
			$mailout .= "From: $repemail\n";
			$mailout .= "Subject: Report Domain: " . $domain . "\n";
			$mailout .= "    Submitter: " . $repdom . "\n";
			$mailout .= "    Report-ID: " . $report_id . "\n";
			$mailout .= "X-Mailer: " . $progname . " v" . $version ."\n";
			$mailout .= "Date: " . $datestr . "\n";
			$mailout .= "Message-ID: <$report_id>\n";
			$mailout .= "Auto-Submitted: auto-generated\n";
			$mailout .= "MIME-Version: 1.0\n";
			$mailout .= "Content-Type: multipart/mixed; boundary=\"$boundary\"\n";
			$mailout .= "\n";
			$mailout .= "This is a MIME-encapsulated message.\n";
			$mailout .= "\n";
			$mailout .= "--$boundary\n";
			$mailout .= "Content-Type: text/plain;\n";
			$mailout .= "\n";
			$mailout .= "This is a DMARC aggregate report for $domain\n";
			$mailout .= "generated at " . strftime("%a, %b %e %Y %H:%M:%S %z (%Z)", localtime()) . "\n";
			$mailout .= "\n";
			$mailout .= "--$boundary\n";
			$mailout .= "Content-Type: application/zip\n";
			$mailout .= "Content-Disposition: attachment; filename=\"$zipfile\"\n";
			$mailout .= "Content-Transfer-Encoding: base64\n";
			$mailout .= "\n";
			$mailout .= $encoded_report;
			$mailout .= "\n";
			$mailout .= "--$boundary--\n";
			$smtpstatus = "sent";
			$smtpfail = 0;
			if (!$smtp->mail($repemail) ||
			    !$smtp->to(split(', ', $repdest), {SkipBad => 1 }) ||
			    !$smtp->data() ||
			    !$smtp->datasend($mailout) ||
			    !$smtp->dataend())
			{
				$smtpfail = 1;
				$smtpstatus = "failed to send";
			}

			if ($verbose || $smtpfail)
			{
				# now perl voodoo:
				$answer = ${${*$smtp}{'net_cmd_resp'}}[1] || $smtp->message() || 'unknown error';
				chomp($answer);
				print STDERR "$progname: $smtpstatus report for $domain to $repdest ($answer)\n";
			}

			$smtp->reset();
		}
		elsif ($repdest_fallback ne "")
		{
			# send error report to $repdest_fallback:
			if ($verbose)
			{
				print STDERR "$progname: emailing an error report for $domain to $repdest_fallback\n";
			}
			$boundary = hostfqdn() . "/" . time();

			my $report_id = $domain . "-" . $now . "@" . $repdom;
			my $datestr = strftime("%a, %e %b %Y %H:%M:%S %z (%Z)", localtime);

			$mailout  = "To: $repdest_fallback\n";
			$mailout .= "From: $repemail\n";
			$mailout .= "Subject: Error Report Domain: " . $domain . " Submitter: " . $repdom . " Report-ID: " . $report_id . "\n";
			$mailout .= "X-Mailer: " . $progname . " v" . $version ."\n";
			$mailout .= "Date: " . $datestr . "\n";
			$mailout .= "Message-ID: <$report_id>\n";
			$mailout .= "Auto-Submitted: auto-generated\n";
			$mailout .= "MIME-Version: 1.0\n";
			$mailout .= "Content-Type: multipart/report;\n";
		        $mailout .= "    report-type=delivery-status;\n";
		        $mailout .= "    boundary=\"$boundary\"\n";
			$mailout .= "\n";
			$mailout .= "This is a MIME-encapsulated message.\n";
			$mailout .= "\n";
			$mailout .= "--$boundary\n";
			$mailout .= "Content-Description: DMARC Notification\n";
			$mailout .= "Content-Type: text/plain\n";
			$mailout .= "\n";
			$mailout .= "This is a DMARC error report from host " . hostfqdn() . ".\n";
			$mailout .= "\n";
			$mailout .= "I'm sorry to have to inform you that a DMARC aggregate report\n";
			$mailout .= "could not be delivered to any of your URIs mentioned in your DMARC\n";
		        $mailout .= "DNS resource records because of size limitations.\n";
			$mailout .= "\n";
			$mailout .= "--$boundary\n";
			$mailout .= "Content-Description: DMARC Error Report\n";
			$mailout .= "Content-Type: text/plain\n";
			$mailout .= "\n";
			$mailout .= "Report-Date: " . strftime("%a, %b %e %Y %H:%M:%S %z (%Z)", localtime()) . "\n";
			$mailout .= "Report-Domain: $domain\n";
			$mailout .= "Report-ID: $report_id\n";
			$mailout .= "Report-Size: $reportsize\n";
			$mailout .= "Submitter: $repdom\n";
			$mailout .= "Submitting-URI: $repdest_fallback\n";
			$mailout .= "\n";
			$mailout .= "--$boundary--\n";
			$smtpstatus = "sent";
			$smtpfail = 0;
			if (!$smtp->mail($repemail) ||
			    !$smtp->to(split(', ', $repdest_fallback), { SkipBad => 1 }) ||
			    !$smtp->data() ||
			    !$smtp->datasend($mailout) ||
			    !$smtp->dataend())
			{
				$smtpfail = 1;
				$smtpstatus = "failed to send";
			}

			if ($verbose || $smtpfail)
			{
				# now perl voodoo:
				$answer = ${${*$smtp}{'net_cmd_resp'}}[1] || $smtp->message() || 'unknown error';
				chomp($answer);
				print STDERR "$progname: $smtpstatus failure notice for report for $domain to $repdest ($answer)\n";
			}

			$smtp->reset();
		}
	}

	# update "last sent" timestamp
	if ($doupdate)
	{
		$dbi_s = $dbi_h->prepare("UPDATE requests SET lastsent = FROM_UNIXTIME(?) WHERE domain = ?");
		if (!$dbi_s->execute($repend, $domainid))
		{
			print STDERR "$progname: can't update last sent time for domain $domain: " . $dbi_h->errstr . "\n";
			$dbi_s->finish;
			$dbi_h->disconnect;
			exit(1);
		}
	}

	unlink($zipfile);
	if (!$keepfiles)
	{
		unlink($repfile);
	}
}

$smtp->quit();

#
# all done!
#

$dbi_s->finish;

if ($verbose)
{
	print STDERR "$progname: terminating at " . localtime() . "\n";
}

$dbi_h->disconnect;

exit(0);
