1#!/usr/local/bin/perl
2#
3# Copyright (c) 2012-2016, 2017-2018, The Trusted Domain Project.
4#   All rights reserved.
5#
6# Script to generate regular DMARC reports.
7
8###
9### Setup
10###
11
12use strict;
13use warnings;
14
15use Switch;
16
17use DBI;
18use File::Basename;
19use File::Temp;
20use Net::Domain qw(hostfqdn hostdomain);
21use Getopt::Long;
22use IO::Handle;
23use IO::Compress::Zip qw(zip);
24use POSIX;
25use MIME::Base64;
26use Net::SMTP;
27use Time::Local;
28
29require DBD::@SQL_BACKEND@;
30
31require HTTP::Request;
32
33# general
34my $progname      = basename($0);
35my $version       = "@VERSION@";
36my $verbose       = 0;
37my $helponly      = 0;
38my $showversion   = 0;
39
40my $interval;
41
42my $gen;
43my $uri;
44
45my $buf;
46
47my $mailout;
48my $boundary;
49
50my $tmpout;
51
52my $repfile;
53my $zipfile;
54
55my $zipin;
56
57my $now = time();
58
59my $repstart;
60my $repend;
61
62my $domain;
63my $domainid;
64my $domainset;
65my $forcedomain;
66my @skipdomains;
67
68my $policy;
69my $spolicy;
70my $policystr;
71my $spolicystr;
72my $pct;
73
74my $repuri;
75my @repuris;
76my $lastsent;
77
78my $aspf;
79my $aspfstr;
80my $adkim;
81my $adkimstr;
82my $align_dkim;
83my $align_dkimstr;
84my $align_spf;
85my $align_spfstr;
86my $spfresult;
87my $dkimresult;
88my $disp;
89my $spfresultstr;
90my $dkimresultstr;
91my $dispstr;
92my $ipaddr;
93my $fromdomain;
94my $envdomain;
95my $dkimdomain;
96my $dkimselector;
97my $arc;
98my $arcstr;
99my $arcpolicy;
100my $arcpolicystr;
101
102my $repdest;
103
104my $smtpstatus;
105my $smtpfail;
106
107my $doupdate = 1;
108my $testmode = 0;
109my $keepfiles = 0;
110my $use_utc = 0;
111my $daybound = 0;
112my $report_maxbytes_global = 15728640; # default: 15M, per spec
113
114my $msgid;
115
116my $rowcount;
117
118my $dbi_h;
119my $dbi_s;
120my $dbi_s2;
121my $dbi_a;
122my $dbi_hash;
123
124# DB parameters
125my $def_dbhost    = "localhost";
126my $def_dbname    = "opendmarc";
127my $def_dbuser    = "opendmarc";
128my $def_dbpasswd  = "opendmarc";
129my $def_dbport    = "3306";
130my $def_interval  = "86400";
131my $dbhost;
132my $dbname;
133my $dbuser;
134my $dbpasswd;
135my $dbport;
136
137my $dbscheme     = "@SQL_BACKEND@";
138
139my $repdom       = hostdomain();
140my $repemail     = "postmaster@" . $repdom;
141
142my $smtp_server  = '127.0.0.1';
143my $smtp_port    = 25;
144my $smtp;
145
146my $answer;
147
148###
149### NO user-serviceable parts beyond this point
150###
151
152sub usage
153{
154	print STDERR "$progname: usage: $progname [options]\n";
155	print STDERR "\t--day              send yesterday's data\n";
156	print STDERR "\t--dbhost=host      database host [$def_dbhost]\n";
157	print STDERR "\t--dbname=name      database name [$def_dbname]\n";
158	print STDERR "\t--dbpasswd=passwd  database password [$def_dbpasswd]\n";
159	print STDERR "\t--dbport=port      database port [$def_dbport]\n";
160	print STDERR "\t--dbuser=user      database user [$def_dbuser]\n";
161	print STDERR "\t--domain=name      force a report for named domain\n";
162	print STDERR "\t--help             print help and exit\n";
163	print STDERR "\t--interval=secs    report interval [$def_interval]\n";
164	print STDERR "\t--keepfiles        keep xml files (in local directory)\n";
165	print STDERR "\t -n                synonym for --test\n";
166	print STDERR "\t--nodomain=name    omit a report for named domain\n";
167	print STDERR "\t--noupdate         don't record report transmission\n";
168	print STDERR "\t--report-email     reporting contact [$repemail]\n";
169	print STDERR "\t--report-org       reporting organization [$repdom]\n";
170	print STDERR "\t--smtp-port        smtp server port [$smtp_port]\n";
171	print STDERR "\t--smtp-server      smtp server [$smtp_server]\n";
172	print STDERR "\t--test             don't send reports\n";
173	print STDERR "\t                   (implies --keepfiles --noupdate)\n";
174	print STDERR "\t--utc              operate in UTC\n";
175	print STDERR "\t--verbose          verbose output\n";
176	print STDERR "\t                   (repeat for increased output)\n";
177	print STDERR "\t--version          print version and exit\n";
178}
179
180# set locale
181setlocale(LC_ALL, 'C');
182
183# parse command line arguments
184my $opt_retval = &Getopt::Long::GetOptions ('day!' => \$daybound,
185                                            'dbhost=s' => \$dbhost,
186                                            'dbname=s' => \$dbname,
187                                            'dbpasswd=s' => \$dbpasswd,
188                                            'dbport=s' => \$dbport,
189                                            'dbuser=s' => \$dbuser,
190                                            'domain=s' => \$forcedomain,
191                                            'help!' => \$helponly,
192                                            'interval=i' => \$interval,
193                                            'keepfiles' => \$keepfiles,
194                                            'n|test' => \$testmode,
195                                            'nodomain=s' => \@skipdomains,
196                                            'report-email=s' => \$repemail,
197                                            'report-org=s' => \$repdom,
198                                            'smtp-server=s' => \$smtp_server,
199                                            'smtp-port=i' => \$smtp_port,
200                                            'update!' => \$doupdate,
201                                            'utc!' => \$use_utc,
202                                            'verbose+' => \$verbose,
203                                            'version!' => \$showversion,
204                                           );
205
206if (!$opt_retval || $helponly)
207{
208	usage();
209
210	if ($helponly)
211	{
212		exit(0);
213	}
214	else
215	{
216		exit(1);
217	}
218}
219
220if ($showversion)
221{
222	print STDOUT "$progname v$version\n";
223	exit(0);
224}
225
226# apply defaults
227if (!defined($dbhost))
228{
229	if (defined($ENV{'OPENDMARC_DBHOST'}))
230	{
231		$dbhost = $ENV{'OPENDMARC_DBHOST'};
232	}
233	else
234	{
235		$dbhost = $def_dbhost;
236	}
237}
238
239if (!defined($dbname))
240{
241	if (defined($ENV{'OPENDMARC_DB'}))
242	{
243		$dbname = $ENV{'OPENDMARC_DB'};
244	}
245	else
246	{
247		$dbname = $def_dbname;
248	}
249}
250
251if (!defined($dbpasswd))
252{
253	if (defined($ENV{'OPENDMARC_PASSWORD'}))
254	{
255		$dbpasswd = $ENV{'OPENDMARC_PASSWORD'};
256	}
257	else
258	{
259		$dbpasswd = $def_dbpasswd;
260	}
261}
262
263if (!defined($dbport))
264{
265	if (defined($ENV{'OPENDMARC_PORT'}))
266	{
267		$dbport = $ENV{'OPENDMARC_PORT'};
268	}
269	else
270	{
271		$dbport = $def_dbport;
272	}
273}
274
275if (!defined($dbuser))
276{
277	if (defined($ENV{'OPENDMARC_USER'}))
278	{
279		$dbuser = $ENV{'OPENDMARC_USER'};
280	}
281	else
282	{
283		$dbuser = $def_dbuser;
284	}
285}
286
287if (defined($interval) && $daybound)
288{
289	print STDERR "$progname: WARN: --day overrides --interval\n";
290}
291
292if (!defined($interval) || $daybound)
293{
294	$interval = $def_interval;
295}
296
297# Test mode requested, don't update last sent and keep xml files
298$doupdate  = ($testmode == 1) ? 0 : $doupdate;
299$keepfiles = ($testmode == 1) ? 1 : $keepfiles;
300
301if ($verbose)
302{
303	print STDERR "$progname: started at " . localtime($now) . "\n";
304}
305
306my $dbi_dsn = "DBI:" . $dbscheme . ":database=" . $dbname .
307              ";host=" . $dbhost . ";port=" . $dbport;
308
309$dbi_h = DBI->connect($dbi_dsn, $dbuser, $dbpasswd, { PrintError => 0 });
310if (!defined($dbi_h))
311{
312	print STDERR "$progname: unable to connect to database: $DBI::errstr\n";
313	exit(1);
314}
315
316if ($verbose >= 2)
317{
318	print STDERR "$progname: connected to database\n";
319}
320
321if ($use_utc)
322{
323	$dbi_s = $dbi_h->prepare("SET TIME_ZONE='+00:00'");
324
325	if (!$dbi_s->execute())
326	{
327		print STDERR "$progname: failed to change to UTC: " . $dbi_h->errstr . "\n";
328		$dbi_s->finish;
329		$dbi_h->disconnect;
330		exit(1);
331	}
332}
333
334#
335# Select domains on which to report
336#
337
338if ($verbose >= 2)
339{
340	print STDERR "$progname: selecting target domains\n";
341}
342
343if (defined($forcedomain))
344{
345	$dbi_s = $dbi_h->prepare("SELECT name FROM domains WHERE name = ?");
346
347	if (!$dbi_s->execute($forcedomain))
348	{
349		print STDERR "$progname: failed to test for database entry: " . $dbi_h->errstr . "\n";
350		$dbi_s->finish;
351		$dbi_h->disconnect;
352		exit(1);
353	}
354}
355elsif ($daybound)
356{
357	$dbi_s = $dbi_h->prepare("SELECT domains.name FROM requests JOIN domains ON requests.domain = domains.id WHERE DATE(lastsent) < DATE(FROM_UNIXTIME(?))");
358
359	if (!$dbi_s->execute($now))
360	{
361		print STDERR "$progname: failed to collect domain names: " . $dbi_h->errstr . "\n";
362		$dbi_s->finish;
363		$dbi_h->disconnect;
364		exit(1);
365	}
366}
367else
368{
369	$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)");
370
371	if (!$dbi_s->execute($now, $interval))
372	{
373		print STDERR "$progname: failed to collect domain names: " . $dbi_h->errstr . "\n";
374		$dbi_s->finish;
375		$dbi_h->disconnect;
376		exit(1);
377	}
378}
379
380$domainset = $dbi_s->fetchall_arrayref([0]);
381$dbi_s->finish;
382
383if ($verbose)
384{
385	print STDERR "$progname: selected " . scalar(@$domainset) . " domain(s)\n";
386}
387
388#
389# For each domain:
390# 	-- extract reporting address
391# 	-- extract messages/signatures to report
392# 	-- generate and send report
393# 	-- update "last sent" timestamp
394#
395
396$smtp = Net::SMTP->new($smtp_server,
397                       'Port' => $smtp_port,
398                       'Hello' => hostfqdn());
399if (!defined($smtp))
400{
401	print STDERR "$progname: open SMTP server $smtp_server:$smtp_port failed\n";
402	exit(1);
403}
404
405foreach (@$domainset)
406{
407	$domain = $_->[0];
408
409	if (!defined($domain))
410	{
411		next;
412	}
413
414	if (@skipdomains && grep({$_ eq $domain} @skipdomains) != 0)
415	{
416		next;
417	}
418
419	if ($verbose >= 2)
420	{
421		print STDERR "$progname: processing $domain\n";
422	}
423
424	# extract this domain's reporting parameters
425	$dbi_s = $dbi_h->prepare("SELECT id FROM domains WHERE name = ?");
426	if (!$dbi_s->execute($domain))
427	{
428		print STDERR "$progname: can't get ID for domain $domain: " . $dbi_h->errstr . "\n";
429		$dbi_s->finish;
430		$dbi_h->disconnect;
431		exit(1);
432	}
433
434	undef $domainid;
435	while ($dbi_a = $dbi_s->fetchrow_arrayref())
436	{
437		if (defined($dbi_a->[0]))
438		{
439			$domainid = $dbi_a->[0];
440		}
441	}
442	$dbi_s->finish;
443
444	if (!defined($domainid))
445	{
446		print STDERR "$progname: ID for domain $domain not found\n";
447		next;
448	}
449
450	$dbi_s = $dbi_h->prepare("SELECT repuri, adkim, aspf, policy, spolicy, pct, UNIX_TIMESTAMP(lastsent) FROM requests WHERE domain = ?");
451	if (!$dbi_s->execute($domainid))
452	{
453		print STDERR "$progname: can't get reporting URI for domain $domain: " . $dbi_h->errstr . "\n";
454		$dbi_s->finish;
455		$dbi_h->disconnect;
456		exit(1);
457	}
458
459	undef $repuri;
460
461	while ($dbi_a = $dbi_s->fetchrow_arrayref())
462	{
463		if (defined($dbi_a->[0]))
464		{
465			$repuri = $dbi_a->[0];
466		}
467		if (defined($dbi_a->[1]))
468		{
469			$adkim = $dbi_a->[1];
470		}
471		if (defined($dbi_a->[2]))
472		{
473			$aspf = $dbi_a->[2];
474		}
475		if (defined($dbi_a->[3]))
476		{
477			$policy = $dbi_a->[3];
478		}
479		if (defined($dbi_a->[4]))
480		{
481			$spolicy = $dbi_a->[4];
482		}
483		if (defined($dbi_a->[5]))
484		{
485			$pct = $dbi_a->[5];
486		}
487		if (defined($dbi_a->[6]))
488		{
489			$lastsent = $dbi_a->[6];
490		}
491	}
492
493	$dbi_s->finish;
494
495	if (!defined($repuri) || ("" eq $repuri))
496	{
497		if ($verbose >= 2)
498		{
499			print STDERR "$progname: no reporting URI for domain $domain; skipping\n";
500		}
501
502		next;
503	}
504
505	if ($daybound)
506	{
507		my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($now - $interval);
508		$repstart = timelocal(0, 0, 0, $mday, $mon, $year);
509		($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($now);
510		$repend = timelocal(0, 0, 0, $mday, $mon, $year);
511	}
512	else
513	{
514		$repstart = $now - $interval;
515		$repend = $now;
516	}
517
518	# construct the temporary file
519	$repfile = $repdom . "!" . $domain . "!" . $repstart . "!" . $repend . ".xml";
520	$zipfile = $repdom . "!" . $domain . "!" . $repstart . "!" . $repend . ".zip";
521	if (!open($tmpout, ">", $repfile))
522	{
523		print STDERR "$progname: can't create report file for domain $domain\n";
524		next;
525	}
526
527	switch ($adkim)
528	{
529		case ord("r")	{ $adkimstr = "r"; }
530		case ord("s")	{ $adkimstr = "s"; }
531		else		{ $adkimstr = "unknown"; }
532	}
533
534	switch ($aspf)
535	{
536		case ord("r")	{ $aspfstr = "r"; }
537		case ord("s")	{ $aspfstr = "s"; }
538		else		{ $aspfstr = "unknown"; }
539	}
540
541	switch ($policy)
542	{
543		case ord("n")	{ $policystr = "none"; }
544		case ord("q")	{ $policystr = "quarantine"; }
545		case ord("r")	{ $policystr = "reject"; }
546		else		{ $policystr = "unknown"; }
547	}
548
549 	switch ($spolicy)
550 	{
551 		case 0		{ $spolicystr = $policystr; }
552 		case ord("n")	{ $spolicystr = "none"; }
553 		case ord("q")	{ $spolicystr = "quarantine"; }
554 		case ord("r")	{ $spolicystr = "reject"; }
555 		else		{ $spolicystr = "unknown"; }
556 	}
557
558
559	print $tmpout "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n";
560	print $tmpout "<feedback>\n";
561
562	print $tmpout "    <report_metadata>\n";
563	print $tmpout "        <org_name>$repdom</org_name>\n";
564	print $tmpout "         <email>$repemail</email>\n";
565	print $tmpout "         <report_id>$domain:$now</report_id>\n";
566	print $tmpout "         <date_range>\n";
567	print $tmpout "         <begin>$repstart</begin>\n";
568	print $tmpout "         <end>$repend</end>\n";
569	print $tmpout "         </date_range>\n";
570	print $tmpout "    </report_metadata>\n";
571
572	print $tmpout "    <policy_published>\n";
573	print $tmpout "        <domain>$domain</domain>\n";
574	print $tmpout "        <adkim>$adkimstr</adkim>\n";
575	print $tmpout "        <aspf>$aspfstr</aspf>\n";
576	print $tmpout "        <p>$policystr</p>\n";
577	print $tmpout "        <sp>$spolicystr</sp>\n";
578	print $tmpout "        <pct>$pct</pct>\n";
579	print $tmpout "    </policy_published>\n";
580
581	if ($daybound)
582	{
583		$dbi_s = $dbi_h->prepare(q{
584		                         SELECT messages.id, ipaddr.addr, messages.disp, d1.name, d2.name,
585		                                 messages.spf, messages.align_spf, messages.align_dkim,
586		                                 messages.arc, messages.arc_policy
587		                         FROM messages
588		                         JOIN ipaddr ON messages.ip = ipaddr.id
589		                         JOIN domains d1 ON messages.from_domain = d1.id
590		                         JOIN domains d2 ON messages.env_domain = d2.id
591		                         WHERE messages.from_domain = ?
592		                                 AND DATE(messages.date) >= DATE(FROM_UNIXTIME(?))
593		                                 AND DATE(messages.date) < DATE(FROM_UNIXTIME(?))
594		});
595	}
596	else
597	{
598		$dbi_s = $dbi_h->prepare(q{
599		                         SELECT messages.id, ipaddr.addr, messages.disp, d1.name, d2.name,
600		                                 messages.spf, messages.align_spf, messages.align_dkim,
601		                                 messages.arc, messages.arc_policy
602		                         FROM messages
603		                         JOIN ipaddr ON messages.ip = ipaddr.id
604		                         JOIN domains d1 ON messages.from_domain = d1.id
605		                         JOIN domains d2 ON messages.env_domain = d2.id
606		                         WHERE messages.from_domain = ?
607		                                 AND messages.date > FROM_UNIXTIME(?)
608		                                 AND messages.date <= FROM_UNIXTIME(?)
609		});
610	}
611
612	if (!$dbi_s->execute($domainid, $repstart, $repend))
613	{
614		print STDERR "$progname: can't extract report for domain $domain: " . $dbi_h->errstr . "\n";
615		$dbi_s->finish;
616		$dbi_h->disconnect;
617		exit(1);
618	}
619
620	$rowcount = 0;
621
622	while ($dbi_a = $dbi_s->fetchrow_arrayref())
623	{
624		undef $msgid;
625
626		if (defined($dbi_a->[0]))
627		{
628			$msgid = $dbi_a->[0];
629		}
630		if (defined($dbi_a->[1]))
631		{
632			$ipaddr = $dbi_a->[1];
633		}
634		if (defined($dbi_a->[2]))
635		{
636			$disp = $dbi_a->[2];
637		}
638		if (defined($dbi_a->[3]))
639		{
640			$fromdomain = $dbi_a->[3];
641		}
642		if (defined($dbi_a->[4]))
643		{
644			$envdomain = $dbi_a->[4];
645		}
646		if (defined($dbi_a->[5]))
647		{
648			$spfresult = $dbi_a->[5];
649		}
650		if (defined($dbi_a->[6]))
651		{
652			$align_spf = $dbi_a->[6];
653		}
654		if (defined($dbi_a->[7]))
655		{
656			$align_dkim = $dbi_a->[7];
657		}
658		if (defined($dbi_a->[8]))
659		{
660			$arc = $dbi_a->[8];
661		}
662		if (defined($dbi_a->[9]))
663		{
664			$arcpolicy = $dbi_a->[9];
665		}
666
667		if (!defined($msgid))
668		{
669			next;
670		}
671
672		$rowcount++;
673
674		switch ($disp)
675		{
676			case 0	{ $dispstr = "reject"; }
677			case 1	{ $dispstr = "reject"; }
678			case 2	{ $dispstr = "none"; }
679			case 4	{ $dispstr = "quarantine"; }
680			else	{ $dispstr = "unknown"; }
681		}
682
683		switch ($spfresult)
684		{
685			case 0	{ $spfresultstr = "pass"; }
686			case 2	{ $spfresultstr = "softfail"; }
687			case 3	{ $spfresultstr = "neutral"; }
688			case 4	{ $spfresultstr = "temperror"; }
689			case 5	{ $spfresultstr = "permerror"; }
690			case 6	{ $spfresultstr = "none"; }
691			case 7	{ $spfresultstr = "fail"; }
692			case 8	{ $spfresultstr = "policy"; }
693			case 9	{ $spfresultstr = "nxdomain"; }
694			case 10	{ $spfresultstr = "signed"; }
695			case 12	{ $spfresultstr = "discard"; }
696			else	{ $spfresultstr = "unknown"; }
697		}
698
699		switch ($align_dkim)
700		{
701			case 4	{ $align_dkimstr = "pass"; }
702			case 5	{ $align_dkimstr = "fail"; }
703			else	{ $align_dkimstr = "unknown"; }
704		}
705
706		switch ($align_spf)
707		{
708			case 4	{ $align_spfstr = "pass"; }
709			case 5	{ $align_spfstr = "fail"; }
710			else	{ $align_spfstr = "unknown"; }
711		}
712
713		switch ($arc)
714		{
715			case 1	{ $arcstr = "pass"; }
716			else	{ $arcstr = "fail"; }
717		}
718
719		switch ($arcpolicy)
720		{
721			case 0	{ $arcpolicystr = "pass"; }
722			else	{ $arcpolicystr = "fail"; }
723		}
724
725		# retrieve arc_policy seals, join arcauthresults.arc_client_addr (smtp.client_ip)
726		$dbi_s2 = $dbi_h->prepare(q{
727		                          SELECT arcseals.instance, domains.name AS domain,
728						selectors.name AS selector,
729						arcauthresults.arc_client_addr as client_ip
730		                          FROM arcseals
731		                          JOIN domains on arcseals.domain = domains.id
732		                          JOIN selectors on arcseals.selector = selectors.id
733					  JOIN arcauthresults on arcseals.message = arcauthresults.message
734					  	AND arcseals.instance = arcauthresults.instance
735		                          WHERE arcseals.message = ?
736		                          ORDER BY arcseals.instance DESC
737		});
738		if (!$dbi_s2->execute($msgid))
739		{
740			print STDERR "$progname: can't extract report for message $msgid: " . $dbi_h->errstr . "\n";
741			$dbi_s2->finish;
742			$dbi_s->finish;
743			$dbi_h->disconnect;
744			exit(1);
745		}
746
747		my $arc_policy_output = "arc=$arcpolicystr";
748		while ($dbi_hash = $dbi_s2->fetchrow_hashref())
749		{
750			$arc_policy_output .= " as[$dbi_hash->{instance}].d=$dbi_hash->{domain}";
751			$arc_policy_output .= " as[$dbi_hash->{instance}].s=$dbi_hash->{selector}";
752			if ($dbi_hash->{instance} == 1 && (defined($dbi_hash->{client_ip}) && $dbi_hash->{client_ip} ne ""))
753			{
754				$arc_policy_output .= " client-ip[$dbi_hash->{instance}]=$dbi_hash->{client_ip}";
755			}
756		}
757
758		$dbi_s2->finish;
759
760		print $tmpout "    <record>\n";
761		print $tmpout "        <row>\n";
762		print $tmpout "            <source_ip>$ipaddr</source_ip>\n";
763		print $tmpout "            <count>1</count>\n";
764		print $tmpout "            <policy_evaluated>\n";
765		print $tmpout "                <disposition>$dispstr</disposition>\n";
766		print $tmpout "                <dkim>$align_dkimstr</dkim>\n";
767		print $tmpout "                <spf>$align_spfstr</spf>\n";
768		print $tmpout "                <reason>\n";
769		print $tmpout "                    <type>local_policy</type>\n";
770		print $tmpout "                    <comment>$arc_policy_output</comment>\n";
771		print $tmpout "                </reason>\n";
772		print $tmpout "            </policy_evaluated>\n";
773		print $tmpout "        </row>\n";
774		print $tmpout "        <identifiers>\n";
775		print $tmpout "            <header_from>$fromdomain</header_from>\n";
776		print $tmpout "        </identifiers>\n";
777		print $tmpout "        <auth_results>\n";
778		print $tmpout "            <spf>\n";
779		print $tmpout "                <domain>$envdomain</domain>\n";
780		print $tmpout "                <result>$spfresultstr</result>\n";
781		print $tmpout "            </spf>\n";
782
783		$dbi_s2 = $dbi_h->prepare(q{
784		                          SELECT domains.name, selectors.name, pass
785		                          FROM signatures
786		                          JOIN domains ON signatures.domain = domains.id
787		                          JOIN selectors ON signatures.selector = selectors.id
788		                          WHERE signatures.message = ?
789		});
790		if (!$dbi_s2->execute($msgid))
791		{
792			print STDERR "$progname: can't extract report for message $msgid: " . $dbi_h->errstr . "\n";
793			$dbi_s2->finish;
794			$dbi_s->finish;
795			$dbi_h->disconnect;
796			exit(1);
797		}
798
799		my %dkim_domain_result_cache = ();
800		while ($dbi_a = $dbi_s2->fetchrow_arrayref())
801		{
802			undef $dkimdomain;
803
804			if (defined($dbi_a->[0]))
805			{
806				$dkimdomain = $dbi_a->[0];
807			}
808			if (defined($dbi_a->[1]))
809			{
810				$dkimselector = $dbi_a->[1];
811			}
812			if (defined($dbi_a->[2]))
813			{
814				$dkimresult = $dbi_a->[2];
815			}
816
817			if (!defined($dkimdomain))
818			{
819				next;
820			}
821			if (defined($dkim_domain_result_cache{$dkimdomain}{$dkimselector}{$dkimresult}))
822			{
823				next; # no duplicate per-record auth_result dkim sections
824			}
825			$dkim_domain_result_cache{$dkimdomain}{$dkimselector}{$dkimresult}++;
826
827			switch ($dkimresult)
828			{
829				case 0	{ $dkimresultstr = "pass"; }
830				case 2	{ $dkimresultstr = "softfail"; }
831				case 3	{ $dkimresultstr = "neutral"; }
832				case 4	{ $dkimresultstr = "temperror"; }
833				case 5	{ $dkimresultstr = "permerror"; }
834				case 6	{ $dkimresultstr = "none"; }
835				case 7	{ $dkimresultstr = "fail"; }
836				case 8	{ $dkimresultstr = "policy"; }
837				case 9	{ $dkimresultstr = "nxdomain"; }
838				case 10	{ $dkimresultstr = "signed"; }
839				case 12	{ $dkimresultstr = "discard"; }
840				else	{ $dkimresultstr = "unknown"; }
841			}
842
843			print $tmpout "            <dkim>\n";
844			print $tmpout "                <domain>$dkimdomain</domain>\n";
845			print $tmpout "                <selector>$dkimselector</selector>\n";
846			print $tmpout "                <result>$dkimresultstr</result>\n";
847			print $tmpout "            </dkim>\n";
848		}
849
850		$dbi_s2->finish;
851
852		print $tmpout "        </auth_results>\n";
853		print $tmpout "    </record>\n";
854	}
855
856	$dbi_s->finish;
857
858	print $tmpout "</feedback>\n";
859
860	close($tmpout);
861
862	if ($rowcount == 0)
863	{
864		if ($verbose >= 2)
865		{
866			print STDERR "$progname: no activity selected for $domain; skipping\n";
867		}
868
869		unlink($repfile);
870		next;
871	}
872
873	# zip the report
874	if (!zip [ $repfile ] => $zipfile)
875	{
876		print STDERR "$progname: can't zip report for domain $domain: $!\n";
877		next;
878	}
879
880	if ($keepfiles)
881	{
882		print STDERR "$progname: keeping report file \"$repfile\"\n";
883	}
884
885	# decode the URI
886	@repuris = split(',', $repuri);
887
888	for $repuri (@repuris)
889	{
890		$uri = URI->new($repuri);
891		if (!defined($uri) ||
892		    !defined($uri->scheme) ||
893		    $uri->opaque eq "")
894		{
895			print STDERR "$progname: can't parse reporting URI for domain $domain\n";
896			next;
897		}
898
899		$repdest = $uri->opaque;
900		my $report_maxbytes = $report_maxbytes_global;
901
902		# check for max report size
903		if ($repdest =~ m/^(\S+)!(\d{1,15})([kmgt])?$/i)
904		{
905			$repdest = $1;
906			$report_maxbytes = $2;
907			if ($3)
908			{
909				my $letter = lc($3);
910				if ($letter eq 'k')
911				{
912					$report_maxbytes = $report_maxbytes * 1024;
913				}
914				if ($letter eq 'm')
915				{
916					$report_maxbytes = $report_maxbytes * 1048576;
917				}
918				if ($letter eq 'g')
919				{
920					$report_maxbytes = $report_maxbytes * (2**30);
921				}
922				if ($letter eq 't')
923				{
924					$report_maxbytes = $report_maxbytes * (2**40);
925				}
926			}
927		}
928
929		# Test mode, just report what would have been done
930		if ($testmode)
931		{
932			print STDERR "$progname: would email $domain report for " .
933			             "$rowcount records to " .  $uri->opaque . "\n";
934		}
935		# ensure a scheme is present
936		elsif (!defined($uri->scheme))
937		{
938			if ($verbose >= 2)
939			{
940				print STDERR "$progname: unknown URI scheme in '$repuri' for domain $domain\n";
941			}
942			next;
943		}
944		# send/post report
945		elsif ($uri->scheme eq "mailto")
946		{
947			my $datestr;
948			my $report_id;
949
950			if (!open($zipin, $zipfile))
951			{
952				print STDERR "$progname: can't read zipped report for $domain: $!\n";
953				next;
954			}
955
956			$boundary = "report_section";
957
958 			$report_id = $domain . "-" . $now . "@" . $repdom;
959			$datestr = strftime("%a, %e %b %Y %H:%M:%S %z (%Z)",
960			                    localtime);
961
962			$mailout  = "To: $repdest\n";
963			$mailout .= "From: $repemail\n";
964			$mailout .= "Subject: Report Domain: " . $domain . " Submitter: " . $repdom . " Report-ID: " . $report_id . "\n";
965			$mailout .= "X-Mailer: " . $progname . " v" . $version ."\n";
966			$mailout .= "Date: " . $datestr . "\n";
967			$mailout .= "Message-ID: <$report_id>\n";
968			$mailout .= "Auto-Submitted: auto-generated\n";
969			$mailout .= "MIME-Version: 1.0\n";
970			$mailout .= "Content-Type: multipart/mixed; boundary=\"$boundary\"\n";
971			$mailout .= "\n";
972			$mailout .= "This is a MIME-encapsulated message.\n";
973			$mailout .= "\n";
974			$mailout .= "--$boundary\n";
975			$mailout .= "Content-Type: text/plain;\n";
976			$mailout .= "\n";
977			$mailout .= "This is a DMARC aggregate report for $domain\n";
978			$mailout .= "generated at " . localtime() . "\n";
979			$mailout .= "\n";
980			$mailout .= "--$boundary\n";
981			$mailout .= "Content-Type: application/zip\n";
982			$mailout .= "Content-Disposition: attachment; filename=\"$zipfile\"\n";
983			$mailout .= "Content-Transfer-Encoding: base64\n";
984			$mailout .= "\n";
985
986			while (read($zipin, $buf, 60*57))
987			{
988				$mailout .= encode_base64($buf);
989			}
990
991			$mailout .= "\n";
992			$mailout .= "--$boundary--\n";
993			my $reportsize = length($mailout);
994
995			if ($reportsize > $report_maxbytes)
996			{
997				# XXX -- generate an error report here
998				print STDERR "$progname: report was too large ($reportsize bytes) per limitation of URI " . $uri->opaque . " for domain $domain\n";
999			}
1000			else
1001			{
1002				$smtpstatus = "sent";
1003				$smtpfail = 0;
1004				if (!$smtp->mail($repemail) ||
1005				    !$smtp->to($repdest) ||
1006				    !$smtp->data() ||
1007				    !$smtp->datasend($mailout) ||
1008				    !$smtp->dataend())
1009				{
1010					$smtpfail = 1;
1011					$smtpstatus = "failed to send";
1012				}
1013
1014				if ($verbose || $smtpfail)
1015				{
1016					# now perl voodoo:
1017					$answer = ${${*$smtp}{'net_cmd_resp'}}[1] || $smtp->message() || 'unknown error';
1018					chomp($answer);
1019					print STDERR "$progname: $smtpstatus report for $domain to $repdest ($answer)\n";
1020				}
1021			}
1022
1023			$smtp->reset();
1024
1025			close($zipin);
1026		}
1027		else
1028		{
1029			print STDERR "$progname: unsupported reporting URI scheme " . $uri->scheme . " for domain $domain\n";
1030			next;
1031		}
1032	}
1033
1034	# update "last sent" timestamp
1035	if ($doupdate)
1036	{
1037		$dbi_s = $dbi_h->prepare("UPDATE requests SET lastsent = FROM_UNIXTIME(?) WHERE domain = ?");
1038		if (!$dbi_s->execute($repend, $domainid))
1039		{
1040			print STDERR "$progname: can't update last sent time for domain $domain: " . $dbi_h->errstr . "\n";
1041			$dbi_s->finish;
1042			$dbi_h->disconnect;
1043			exit(1);
1044		}
1045	}
1046
1047	unlink($zipfile);
1048	if (!$keepfiles)
1049	{
1050		unlink($repfile);
1051	}
1052}
1053
1054$smtp->quit();
1055
1056#
1057# all done!
1058#
1059
1060$dbi_s->finish;
1061
1062if ($verbose)
1063{
1064	print STDERR "$progname: terminating at " . localtime() . "\n";
1065}
1066
1067$dbi_h->disconnect;
1068
1069exit(0);
1070