Parse and display DMARC reports for human review.

dmarc-report-display.pl

#!/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 <[email protected]>
#      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 <[email protected]>

=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 <[email protected]>

=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/>.

I'm not familiar with perl at all, but I found that I had to run sudo cpan File::LibMagic to get this to work. Posting here for future readers.

Hi @iSWORD! I just updated the file header to include File::LibMagic which was missing, along with optional dependencies. All of them was correctly describe, but only in the perldoc section.
I hope the script respond to your needs!

Your script helped me a lot. Thank you so much.