1
0
Fork 0
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

482 lines
12 KiB

#!/usr/bin/env perl
#=============================================================================
#
# FILE: dmarc-report-display.pl
#
# USAGE: ./dmarc-report-display.pl REPORT
#
# DESCRIPTION: Parse and display a DMARC report
#
# REQUIREMENTS: Perl 5.10; File::LibMagic, Term::ANSIColor; XML::LibXML
# OPTIONAL: Archive::Zip, Email::MIME,
# BUGS: none known
# AUTHOR: nemunaire <nemunaire@nemunai.re>
# CREATED: 05/24/2014 12:23:00 PM
#=============================================================================
use v5.10;
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use Term::ANSIColor;
use Socket;
use XML::LibXML;
use File::LibMagic;
### GLOBALS #############################################################
our $VERSION = 1.5;
### COMMAND-LINE #############################################################
my $HELP = 0;
my $NUMERIC = 0;
my @REPORTS;
my $LIBMAGIC = File::LibMagic->new;
GetOptions(
'help|?' => \$HELP,
'numeric' => \$NUMERIC,
) or pod2usage(2);
pod2usage( -exitval => 0, -verbose => 2 ) if $HELP;
### FUNCTIONS ################################################################
sub format_alignment($) {
my $at = shift;
return colored("strict", "bold", "green") if ($at eq "s");
colored("relaxed", "bold", "magenta")
}
sub format_auth_result($) {
my $ar = shift;
"=> " . colored("DKIM: ", "yellow") .
format_dkim_auth_result( $ar->findnodes("dkim") ) . "\n" .
"=> " . colored("SPF: ", "yellow") .
format_spf_auth_result( $ar->findnodes("spf") );
}
sub format_dkim_auth_result($) {
my @res;
while (my $ar = shift) {
my $domain = @{ $ar->find("domain") }[0]->textContent;
my $result = @{ $ar->find("result") }[0]->textContent;
my $human = "";
$human = " (" . @{ $ar->find("human_result") }[0]->textContent . ")"
if @{ $ar->find("human_result") };
push @res, colored($domain, "magenta") . $human if $result eq "none";
push @res, colored("✓ " . $domain, "green") . $human if $result eq "pass";
push @res, colored("✘ " . $domain, "red") . $human if $result eq "fail";
push @res, $domain . $human if $result eq "policy";
push @res, colored("? " . $domain, "blue") . $human if $result eq "neutral";
push @res, colored("! " . $domain, "yellow") . $human if $result eq "temperror";
push @res, colored("@ " . $domain, "yellow") . $human if $result eq "permerror";
}
join ", ", @res;
}
sub format_spf_auth_result($) {
my @res;
while (my $ar = shift) {
my $domain = @{ $ar->find("domain") }[0]->textContent;
my $result = @{ $ar->find("result") }[0]->textContent;
push @res, colored($domain, "magenta") if $result eq "none";
push @res, colored("? " . $domain, "blue") if $result eq "neutral";
push @res, colored("+ " . $domain, "green") if $result eq "pass";
push @res, colored("- " . $domain, "red") if $result eq "fail";
push @res, colored("~ " . $domain, "red") if $result eq "softfail";
push @res, colored("! " . $domain, "yellow") if $result eq "temperror";
push @res, colored("@ " . $domain, "yellow") if $result eq "permerror";
}
join ", ", @res;
}
sub format_daterange($) {
my $dr = shift;
my $begin = localtime(@{ $dr->find("begin") }[0]->textContent);
my $end = localtime(@{ $dr->find("end") }[0]->textContent);
"from $begin to $end"
}
sub format_disposition($) {
my $dt = shift;
return colored("reject", "red") if ($dt eq "reject");
return colored("quarantine", "bold", "magenta") if ($dt eq "quarantine");
colored("none", "bold", "cyan")
}
sub format_identifier($) {
my $i = shift;
my $env = "";
$env = colored("To: ", "yellow") . colored(@{ $i->find("envelope_to") }[0]->textContent, "bold") . "\n"
if @{ $i->find("envelope_to") };
$env . colored("From: ", "yellow") . colored(@{ $i->find("header_from") }[0]->textContent, "bold")
}
sub format_ipaddress($) {
my $ip = shift;
return $ip if $NUMERIC;
my $pip = inet_aton($ip);
# IPv6
return gethostbyaddr(Socket::inet_pton(AF_INET6, $ip), AF_INET6) // $ip if not $pip;
# IPv4
gethostbyaddr($pip, AF_INET) // $ip;
}
sub format_metadata($) {
my $rp = shift;
colored("Report ID: ", "yellow") .
@{ $rp->find("report_id") }[0]->textContent . "\n" .
colored("Organization: ", "yellow") .
colored(@{ $rp->find("org_name") }[0]->textContent, "bold") .
" (" . @{ $rp->find("email") }[0]->textContent . ")\n" .
colored("Period: ", "yellow") .
format_daterange( @{ $rp->find("date_range") }[0] ) . "\n";
}
sub format_policy($) {
my $pp = shift;
my $sp = "";
$sp = colored("Subdomains policy: ", "yellow") .
format_disposition( @{ $pp->find("sp") }[0]->textContent ) . "\n"
if $pp->find("sp");
colored("Domain: ", "yellow") .
colored(@{ $pp->find("domain") }[0]->textContent, "bold") . "\n" .
colored("DKIM checks: ", "yellow") .
format_alignment( @{ $pp->find("adkim") }[0]->textContent ) . "\n" .
colored("SPF checks: ", "yellow") .
format_alignment( @{ $pp->find("aspf") }[0]->textContent ) . "\n" .
"\n" .
colored("Domain policy: ", "yellow") .
format_disposition( @{ $pp->find("p") }[0]->textContent ) . "\n" .
$sp .
colored("Policy applies on: ", "yellow") .
@{ $pp->find("pct") }[0]->textContent . "%\n" ;
}
sub format_policy_evaluated($) {
my $pe = shift;
my @reasons;
for my $r ($pe->findnodes("reason")) {
push @reasons, format_policy_override_reason($r)
}
my $reason = "";
$reason = "; " . join ", ", @reasons if @reasons;
format_disposition( @{ $pe->find("disposition") }[0]->textContent ) .
" (DKIM: " . format_result_type( @{ $pe->find("dkim") }[0]->textContent ) .
"; SPF: " . format_result_type( @{ $pe->find("spf") }[0]->textContent ) .
$reason . ")"
}
sub format_policy_override($) {
my $po = shift;
return colored("forwarded", "blue", "bold") if ($po eq "forwarded");
return colored("sampled_out", "cyan", "bold") if ($po eq "sampled_out");
return colored("trusted_forwarder", "green", "bold") if ($po eq "trusted_forwarder");
colored($po, "bold")
}
sub format_policy_override_reason($) {
my $por = shift;
my $comment = "";
$comment = ": " .@{ $por->find("comment") }[0]->textContent
if @{ $por->find("comment") } && @{ $por->find("comment") }[0]->textContent;
format_policy_override( @{ $por->find("type") }[0]->textContent ) .
$comment
}
sub format_record($) {
my $r = shift;
format_row( @{ $r->find("row") }[0] ) . "\n" .
format_identifier( @{ $r->find("identifiers") }[0] ) . "\n" .
format_auth_result( @{ $r->find("auth_results") }[0] );
}
sub format_result_type($) {
my $rt = shift;
return colored("✓ pass", "green") if ($rt eq "pass");
colored("✘ fail", "red", "bold")
}
sub format_row($) {
my $r = shift;
@{ $r->find("count") }[0]->textContent . " messages matching from " .
format_ipaddress( @{ $r->find("source_ip") }[0]->textContent ) . ": " .
format_policy_evaluated( @{ $r->find("policy_evaluated") }[0] );
}
sub treat_report($) {
my $dom = shift;
say format_metadata @{ $dom->find("/feedback/report_metadata") }[0];
say format_policy @{ $dom->find("/feedback/policy_published") }[0];
for my $record (@{ $dom->find("/feedback/record") }) {
say format_record $record;
} continue { print "\n" }
}
sub treat_data($);
sub treat_data($) {
my $data = shift;
my $mimetype = $LIBMAGIC->checktype_contents($data);
for ($mimetype) {
if (/gzip/) {
use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
open my $dh, '<', \$data;
my $buffer;
gunzip $dh => \$buffer or die "gunzip failed: $GunzipError\n";
treat_data( $buffer );
} elsif (/zip/) {
require Archive::Zip;
open my $dh, '<', \$data;
my $zip = Archive::Zip->new();
my $errno = $zip->readFromFileHandle($dh);
die "Can't open zip archive (error code $errno)\n" if $errno != 0;
for my $zipped ( $zip->memberNames ) {
treat_data( $zip->contents($zipped) );
}
} elsif (/rfc822/) {
require Email::MIME;
my $email = Email::MIME->new($data);
for my $part ( $email->parts ) {
my $ct = $part->header('Content-Type');
next if $ct =~ m{^text/plain};
treat_data( $part->body );
}
} elsif (/\b xml \b/x || /\b text \b/x) {
treat_report( XML::LibXML->load_xml( string => $data ) );
} else {
warn "Sorry! $mimetype not yet supported!\n";
return;
}
}
}
### MAIN ################################################################
my @reports = map { open my $fh, '<', $_; local $/; <$fh> } @ARGV;
push @reports, do { local $/; <STDIN> } if !@reports;
for my $report (@reports) {
treat_data($report);
} continue { print "#" x 79 . "\n" }
__END__
=head1 NAME
DMARC report display - Parse and display a DMARC report
=head1 SYNOPSIS
./dmarc-report-display.pl [OPTIONS] [REPORT [REPORT ...]]
=head1 OPTIONS
=over
=item B<-help>
Displays the help.
=item B<-numeric>
IP addresses will be printed in numeric format. By default, the program will try
to display them as host names, network names, or services (whenever applicable).
=back
=head1 EXIT STATUS
This script should always return 0.
=head1 DEPENDENCIES
=over
=item
perl >= 5.10
=item
File::LibMagic
=item
Email::MIME v1.910+ (only required for opening mailed reports)
=item
Archive::Zip (only required for opening zipped reports)
=item
Term::ANSIColor v5.001+
=item
XML::LibXML v2.1.400+
=back
=head1 AUTHOR
nemunaire <nemunaire@nemunai.re>
=head1 CHANGELOG
=over
=item v0.2
=over
=item
By default, display reverse DNS instead of raw IP. New option -numeric restore
the original behaviour.
=item
Can treat zipped (-zip option) and emailed (-mail) reports.
=back
=item v0.3
Author: thilp <thilp@thilp.net>
=over
=item
Replaced command-line switches --zip and --mail with mime-type autodetection
(thanks to L<File::LibMagic>).
=item
Can now process arbitrarily nested xml/zip/email formats. Also, it will be
much easier to support other formats.
=item
Replaced L<IO::Uncompress::Unzip> with L<Archive::Zip>.
=back
=item v1.0
=over
=item
Improve report readability.
=back
=item v1.1
=over
=item
Display numeric IP when no reverse exists (bug reported by thilp).
=back
=item v1.2
=over
=item
Optional information about subdomain policy in policy_published (after receiving a report from Yahoo).
=back
=item v1.3
=over
=item
Add GZip reports support (after receiving a report from fastmail.com).
=back
=item v1.4
=over
=item
Consider any text file as report, not only XML ones (after receiving a report from tagmail.eu).
=back
=item v1.5
=over
=item
Revert partially the previous commit to keep allowing application/xml MIME type, that doesn't match 'text'.
=back
=back
=head1 VERSION
This is B<dmarc-report-display.pl> version 1.5.
=head1 LICENSE AND COPYRIGHT
B<The GNU GPLv3 License>
Copyright (C) 2014-2019 nemunaire
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.