#!perl

# nagios: -epn

package main;

# check_rbl is a Nagios plugin to check if an SMTP server is black- or
# white- listed
#
# See  the INSTALL file for installation instructions
#
# Copyright (c) 2014, Matteo Corti <matteo@corti.li>
# Copyright (c) 2007, ETH Zurich.
# Copyright (c) 2010, Elan Ruusamae <glen@delfi.ee>.
#
# This module is free software; you can redistribute it and/or modify it
# under the terms of GNU general public license (gpl) version 3.
# See the LICENSE file for details.

use strict;
use warnings;

use 5.00800;

our $VERSION = '1.3.8';

use Data::Validate::Domain qw(is_hostname);
use Data::Validate::IP qw(is_ipv4 is_ipv6);
use IO::Select;
use Net::DNS;
use Readonly;
use English qw(-no_match_vars);
use Data::Dumper;

my $plugin_module = load_module( 'Monitoring::Plugin', 'Nagios::Plugin' );
my $plugin_threshold_module =
  load_module( 'Monitoring::Plugin::Threshold', 'Nagios::Plugin::Threshold' );
my $plugin_getopt_module =
  load_module( 'Monitoring::Plugin::Getopt', 'Nagios::Plugin::Getopt' );

# Check which version of the monitoring plugins is available

sub load_module {

    my @names = @_;
    my $loaded_module;

    for my $name (@names) {

        my $file = $name;

        # requires need either a bare word or a file name
        $file =~ s{::}{/}gsxm;
        $file .= '.pm';

        eval {    ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
            require $file;
            $name->import();
        };
        if ( !$EVAL_ERROR ) {
            $loaded_module = $name;
            last;
        }
    }

    if ( !$loaded_module ) {
        #<<<
        print 'CHECK_RBL: plugin not found: ' . join( ', ', @names ) . "\n";  ## no critic (RequireCheckedSyscall)
        #>>>

        exit 2;
    }

    return $loaded_module;

}

Readonly our $DEFAULT_TIMEOUT       => 15;
Readonly our $DEFAULT_RETRIES       => 4;
Readonly our $DEFAULT_WORKERS       => 20;
Readonly our $DEFAULT_QUERY_TIMEOUT => 15;

# IMPORTANT: Nagios plugins could be executed using embedded perl in this case
#            the main routine would be executed as a subroutine and all the
#            declared subroutines would therefore be inner subroutines
#            This will cause all the global lexical variables not to stay shared
#            in the subroutines!
#
# All variables are therefore declared as package variables...
#

## no critic (ProhibitPackageVars)
our ( @listed, @timeouts, $options, $plugin, $threshold, $timeouts_string, );

##############################################################################
# Usage     : debug("some message string")
# Purpose   : write a message if the debugging option was specified
# Returns   : n/a
# Arguments : message : message string
# Throws    : n/a
# Comments  : n/a
# See also  : n/a
sub debug {

    # arguments
    my $message = shift;

    if ( !defined $message ) {
        $plugin->nagios_exit( $plugin_module->UNKNOWN,
            q{Internal error: not enough parameters for 'debug'} );
    }

    if ( $options && $options->debug() ) {
        ## no critic (RequireCheckedSyscall)
        print "[DBG] $message\n";
    }

    return;

}

##############################################################################
# Usage     : verbose("some message string", $optional_verbosity_level);
# Purpose   : write a message if the verbosity level is high enough
# Returns   : n/a
# Arguments : message : message string
#             level   : options verbosity level
# Throws    : n/a
# Comments  : n/a
# See also  : n/a
sub verbose {

    # arguments
    my $message = shift;
    my $level   = shift;

    if ( !defined $message ) {
        $plugin->nagios_exit( $plugin_module->UNKNOWN,
            q{Internal error: not enough parameters for 'verbose'} );
    }

    if ( !defined $level ) {
        $level = 0;
    }

    if ( $level < $options->verbose ) {
        if ( !print $message ) {
            $plugin->nagios_exit( $plugin_module->UNKNOWN,
                'Error: cannot write to STDOUT' );
        }
    }

    return;

}

# the script is declared as a package so that it can be unit tested
# but it should not be used as a module
if ( !caller ) {
    run();
}

##############################################################################
# Usage     : my $res = init_dns_resolver( $retries )
# Purpose   : Initializes a new DNS resolver
# Arguments : retries : number of retries
# Returns   : The newly created resolver
# See also  : Perl Net::DNS
sub init_dns_resolver {

    my $retries = shift;

    my $res = Net::DNS::Resolver->new();
    if ( $res->can('force_v4') ) {
        $res->force_v4(1);
    }

    if ($retries) {
        $res->retry($retries);
    }

    return $res;
}

##############################################################################
# Usage     : mdns(\@addresses, $callback)
# Purpose   : Perform multiple DNS lookups in parallel
# Returns   : n/a
# See also  : Perl Net::DNS module mresolv in examples
#
# Resolves all IPs in C<@addresses> in parallel.
# If answer is found C<$callback> is called with arguments as: $name, $host.
#
# Author: Elan Ruusamae <glen@delfi.ee>, (c) 1999-2010
sub mdns {

    my ( $data, $callback ) = @_;

    # number of requests to have outstanding at any time
    my $workers = $options ? $options->workers() : 1;

    # timeout per query (seconds)
    my $timeout = $options ? $options->get('query-timeout') : $DEFAULT_TIMEOUT;
    my $res = init_dns_resolver( $options ? $options->retry() : 0 );

    my $sel = IO::Select->new();
    my $eof = 0;

    my @addrs = @{$data};

    my %addrs;
    while (1) {

        #----------------------------------------------------------------------
        # Read names until we've filled our quota of outstanding requests.
        #----------------------------------------------------------------------

        while ( !$eof && $sel->count() < $workers ) {

            my $name = shift @addrs;

            if ( !defined $name ) {
                debug('reading...EOF.');
                $eof = 1;
                last;
            }

            debug("reading...$name");

            my $sock = $res->bgsend($name);

            if ( !defined $sock ) {
                verbose 'DNS query error: ' . $res->errorstring;
                verbose "Skipping $name";
            }
            else {

                # we store in a hash the query we made, as parsing it back from
                # response gives different ip for ips with multiple hosts
                $addrs{$sock} = $name;
                $sel->add($sock);
                debug( "name = $name, outstanding = " . $sel->count() );

            }

        }

        #----------------------------------------------------------------------
        # Wait for any replies.  Remove any replies from the outstanding pool.
        #----------------------------------------------------------------------

        my @ready;
        my $timed_out = 1;

        debug('waiting for replies');

        @ready = $sel->can_read($timeout);

        while (@ready) {

            $timed_out = 0;

            debug( 'replies received: ' . scalar @ready );

            foreach my $sock (@ready) {

                debug('handling a reply');

                my $addr = $addrs{$sock};
                delete $addrs{$sock};
                $sel->remove($sock);

                my $ans = $res->bgread($sock);

                debug Dumper $ans;

                my $host;

                if ($ans) {

                    foreach my $rr ( $ans->answer ) {

                        debug('Processing answer');

                        ## no critic(ProhibitDeepNests)
                        if ( !( $rr->type eq 'A' ) ) {
                            next;
                        }

                        $host = $rr->address;

                        debug("host = $host");

                        # take just the first answer
                        last;
                    }
                }
                else {

                    debug( 'no answer: ' . $res->errorstring() );

                }

                if ( defined $host ) {

                    debug("callback( $addr, $host )");

                }
                else {

                    debug("callback( $addr, <undefined> )");

                }

                &{$callback}( $addr, $host );
            }

            @ready = $sel->can_read(0);

        }

        #----------------------------------------------------------------------
        # If we timed out waiting for replies, remove all entries from the
        # outstanding pool.
        #----------------------------------------------------------------------

        if ($timed_out) {

            debug('timeout: clearing the outstanding pool.');

            foreach my $sock ( $sel->handles() ) {
                my $addr = $addrs{$sock};
                delete $addrs{$sock};
                $sel->remove($sock);

                # callback for hosts that timed out
                &{$callback}( $addr, q{} );
            }
        }

        debug( 'outstanding = ' . $sel->count() . ", eof = $eof" );

        #----------------------------------------------------------------------
        # We're done if there are no outstanding queries and we've read EOF.
        #----------------------------------------------------------------------

        last if ( $sel->count() == 0 ) && $eof;
    }

    return;

}

##############################################################################
# Usage     : validate( $hostname );
# Purpose   : check if an IP address or host name is valid
# Returns   : the IP address corresponding to $hostname
# Arguments : n/a
# Throws    : an UNKNOWN error if the argument is not valid
# Comments  : n/a
# See also  : n/a
sub validate {

    my $hostname = shift;
    my $ip       = $hostname;

    debug("validate($hostname, $ip)");

    if ( !is_ipv4($hostname) && !is_ipv6($hostname) ) {

        if ( is_hostname($hostname) ) {

            mdns(
                [$hostname],
                sub {
                    my ( $addr, $host ) = @_;
                    $ip = $host;
                }
            );

            if ( !$ip ) {
                $plugin->nagios_exit( $plugin_module->UNKNOWN,
                    'Cannot resolve ' . $hostname );
            }

        }

        if ( !$ip ) {
            $plugin->nagios_exit( $plugin_module->UNKNOWN,
                'Cannot resolve ' . $options->host );
        }

    }

    return $ip;

}

##############################################################################
# Usage     : run();
# Purpose   : main method
# Returns   : n/a
# Arguments : n/a
# Throws    : n/a
# Comments  : n/a
# See also  : n/a
sub run {

    ################################################################################
    # Initialization

    $plugin = $plugin_module->new( shortname => 'CHECK_RBL' );

    my $time = time;

    ########################
    # Command line arguments

    $options = $plugin_getopt_module->new(
        usage   => 'Usage: %s [OPTIONS]',
        version => $VERSION,
        url     => 'http://matteocorti.github.io/check_rbl/',
        blurb   => 'Check SMTP black- or white- listing status',
    );

    $options->arg(
        spec     => 'critical|c=i',
        help     => 'Number of blacklisting servers for a critical warning',
        required => 0,
        default  => 1,
    );

    $options->arg(
        spec     => 'warning|w=i',
        help     => 'Number of blacklisting servers for a warning',
        required => 0,
        default  => 1,
    );

    $options->arg(
        spec     => 'debug|d',
        help     => 'Prints debugging information',
        required => 0,
        default  => 0,
    );

    $options->arg(
        spec     => 'server|s=s@',
        help     => 'RBL server',
        required => 1,
    );

    $options->arg(
        spec     => 'host|H=s',
        help     => 'SMTP server to check',
        required => 1,
    );

    $options->arg(
        spec     => 'retry|r=i',
        help     => 'Number of times to try a DNS query (default is 4) ',
        required => 0,
        default  => $DEFAULT_RETRIES,
    );

    $options->arg(
        spec     => 'workers=i',
        help     => 'Number of parallel checks',
        required => 0,
        default  => $DEFAULT_WORKERS,
    );

    $options->arg(
        spec     => 'whitelistings|wl',
        help     => 'Check whitelistings instead of blacklistings',
        required => 0,
        default  => 0,
    );

    $options->arg(
        spec     => 'query-timeout=i',
        help     => 'Timeout of the RBL queries',
        required => 0,
        default  => $DEFAULT_QUERY_TIMEOUT,
    );

    $options->getopts();

    ###############
    # Sanity checks

    if ( $options->critical < $options->warning ) {
        $plugin->nagios_exit( $plugin_module->UNKNOWN,
            'critical has to be greater or equal warning' );
    }

    my $ip = validate( $options->host );

    my @servers = @{ $options->server };

    verbose 'Using ' . $options->timeout . " as global script timeout\n";
    alarm $options->timeout;

    ################
    # Set the limits

    # see https://nagios-plugins.org/doc/guidelines.html#THRESHOLDFORMAT
    $threshold = $plugin_threshold_module->set_thresholds(
        warning  => $options->warning - 1,
        critical => $options->critical - 1,
    );

    ################################################################################

    my $nservers = scalar @servers;

    verbose 'Checking ' . $options->host . " ($ip) on $nservers server(s)\n";

    # build address lists
    my @addrs;
    foreach my $server (@servers) {
        ( my $local_ip = $ip ) =~
s/(\d{1,3}) [.] (\d{1,3}) [.] (\d{1,3}) [.] (\d{1,3})/$4.$3.$2.$1.$server/mxs;
        push @addrs, $local_ip;
    }

    mdns(
        \@addrs,
        sub {
            my ( $addr, $host ) = @_;

            if ( defined $host ) {

                debug("callback( $addr, $host )");

            }
            else {

                debug("callback( $addr, <undefined> )");

            }

            # extract RBL we checked
            $addr =~ s/^(?:\d+[.]){4}//mxs;
            if ( defined $host ) {
                if ( $host eq q{} ) {
                    push @timeouts, $addr;
                }
                else {
                    verbose "listed in $addr as $host\n";
                    if ( !$options->get('whitelistings') ) {
                        push @listed, $addr;
                    }
                }
            }
            else {
                verbose "not listed in $addr\n";
                if ( $options->get('whitelistings') ) {
                    push @listed, $addr;
                }
            }
        }
    );

    my $total = scalar @listed;

    my $status;
    if ( $options->get('whitelistings') ) {

        $status =
            $options->host
          . " NOT WHITELISTED on $total "
          . ( ( $total == 1 ) ? 'server' : 'servers' )
          . " of $nservers";
    }
    else {
        $status =
            $options->host
          . " BLACKLISTED on $total "
          . ( ( $total == 1 ) ? 'server' : 'servers' )
          . " of $nservers";

    }

    # append timeout info, but do not account these in status
    if (@timeouts) {
        $timeouts_string = scalar @timeouts;
        $status =
            " ($timeouts_string server"
          . ( ( $timeouts_string > 1 ) ? 's' : q{} )
          . ' timed out: '
          . join( ', ', @timeouts ) . ')';
    }

    if ( $total > 0 ) {
        $status .= " (@listed)";
    }

    $plugin->add_perfdata(
        label     => 'servers',
        value     => $total,
        uom       => q{},
        threshold => $threshold,
    );

    $plugin->add_perfdata(
        label => 'time',
        value => time - $time,
        uom   => q{s},
    );

    $plugin->nagios_exit( $threshold->get_status($total), $status );

    return;

}

1;