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