#!perl
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) 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.
#
# RCS information
# enable substitution with:
# $ svn propset svn:keywords "Id Revision HeadURL Source Date"
#
# $Id$
# $Revision$
# $HeadURL$
# $Date$
use strict;
use warnings;
use 5.00800;
use IO::Select;
use Nagios::Plugin 0.31;
use Nagios::Plugin::Getopt;
use Nagios::Plugin::Threshold;
use Net::DNS;
use Readonly;
our $VERSION = '1.3.0';
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, $ip, $options, $plugin, $threshold, $res, $timeouts,
);
# 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();
}
##############################################################################
# subroutines
##############################################################################
# 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( UNKNOWN,
q{Internal error: not enough parameters for 'verbose'} );
}
if ( !defined $level ) {
$level = 0;
}
if ( $level < $options->verbose ) {
if ( !print $message ) {
$plugin->nagios_exit( UNKNOWN, 'Error: cannot write to STDOUT' );
}
}
return;
}
##############################################################################
# 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->workers();
# timeout per query (seconds)
my $timeout = $options->get('query-timeout');
my $debug = $options->debug();
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 ) {
if ($debug) {
## no critic (RequireCheckedSyscall)
print 'DEBUG: reading...';
}
my $name = shift @addrs;
if ( !defined $name ) {
if ($debug) {
## no critic (RequireCheckedSyscall)
print "EOF.\n";
}
$eof = 1;
last;
}
if ($debug) {
## no critic (RequireCheckedSyscall)
print "NAME: $name\n";
}
my $sock = $res->bgsend($name);
# 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);
if ($debug) {
## no critic (RequireCheckedSyscall)
print "DEBUG: name = $name, outstanding = ", $sel->count(),
"\n";
}
}
#----------------------------------------------------------------------
# Wait for any replies. Remove any replies from the outstanding pool.
#----------------------------------------------------------------------
my @ready;
my $timed_out = 1;
if ($debug) {
## no critic (RequireCheckedSyscall)
print "DEBUG: waiting for replies\n";
}
@ready = $sel->can_read($timeout);
while (@ready) {
$timed_out = 0;
if ($debug) {
## no critic (RequireCheckedSyscall)
print 'DEBUG: replies received: ', scalar @ready, "\n";
}
foreach my $sock (@ready) {
if ($debug) {
## no critic (RequireCheckedSyscall)
print "DEBUG: handling a reply\n";
}
my $addr = $addrs{$sock};
delete $addrs{$sock};
$sel->remove($sock);
my $ans = $res->bgread($sock);
my $host;
if ($ans) {
foreach my $rr ( $ans->answer ) {
## no critic(ProhibitDeepNests)
if ( !( $rr->type eq 'A' ) ) {
next;
}
$host = $rr->address;
# take just the first answer
last;
}
}
else {
if ($debug) {
## no critic (RequireCheckedSyscall)
print 'DEBUG: no answer: ' . $res->errorstring() . "\n";
}
}
&{$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) {
if ($debug) {
## no critic (RequireCheckedSyscall)
print "DEBUG: timeout: clearing the outstanding pool.\n";
}
foreach my $sock ( $sel->handles() ) {
my $addr = $addrs{$sock};
delete $addrs{$sock};
$sel->remove($sock);
# callback for hosts that timed out
&{$callback}( $addr, q{} );
}
}
if ($debug) {
## no critic (RequireCheckedSyscall)
print 'DEBUG: outstanding = ', $sel->count(), ", eof = $eof\n";
}
#----------------------------------------------------------------------
# We're done if there are no outstanding queries and we've read EOF.
#----------------------------------------------------------------------
last if ( $sel->count() == 0 ) && $eof;
}
return;
}
##