3 # Copyright (c) 2012-2015, The Trusted Domain Project. All rights reserved.
5 # Script to generate regular DMARC reports.
19 use Net
::Domain
qw(hostfqdn hostdomain);
22 use IO
::Compress
::Zip
qw(zip);
30 require HTTP
::Request
;
33 my $progname = basename
($0);
34 my $version = "1.3.1";
106 my $report_maxbytes_global = 15728640; # default: 15M, per spec
118 my $def_dbhost = "localhost";
119 my $def_dbname = "opendmarc";
120 my $def_dbuser = "opendmarc";
121 my $def_dbpasswd = "opendmarc";
122 my $def_dbport = "3306";
123 my $def_interval = "86400";
130 my $dbscheme = "mysql";
132 my $repdom = hostdomain
();
133 my $repemail = "postmaster@" . $repdom;
135 my $smtp_server = '127.0.0.1';
145 ### NO user-serviceable parts beyond this point
150 print STDERR
"$progname: usage: $progname [options]\n";
151 print STDERR
"\t--day send yesterday's data\n";
152 print STDERR
"\t--dbhost=host database host [$def_dbhost]\n";
153 print STDERR
"\t--dbname=name database name [$def_dbname]\n";
154 print STDERR
"\t--dbpasswd=passwd database password [$def_dbpasswd]\n";
155 print STDERR
"\t--dbport=port database port [$def_dbport]\n";
156 print STDERR
"\t--dbuser=user database user [$def_dbuser]\n";
157 print STDERR
"\t--domain=name force a report for named domain\n";
158 print STDERR
"\t--help print help and exit\n";
159 print STDERR
"\t--interval=secs report interval [$def_interval]\n";
160 print STDERR
"\t--keepfiles keep xml files (in local directory)\n";
161 print STDERR
"\t -n synonym for --test\n";
162 print STDERR
"\t--nodomain=name omit a report for named domain\n";
163 print STDERR
"\t--noupdate don't record report transmission\n";
164 print STDERR
"\t--report-email reporting contact [$repemail]\n";
165 print STDERR
"\t--report-org reporting organization [$repdom]\n";
166 print STDERR
"\t--smtp-port smtp server port [$smtp_port]\n";
167 print STDERR
"\t--smtp-server smtp server [$smtp_server]\n";
168 print STDERR
"\t--smtp-user smtp user (for SASL login)\n";
169 print STDERR
"\t--smtp-passwd smtp password (for SASL login)\n";
170 print STDERR
"\t--smtp-use-tls use TLS for SMTP\n";
171 print STDERR
"\t--test don't send reports\n";
172 print STDERR
"\t--utc operate in UTC\n";
173 print STDERR
"\t (implies --keepfiles --noupdate)\n";
174 print STDERR
"\t--verbose verbose output\n";
175 print STDERR
"\t (repeat for increased output)\n";
176 print STDERR
"\t--version print version and exit\n";
180 setlocale
(LC_ALL
, 'C');
182 # parse command line arguments
183 my $opt_retval = &Getopt
::Long
::GetOptions
('day!' => \
$daybound,
184 'dbhost=s' => \
$dbhost,
185 'dbname=s' => \
$dbname,
186 'dbpasswd=s' => \
$dbpasswd,
187 'dbport=s' => \
$dbport,
188 'dbuser=s' => \
$dbuser,
189 'domain=s' => \
$forcedomain,
190 'help!' => \
$helponly,
191 'interval=i' => \
$interval,
192 'keepfiles' => \
$keepfiles,
193 'n|test' => \
$testmode,
194 'nodomain=s' => \
@skipdomains,
195 'report-email=s' => \
$repemail,
196 'report-org=s' => \
$repdom,
197 'smtp-server=s' => \
$smtp_server,
198 'smtp-port=i' => \
$smtp_port,
199 'smtp-user=s' => \
$smtp_user,
200 'smtp-passwd=s' => \
$smtp_passwd,
201 'smtp-use-tls!' => \
$smtp_usetls,
202 'update!' => \
$doupdate,
204 'verbose+' => \
$verbose,
205 'version!' => \
$showversion,
208 if (!$opt_retval || $helponly)
224 print STDOUT
"$progname v$version\n";
229 if (!defined($dbhost))
231 if (defined($ENV{'OPENDMARC_DBHOST'}))
233 $dbhost = $ENV{'OPENDMARC_DBHOST'};
237 $dbhost = $def_dbhost;
241 if (!defined($dbname))
243 if (defined($ENV{'OPENDMARC_DB'}))
245 $dbname = $ENV{'OPENDMARC_DB'};
249 $dbname = $def_dbname;
253 if (!defined($dbpasswd))
255 if (defined($ENV{'OPENDMARC_PASSWORD'}))
257 $dbpasswd = $ENV{'OPENDMARC_PASSWORD'};
261 $dbpasswd = $def_dbpasswd;
265 if (!defined($dbport))
267 if (defined($ENV{'OPENDMARC_PORT'}))
269 $dbport = $ENV{'OPENDMARC_PORT'};
273 $dbport = $def_dbport;
277 if (!defined($dbuser))
279 if (defined($ENV{'OPENDMARC_USER'}))
281 $dbuser = $ENV{'OPENDMARC_USER'};
285 $dbuser = $def_dbuser;
289 if (!defined($interval))
291 $interval = $def_interval;
294 # Test mode requested, don't update last sent and keep xml files
295 $doupdate = ($testmode == 1) ?
0 : $doupdate;
296 $keepfiles = ($testmode == 1) ?
1 : $keepfiles;
300 print STDERR
"$progname: started at " . localtime() . "\n";
303 my $dbi_dsn = "DBI:" . $dbscheme . ":database=" . $dbname .
304 ";host=" . $dbhost . ";port=" . $dbport;
306 $dbi_h = DBI
->connect($dbi_dsn, $dbuser, $dbpasswd, { PrintError
=> 0 });
307 if (!defined($dbi_h))
309 print STDERR
"$progname: unable to connect to database: $DBI::errstr\n";
315 print STDERR
"$progname: connected to database\n";
320 $dbi_s = $dbi_h->prepare("SET TIME_ZONE='+00:00'");
322 if (!$dbi_s->execute())
324 print STDERR
"$progname: failed to change to UTC: " . $dbi_h->errstr . "\n";
332 # Select domains on which to report
339 print STDERR
"$progname: selecting target domains\n";
342 if (defined($forcedomain))
344 $dbi_s = $dbi_h->prepare("SELECT name FROM domains WHERE name = ?");
346 if (!$dbi_s->execute($forcedomain))
348 print STDERR
"$progname: failed to test for database entry: " . $dbi_h->errstr . "\n";
356 $dbi_s = $dbi_h->prepare("SELECT domains.name FROM requests JOIN domains ON requests.domain = domains.id WHERE DATE(lastsent) < DATE(FROM_UNIXTIME(?))");
358 if (!$dbi_s->execute($now))
360 print STDERR
"$progname: failed to collect domain names: " . $dbi_h->errstr . "\n";
368 $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 if (!$dbi_s->execute($now, $interval))
372 print STDERR
"$progname: failed to collect domain names: " . $dbi_h->errstr . "\n";
379 $domainset = $dbi_s->fetchall_arrayref([0]);
384 print STDERR
"$progname: selected " . scalar(@
$domainset) . " domain(s)\n";
389 # -- extract reporting address
390 # -- extract messages/signatures to report
391 # -- generate and send report
392 # -- update "last sent" timestamp
395 $smtp = Net
::SMTP
->new($smtp_server,
396 'Port' => $smtp_port,
397 'Hello' => hostfqdn
());
401 print STDERR
"$progname: open SMTP server $smtp_server:$smtp_port failed\n";
410 if (defined($smtp_user))
412 if (!$smtp->auth($smtp_user, $smtp_passwd))
414 print STDERR
"$progname: could not login to $smtp_server as user $smtp_user\n";
419 foreach (@
$domainset)
423 if (!defined($domain))
428 if (@skipdomains && grep({$_ eq $domain} @skipdomains) != 0)
435 print STDERR
"$progname: processing $domain\n";
438 # extract this domain's reporting parameters
439 $dbi_s = $dbi_h->prepare("SELECT id FROM domains WHERE name = ?");
440 if (!$dbi_s->execute($domain))
442 print STDERR
"$progname: can't get ID for domain $domain: " . $dbi_h->errstr . "\n";
449 while ($dbi_a = $dbi_s->fetchrow_arrayref())
451 if (defined($dbi_a->[0]))
453 $domainid = $dbi_a->[0];
458 if (!defined($domainid))
460 print STDERR
"$progname: ID for domain $domain not found\n";
464 $dbi_s = $dbi_h->prepare("SELECT repuri, adkim, aspf, policy, spolicy, pct, UNIX_TIMESTAMP(lastsent) FROM requests WHERE domain = ?");
465 if (!$dbi_s->execute($domainid))
467 print STDERR
"$progname: can't get reporting URI for domain $domain: " . $dbi_h->errstr . "\n";
475 while ($dbi_a = $dbi_s->fetchrow_arrayref())
477 if (defined($dbi_a->[0]))
479 $repuri = $dbi_a->[0];
481 if (defined($dbi_a->[1]))
483 $adkim = $dbi_a->[1];
485 if (defined($dbi_a->[2]))
489 if (defined($dbi_a->[3]))
491 $policy = $dbi_a->[3];
493 if (defined($dbi_a->[4]))
495 $spolicy = $dbi_a->[4];
497 if (defined($dbi_a->[5]))
501 if (defined($dbi_a->[6]))
503 $lastsent = $dbi_a->[6];
509 if (!defined($repuri) || ("" eq $repuri))
513 print STDERR
"$progname: no reporting URI for domain $domain; skipping\n";
519 # construct the temporary file
520 $repfile = $repdom . "!" . $domain . "!" . $lastsent . "!" . time() . ".xml";
521 $zipfile = $repdom . "!" . $domain . "!" . $lastsent . "!" . time() . ".zip";
522 if (!open($tmpout, ">", $repfile))
524 print STDERR
"$progname: can't create report file for domain $domain\n";
530 case
ord("r") { $adkimstr = "r"; }
531 case
ord("s") { $adkimstr = "s"; }
532 else { $adkimstr = "unknown"; }
537 case
ord("r") { $aspfstr = "r"; }
538 case
ord("s") { $aspfstr = "s"; }
539 else { $aspfstr = "unknown"; }
544 case
ord("n") { $policystr = "none"; }
545 case
ord("q") { $policystr = "quarantine"; }
546 case
ord("r") { $policystr = "reject"; }
547 else { $policystr = "unknown"; }
552 case
ord("n") { $spolicystr = "none"; }
553 case
ord("q") { $spolicystr = "quarantine"; }
554 case
ord("r") { $spolicystr = "reject"; }
559 $dbi_s = $dbi_h->prepare("SELECT UNIX_TIMESTAMP(MIN(date)), UNIX_TIMESTAMP(MAX(date)) FROM messages WHERE from_domain = ? AND DATE(date) >= DATE(FROM_UNIXTIME(?)) AND DATE(date) < DATE(FROM_UNIXTIME(?))");
563 $dbi_s = $dbi_h->prepare("SELECT UNIX_TIMESTAMP(MIN(date)), UNIX_TIMESTAMP(MAX(date)) FROM messages WHERE from_domain = ? AND UNIX_TIMESTAMP(date) > ? AND UNIX_TIMESTAMP(date) <= ?");
566 if (!$dbi_s->execute($domainid, $lastsent, $now))
568 print STDERR
"$progname: can't extract begin/end times for domain $domain: " . $dbi_h->errstr . "\n";
577 while ($dbi_a = $dbi_s->fetchrow_arrayref())
579 if (defined($dbi_a->[0]))
581 $repstart = $dbi_a->[0];
583 if (defined($dbi_a->[1]))
585 $repend = $dbi_a->[1];
591 print $tmpout "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n";
592 print $tmpout "<feedback>\n";
594 print $tmpout " <report_metadata>\n";
595 print $tmpout " <org_name>$repdom</org_name>\n";
596 print $tmpout " <email>$repemail</email>\n";
597 print $tmpout " <report_id>$domain:$now</report_id>\n";
598 print $tmpout " <date_range>\n";
599 print $tmpout " <begin>$repstart</begin>\n";
600 print $tmpout " <end>$repend</end>\n";
601 print $tmpout " </date_range>\n";
602 print $tmpout " </report_metadata>\n";
604 print $tmpout " <policy_published>\n";
605 print $tmpout " <domain>$domain</domain>\n";
606 print $tmpout " <adkim>$adkimstr</adkim>\n";
607 print $tmpout " <aspf>$aspfstr</aspf>\n";
608 print $tmpout " <p>$policystr</p>\n";
609 if (defined($spolicystr))
611 print $tmpout " <sp>$spolicystr</sp>\n";
613 print $tmpout " <pct>$pct</pct>\n";
614 print $tmpout " </policy_published>\n";
618 $dbi_s = $dbi_h->prepare("SELECT messages.id, ipaddr.addr, messages.disp, d1.name, d2.name, messages.spf, messages.align_spf, messages.align_dkim 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(?))");
622 $dbi_s = $dbi_h->prepare("SELECT messages.id, ipaddr.addr, messages.disp, d1.name, d2.name, messages.spf, messages.align_spf, messages.align_dkim 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(?)");
625 if (!$dbi_s->execute($domainid, $lastsent, $now))
627 print STDERR
"$progname: can't extract report for domain $domain: " . $dbi_h->errstr . "\n";
635 while ($dbi_a = $dbi_s->fetchrow_arrayref())
639 if (defined($dbi_a->[0]))
641 $msgid = $dbi_a->[0];
643 if (defined($dbi_a->[1]))
645 $ipaddr = $dbi_a->[1];
647 if (defined($dbi_a->[2]))
651 if (defined($dbi_a->[3]))
653 $fromdomain = $dbi_a->[3];
655 if (defined($dbi_a->[4]))
657 $envdomain = $dbi_a->[4];
659 if (defined($dbi_a->[5]))
661 $spfresult = $dbi_a->[5];
663 if (defined($dbi_a->[6]))
665 $align_spf = $dbi_a->[6];
667 if (defined($dbi_a->[7]))
669 $align_dkim = $dbi_a->[7];
672 if (!defined($msgid))
681 case
0 { $dispstr = "reject"; }
682 case
1 { $dispstr = "reject"; }
683 case
2 { $dispstr = "none"; }
684 case
4 { $dispstr = "quarantine"; }
685 else { $dispstr = "unknown"; }
690 case
0 { $spfresultstr = "pass"; }
691 case
2 { $spfresultstr = "softfail"; }
692 case
3 { $spfresultstr = "neutral"; }
693 case
4 { $spfresultstr = "temperror"; }
694 case
5 { $spfresultstr = "permerror"; }
695 case
6 { $spfresultstr = "none"; }
696 case
7 { $spfresultstr = "fail"; }
697 case
8 { $spfresultstr = "policy"; }
698 case
9 { $spfresultstr = "nxdomain"; }
699 case
10 { $spfresultstr = "signed"; }
700 case
12 { $spfresultstr = "discard"; }
701 else { $spfresultstr = "unknown"; }
706 case
4 { $align_dkimstr = "pass"; }
707 case
5 { $align_dkimstr = "fail"; }
708 else { $align_dkimstr = "unknown"; }
713 case
4 { $align_spfstr = "pass"; }
714 case
5 { $align_spfstr = "fail"; }
715 else { $align_spfstr = "unknown"; }
718 print $tmpout " <record>\n";
719 print $tmpout " <row>\n";
720 print $tmpout " <source_ip>$ipaddr</source_ip>\n";
721 print $tmpout " <count>1</count>\n";
722 print $tmpout " <policy_evaluated>\n";
723 print $tmpout " <disposition>$dispstr</disposition>\n";
724 print $tmpout " <dkim>$align_dkimstr</dkim>\n";
725 print $tmpout " <spf>$align_spfstr</spf>\n";
726 print $tmpout " </policy_evaluated>\n";
727 print $tmpout " </row>\n";
728 print $tmpout " <identifiers>\n";
729 print $tmpout " <header_from>$fromdomain</header_from>\n";
730 print $tmpout " </identifiers>\n";
731 print $tmpout " <auth_results>\n";
732 print $tmpout " <spf>\n";
733 print $tmpout " <domain>$envdomain</domain>\n";
734 print $tmpout " <result>$spfresultstr</result>\n";
735 print $tmpout " </spf>\n";
737 $dbi_d = $dbi_h->prepare("SELECT domains.name, pass FROM signatures JOIN domains ON signatures.domain = domains.id WHERE signatures.message = ?");
738 if (!$dbi_d->execute($msgid))
740 print STDERR
"$progname: can't extract report for message $msgid: " . $dbi_h->errstr . "\n";
747 while ($dbi_a = $dbi_d->fetchrow_arrayref())
751 if (defined($dbi_a->[0]))
753 $dkimdomain = $dbi_a->[0];
755 if (defined($dbi_a->[1]))
757 $dkimresult = $dbi_a->[1];
761 if (!defined($dkimdomain))
768 case
0 { $dkimresultstr = "pass"; }
769 case
2 { $dkimresultstr = "softfail"; }
770 case
3 { $dkimresultstr = "neutral"; }
771 case
4 { $dkimresultstr = "temperror"; }
772 case
5 { $dkimresultstr = "permerror"; }
773 case
6 { $dkimresultstr = "none"; }
774 case
7 { $dkimresultstr = "fail"; }
775 case
8 { $dkimresultstr = "policy"; }
776 case
9 { $dkimresultstr = "nxdomain"; }
777 case
10 { $dkimresultstr = "signed"; }
778 case
12 { $dkimresultstr = "discard"; }
779 else { $dkimresultstr = "unknown"; }
782 print $tmpout " <dkim>\n";
783 print $tmpout " <domain>$dkimdomain</domain>\n";
784 print $tmpout " <result>$dkimresultstr</result>\n";
785 print $tmpout " </dkim>\n";
790 print $tmpout " </auth_results>\n";
791 print $tmpout " </record>\n";
796 print $tmpout "</feedback>\n";
804 print STDERR
"$progname: no activity selected for $domain; skipping\n";
812 if (!zip
[ $repfile ] => $zipfile)
814 print STDERR
"$progname: can't zip report for domain $domain: $!\n";
820 print STDERR
"$progname: keeping report file \"$repfile\"\n";
824 @repuris = split(',', $repuri);
826 for $repuri (@repuris)
828 $uri = URI
->new($repuri);
829 if (!defined($uri) ||
830 !defined($uri->scheme) ||
833 print STDERR
"$progname: can't parse reporting URI for domain $domain\n";
839 $repdest = $uri->opaque;
840 my $report_maxbytes = $report_maxbytes_global;
842 # check for max report size
843 if ($repdest =~ m/^(\S+)!(\d{1,15})([kmgt])?$/i)
846 $report_maxbytes = $2;
852 $report_maxbytes = $report_maxbytes * 1024;
856 $report_maxbytes = $report_maxbytes * 1048576;
860 $report_maxbytes = $report_maxbytes * (2**30);
864 $report_maxbytes = $report_maxbytes * (2**40);
869 # Test mode, just report what would have been done
872 print STDERR
"$progname: would email $domain report for " .
873 "$rowcount records to " . $uri->opaque . "\n";
875 # ensure a scheme is present
876 elsif (!defined($uri->scheme))
880 print STDERR
"$progname: unknown URI scheme in '$repuri' for domain $domain\n";
888 elsif ($uri->scheme eq "mailto")
893 if (!open($zipin, $zipfile))
895 print STDERR
"$progname: can't read zipped report for $domain: $!\n";
901 $boundary = "report_section";
903 $report_id = $domain . "-" . $now . "@" . $repdom;
904 $datestr = strftime
("%a, %e %b %Y %H:%M:%S %z (%Z)",
907 $mailout = "To: $repdest\n";
908 $mailout .= "From: $repemail\n";
909 $mailout .= "Subject: Report Domain: " . $domain . " Submitter: " . $repdom . " Report-ID: " . $report_id . "\n";
910 $mailout .= "X-Mailer: " . $progname . " v" . $version ."\n";
911 $mailout .= "Date: " . $datestr . "\n";
912 $mailout .= "Message-ID: <$report_id>\n";
913 $mailout .= "Auto-Submitted: auto-generated\n";
914 $mailout .= "MIME-Version: 1.0\n";
915 $mailout .= "Content-Type: multipart/mixed; boundary=\"$boundary\"\n";
917 $mailout .= "This is a MIME-encapsulated message.\n";
919 $mailout .= "--$boundary\n";
920 $mailout .= "Content-Type: text/plain;\n";
922 $mailout .= "This is a DMARC aggregate report for $domain\n";
923 $mailout .= "generated at " . localtime() . "\n";
925 $mailout .= "--$boundary\n";
926 $mailout .= "Content-Type: application/zip\n";
927 $mailout .= "Content-Disposition: attachment; filename=\"$zipfile\"\n";
928 $mailout .= "Content-Transfer-Encoding: base64\n";
931 while (read($zipin, $buf, 60*57))
933 $mailout .= encode_base64
($buf);
937 $mailout .= "--$boundary--\n";
938 my $reportsize = length($mailout);
940 if ($reportsize > $report_maxbytes)
942 # XXX -- generate an error report here
943 print STDERR
"$progname: report was too large ($reportsize bytes) per limitation of URI " . $uri->opaque . " for domain $domain\n";
947 $smtpstatus = "sent";
949 if (!$smtp->mail($repemail) ||
950 !$smtp->to($repdest) ||
952 !$smtp->datasend($mailout) ||
956 $smtpstatus = "failed to send";
959 if ($verbose || $smtpfail)
962 $answer = ${${*$smtp}{'net_cmd_resp'}}[1];
963 $answer = $smtp->message() if (!defined($answer));
965 print STDERR
"$progname: $smtpstatus report for $domain to $repdest ($answer)\n";
975 print STDERR
"$progname: unsupported reporting URI scheme " . $uri->scheme . " for domain $domain\n";
982 # update "last sent" timestamp
985 $dbi_s = $dbi_h->prepare("UPDATE requests SET lastsent = FROM_UNIXTIME(?) WHERE domain = ?");
986 if (!$dbi_s->execute($now, $domainid))
988 print STDERR
"$progname: can't update last sent time for domain $domain: " . $dbi_h->errstr . "\n";
1012 print STDERR
"$progname: terminating at " . localtime() . "\n";