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
#
#      OPTIONS: TODO
# REQUIREMENTS: Perl 5.10; Term::ANSIColor; XML::LibXML
#         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 qw(:constants);
use Socket;
use XML::LibXML;
use File::LibMagic;

### GLOBALS #############################################################

our $VERSION = 0.3;

### 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 ################################################################

use Data::Dumper;

sub format_alignment($) {
    my $at = shift;

    return BOLD . GREEN . "strict" . RESET if ($at eq "s");
    BOLD . MAGENTA . "relaxed" . RESET
}

sub format_auth_result($) {
    my $ar = shift;

    "=> " . YELLOW . "DKIM: " .
        format_dkim_auth_result( $ar->findnodes("dkim") ) . "\n" .
    "=> " . YELLOW . "SPF: " .
        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, MAGENTA . $domain . RESET . $human if $result eq "none";
        push @res, GREEN . "✓ " . $domain . RESET . $human if $result eq "pass";
        push @res, RED . "✘ " . $domain . RESET . $human if $result eq "fail";
        push @res, $domain . $human if $result eq "policy";
        push @res, BLUE . "? " . $domain . RESET . $human if $result eq "neutral";
        push @res, YELLOW . "! " . $domain . RESET . $human if $result eq "temperror";
        push @res, YELLOW . "@ " . $domain . RESET . $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, MAGENTA . $domain . RESET if $result eq "none";
        push @res, BLUE . "? " . $domain . RESET if $result eq "neutral";
        push @res, GREEN . "+ " . $domain . RESET if $result eq "pass";
        push @res, RED . "- " . $domain . RESET if $result eq "fail";
        push @res, RED . "~ " . $domain . RESET if $result eq "softfail";
        push @res, YELLOW . "! " . $domain . RESET if $result eq "temperror";
        push @res, YELLOW . "@ " . $domain . RESET 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 GREEN . "reject" . RESET if ($dt eq "reject");
    return BOLD . CYAN . "quarantine" . RESET if ($dt eq "quarantine");
    BOLD . MAGENTA . "none" . RESET
}

sub format_identifier($) {
    my $i = shift;

    my $env = "";
    $env = YELLOW . "To: " . RESET . BOLD . @{ $i->find("envelope_to") }[0]->textContent . RESET . "\n"
        if @{ $i->find("envelope_to") };

    $env . YELLOW . "From: " . RESET . BOLD . @{ $i->find("header_from") }[0]->textContent . RESET
}

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) if not $pip;

    # IPv4
    gethostbyaddr($pip, AF_INET);
}

sub format_metadata($) {
    my $rp = shift;

    YELLOW . "Report ID: " . RESET .
        @{ $rp->find("report_id") }[0]->textContent . "\n" .
    YELLOW . "Organization: " . RESET .
        BOLD . @{ $rp->find("org_name") }[0]->textContent .
        RESET . " (" . @{ $rp->find("email") }[0]->textContent . ")\n" .
    YELLOW . "Period: " . RESET .
        format_daterange( @{ $rp->find("date_range") }[0] ) . "\n";
}

sub format_policy($) {
    my $pp = shift;

    YELLOW . "Domain: " . RESET .
        BOLD . @{ $pp->find("domain") }[0]->textContent . RESET . "\n" .
    YELLOW . "DKIM checks: " . RESET .
        format_alignment( @{ $pp->find("adkim") }[0]->textContent ) . "\n" .
    YELLOW . "SPF checks: " . RESET .
        format_alignment( @{ $pp->find("aspf") }[0]->textContent ) . "\n" .
    "\n" .
    YELLOW . "Domain policy: " . RESET .
        format_disposition( @{ $pp->find("p") }[0]->textContent ) . "\n" .
    YELLOW . "Subdomains policy: " . RESET .
        format_disposition( @{ $pp->find("sp") }[0]->textContent ) . "\n" .
    YELLOW . "Policy applies on: " . RESET .
        @{ $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 BOLD . BLUE . "forwarded" . RESET if ($po eq "forwarded");
    return BOLD . CYAN . "sampled_out" . RESET if ($po eq "sampled_out");
    return BOLD . GREEN . "trusted_forwarder" . RESET if ($po eq "trusted_forwarder");
    BOLD . $po . RESET
}

sub format_policy_override_reason($) {
    my $por = shift;

    my $comment = "";
    $comment = ": " .@{ $por->find("comment") }[0]->textContent
        if @{ $por->find("comment") };

    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 GREEN . "✓ pass" . RESET if ($rt eq "pass");
    BOLD . RED . "✘ fail" . RESET
}

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;
    }
}

sub treat_data($);
sub treat_data($) {
    my $data     = shift;
    my $mimetype = $LIBMAGIC->checktype_contents($data);
    for ($mimetype) {
        if (/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) {
            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.xml [REPORT.xml ...]]

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

=back

=head1 VERSION

This is B<dmarc-report-display.pl> version 0.3.

=head1 LICENSE AND COPYRIGHT

B<The GNU GPLv3 License>

Copyright (C) 2014  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/>.