#!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) 2009-2023 Matteo Corti <matteo@corti.li>
# Copyright (c) 2009 ETH Zurich.
# Copyright (c) 2010 Elan Ruusamae <glen@delfi.ee>.
# Copyright (c) 2022 Claudio Kuenzler <ck@claudiokuenzler.com>.
#
# 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;

our $VERSION = '1.7.5';

use Capture::Tiny qw(capture);
use Data::Validate::Domain qw(is_hostname);
use Data::Validate::IP qw(is_ipv4 is_ipv6);
use IO::Select;
use Net::DNS;
use Net::IP qw(ip_expand_address);
use Readonly;
use English qw(-no_match_vars);
use Socket qw( NI_NUMERICSERV SOCK_RAW getaddrinfo getnameinfo);

use Monitoring::Plugin;
use Monitoring::Plugin::Threshold;
use Monitoring::Plugin::Getopt;

Readonly our $DEFAULT_TIMEOUT       => 15;
Readonly our $DEFAULT_RETRIES       => 4;
Readonly our $DEFAULT_WORKERS       => 20;
Readonly our $DEFAULT_QUERY_TIMEOUT => 15;
Readonly our $DEFAULT_APPEND_STRING => q{};

# 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( Monitoring::Plugin->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( Monitoring::Plugin->UNKNOWN,
            q{Internal error: not enough parameters for 'verbose'} );
    }

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

    if ( $level < $options->verbose ) {
        if ( !print $message ) {
            $plugin->nagios_exit( Monitoring::Plugin->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 $resolver = Net::DNS::Resolver->new();
    if ( $resolver->can('force_v4') ) {
        $resolver->force_v4(1);
    }

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

    if ( defined $options->nameserver ) {

# If the nameserver is invalid Net::DNS::Resolver prints an error message on STDERR: we want to suppress it
# see: https://stackoverflow.com/questions/73270724/how-to-handle-errors-while-setting-the-name-server-with-netdns

        my ( $stdout, $stderr, @servers ) =
          capture { $resolver->nameservers( $options->nameserver ); };

        if ( @servers == 0 ) {
            debug("DNS nameserver error: $stderr");
            $plugin->nagios_exit( Monitoring::Plugin->CRITICAL,
                'Invalid nameserver ' . $options->nameserver );
        }

    }

    my @nameservers = $resolver->nameservers();
    debug("Using DNS Resolver: @nameservers");

    return $resolver;
}

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

## no critic (ProhibitExcessComplexity)
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;
            }

            # TODO
            # get the authoritative name server
            # to be implemented

            if ( defined $options && defined $options->get('authoritative') ) {

                # we initialize a default query to get the authoritative nameserver

                printf "-A not yet implemented\n";

            }

            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 $answer = $res->bgread($sock);

                my $host;

                if ($answer) {

                    foreach my $rr ( $answer->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(
                    Monitoring::Plugin->UNKNOWN,
                    'Cannot resolve ' . $hostname
                );
            }

        }

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

    }

    if ( is_ipv6($ip) ) {
        ## no critic (ProhibitMagicNumbers)
        $ip = Net::IP::ip_expand_address( $ip, 6 );
    }

    return $ip;

}

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

## no critic (ProhibitExcessComplexity)
sub run {

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

    $plugin = Monitoring::Plugin->new( shortname => 'CHECK_RBL' );

    my $time = time;

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

    $options = Monitoring::Plugin::Getopt->new(
        usage   => 'Usage: %s [OPTIONS]',
        version => $VERSION,
        url     => 'https://github.com/matteocorti/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 (may be repeated)',
        required => 1,
    );

    $options->arg(
        spec => 'host|H=s',
        help =>
'SMTP server to check. If hostname is given, it will be resolved to its IP first.',
        required => 0,
    );

    $options->arg(
        spec     => 'url|U=s',
        help     => 'URL to check. Will be ignored if host is set.',
        required => 0,
    );

    $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->arg(
        spec     => 'append|a=s',
        help     => 'Append string at the end of the plugin output',
        required => 0,
        default  => $DEFAULT_APPEND_STRING,
    );

    $options->arg(
        spec => 'nameserver|n=s',
        help =>
'Use this nameserver IP as DNS resolver (only one server is supported)',
        required => 0,
    );

    $options->arg(
        spec     => 'authoritative|A',
        help     => 'Always use the corresponding authoritative name server',
        required => 0,
    );

    $options->getopts();

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

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

    if (   ( !defined $options->host || $options->host eq q{} )
        && ( !defined $options->url || $options->url eq q{} ) )
    {
        $plugin->nagios_exit( Monitoring::Plugin->UNKNOWN,
            'host or url has to be set' );
    }

    if (   defined $options
        && defined $options->authoritative
        && defined $options->nameserver )
    {
        $plugin->nagios_exit( Monitoring::Plugin->UNKNOWN,
'--or authoritative and --nameserver cannot be specified at the same time'
        );
    }

# if present remove the trailing dot from the FQDN
# see https://serverfault.com/questions/803033/should-i-append-a-dot-at-the-end-of-my-dns-urls
    my $host = $options->host;
    if ( defined $host ) {
        $host =~ s/[.]$//mxs;
    }

    my $check_prefix;
    my $check_object;
    if ( defined $options->host and $options->host ne q{} ) {

        # if checking for host
        # validate ip and resolve hostname if applicable
        my $ip = validate($host);

        # reverse ip order
        my $local_ip = $ip;

        if ( is_ipv6($local_ip) ) {

            debug("$local_ip is an IPv6 address");

            $local_ip = reverse $local_ip;
            $local_ip =~ s/://gmxs;

            $local_ip = join q{.}, split //ms, $local_ip;

            debug("    $local_ip");

        }
        else {
            $local_ip =~
s/(\d{1,3}) [.] (\d{1,3}) [.] (\d{1,3}) [.] (\d{1,3})/$4.$3.$2.$1/mxs;
        }

        $check_prefix = $local_ip;
        $check_object = $host;
    }
    else {
        # if checking for url, just set the prefix to the url name
        $check_prefix = $options->url;
        $check_object = $options->url;
    }

    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 = Monitoring::Plugin::Threshold->set_thresholds(
        warning  => $options->warning - 1,
        critical => $options->critical - 1,
    );

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

    my $nservers = scalar @servers;

    verbose 'Checking ' . $check_prefix . " on $nservers server(s)\n";

    # build address lists
    my @addrs;
    foreach my $server (@servers) {
        my $local_ip = $check_prefix . q{.} . $server;
        push @addrs, $local_ip;
    }

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

            if ( defined $mdns_host ) {

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

            }
            else {

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

            }

            # extract RBL we checked
            $addr =~ s/^(?:[a-f\d][.]){32}//mxs;
            $addr =~ s/^(?:\d+[.]){4}//mxs;

            if ( defined $mdns_host ) {
                if ( $mdns_host eq q{} ) {
                    push @timeouts, $addr;
                }
                else {
                    verbose "listed in $addr as $mdns_host\n";
                    if ( !$options->get('whitelistings') ) {
                        push @listed, $addr . ' (' . $mdns_host . ')';
                    }
                }
            }
            else {
                verbose "not listed in $addr\n";
                if ( $options->get('whitelistings') ) {
                    push @listed, $addr;
                }
            }
        }
    );

    my $total = scalar @listed;

    if ( is_ipv4($check_object) || is_ipv6($check_object) ) {

# if the input is an IP address we try to do a reverse DNS lookup to display the FQDN
# we ignore errors since in case of failure we can just skip the information

        my $err;
        my @res;
        my $fqdn;

        ( $err, @res ) =
          getaddrinfo( $check_object, q{}, { socktype => SOCK_RAW } );

        if ( !$err ) {

            while ( my $ai = shift @res ) {
                ( $err, $fqdn ) = getnameinfo( $ai->{addr}, NI_NUMERICSERV );
                if ( !$err ) {
                    $check_object = "$check_object ($fqdn)";
                    last;
                }
            }

        }

    }

    my $status;
    my $appendstring = $options->append;

    if ( $options->get('whitelistings') ) {

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

    }

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

    # 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 ) . ')';
    }

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

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

    # append string defined in append argument to status output
    if ( $appendstring ne q{} ) {
        $status .= " $appendstring";
    }

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

    return;

}

1;