#!/usr/bin/perl -w

# Copyright 2002, Thus Plc, All rights reserved.
# Author: Phil Pennock, <Phil.Pennock@thus.net>, Demon NL NOC
# Approved for public release: Jim Segrave, 2002-02-12
#                              (minus internal mail-address information)
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author and/or Thus Plc may not be used to endorse or
#    promote products derived from this software without specific prior
#    written permission. 
#
# THIS SOFTWARE IS PROVIDED BY THUS PLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
# EVENT SHALL THUS PLC BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

use strict;
# Check multiple DNS-based anti-spam RBLs for listing of address(es)

use Socket;
use Net::DNS;
use Getopt::Std;
use Mail::Mailer;
use Sys::Hostname ();
BEGIN { require 'sysexits.ph' };

my $hostname = Sys::Hostname::hostname();
my $defaultmaildomain = 'example.net';

my %mailinfo = (
    To			=> (scalar getpwuid($<)) . '@' . $defaultmaildomain,
    From		=> 'RBL Check <automated-user@example.net>',
    Subject		=> 'Machines on an RBL',
    Organisation	=> 'MY ORGANISATION',
    Keywords		=> 'mail, relay, RBL, spam',
    'X-Autogenerated'	=> $hostname . ':' . $0,
    'X-Program-Version'	=> '$Revision: 1.14 $ $Date: 2002/02/12 13:50:52 $',
    );

my @rbl_doms = (qw(
	    inputs.orbz.org
	    outputs.orbz.org
	    orbs.dorkslayers.com
	    sbl.spamhaus.org
	    relays.osirusoft.com
	    relays.ordb.org
	    bl.spamcop.net
	    dev.null.dk
	    relays.visi.com
	    blackholes.five-ten-sg.com
	    blacklist.spambag.org
	    blackholes.wirehub.net
	    dynablock.wirehub.net
	    block.blars.org
	    spammers.v6net.org
	    xbl.selwerd.cx
	    ipwhois.rfc-ignorant.org
	));
#	    spews.relays.osirusoft.com # No NS
#	blackholes.mail-abuse.org
#	relays.mail-abuse.org
#	dialups.mail-abuse.org
#	relays.orbs.org
#	rss.maps.vix.com
#	outputs.orbs.org

########################################################################
# NO USER-SERVICEABLE PARTS BEYOND THIS POINT
########################################################################

# Core functionality
sub check_host		($);
sub check_ip		($);
sub check_rblentry	($$$);
sub fetch_nameservers	($);

# Auxilliary functions
sub mprint		(@);
sub mwarn		(@);
sub handle_mail		();
sub usage		(;$);

my $quiet	= 0;
my $buffer	= undef;
my %opts;

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

getopts('hqmM:s:S:x:', \%opts);
usage 0 if exists $opts{'h'};
usage if exists $opts{'m'} and exists $opts{'M'};
usage if exists $opts{'s'} and exists $opts{'S'};

$quiet = 1 if exists $opts{'q'};

if (exists $opts{'M'}) {
	usage unless defined $opts{'M'};
	my $t = $opts{'M'};
	$t .= '@' . $defaultmaildomain unless $t =~ /\@/;
	$mailinfo{'To'} = $t;
	$buffer = '';
}
$buffer = '' if exists $opts{'m'};

if (exists $opts{'s'}) {
	usage unless defined $opts{'s'};
	@rbl_doms = split /[,\s]+/, $opts{'s'};
}
if (exists $opts{'S'}) {
	usage unless defined $opts{'S'};
	push @rbl_doms, split /[,\s]+/, $opts{'S'};
}
if (exists $opts{'x'}) {
	usage unless defined $opts{'x'};
	my %nameset;
	@nameset{@rbl_doms} = (1) x scalar @rbl_doms;
	foreach (split /[,\s]+/, $opts{'x'}) {
		delete $nameset{$_};
	}
	@rbl_doms = keys %nameset; # not worth preserving order
}


usage unless scalar @ARGV;

my $len = 0;
foreach my $a (@ARGV) {
	check_host $a;
	if (defined $buffer and $len < length $buffer) {
		$buffer .= "\n";
		$len = length $buffer;
	}
}

handle_mail if defined $buffer;

exit 0;

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

sub check_host ($)
{
	my $h = shift;

	if ($h =~ /^[0-9:.]+$/) {
		check_ip($h);
		return;
	}

	my (undef, undef, undef, undef, @addrs) = gethostbyname($h);
	if (not defined @addrs) {
		mwarn "DNS host lookup of '${h}' failed: $?\n";
		return undef;
	}

	foreach my $a (@addrs) {
		check_ip(inet_ntoa($a));
	}
}

sub check_ip ($)
{
	my $ip = shift;

	mprint "Checking $ip ...\n" unless $quiet;

	my $stem = join('.', reverse(split(/\./, $ip)));

	foreach my $rd (@rbl_doms) {
		check_rblentry $stem, $rd, $ip;
	}
}

sub check_rblentry ($$$)
{
	my $query_data	= shift;
	my $domain	= shift;
	my $label	= shift;
	my ($res, $query);
	my @servers;
	my @display;

	$domain .= '.' unless $domain =~ /\.$/;
	$query_data .= '.' . $domain;

	@servers = fetch_nameservers $domain;
	if (scalar @servers == 0) {
		mwarn "No nameservers for '${domain}'\n";
		return undef;
	}

	$res = new Net::DNS::Resolver;
	$res->searchlist('.');
	$res->nameservers(@servers);

#	print "DBG: $query_data\n";
	$domain =~ s/\.$//;

	if (not ($query = $res->query($query_data, 'A'))) {
		mprint "$domain ! (@{[$res->errorstring]})\n"
			unless $quiet and (
			    $res->errorstring eq 'NXDOMAIN' or
			    $res->errorstring eq 'NOERROR'
			    );
		return;
	}
	foreach my $rr ($query->answer) {
		push @display, ('  A ' . $rr->rdatastr) if $rr->type eq 'A';
	}
	$query = $res->query($query_data, 'TXT');
	if (not defined $query) {
		push @display, ('   ! No TXT records!');
	} else {
		foreach my $rr ($query->answer) {
			push @display, ('TXT ' . $rr->rdatastr) if $rr->type eq 'TXT';
		}
	}

	{
		local $" = "\n ";
		mprint "[$label]\t$domain => {\n @display\n}\n";
	}

	return scalar @display;
}

{
 my %ns_servers;
sub fetch_nameservers ($)
{
	my $domain = shift;

	return @{$ns_servers{$domain}} if exists $ns_servers{$domain};

	my ($res, $dq);
	my @servers;

	$res = new Net::DNS::Resolver;
	$res->searchlist('.');

	if (not $dq = $res->query($domain, 'NS')) {
		mwarn "No data returned for NS query of '${domain}'\n";
		$ns_servers{$domain} = [];
	} else {
		foreach my $rr ($dq->answer) {
			push @servers, $rr->nsdname if $rr->type eq 'NS';
		}
		$ns_servers{$domain} = \@servers;
	}

	return @{$ns_servers{$domain}};
}
}

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

sub mwarn (@)
{
	return warn(@_) unless defined $buffer;
	foreach (@_) {
		$_ .= "\n" unless m/\n$/;
		$buffer .= 'Warning: ' . $_;
	}
}

sub mprint (@)
{
	return print(@_) unless defined $buffer;
	$buffer .= join '', @_;
}

sub handle_mail ()
{
	return unless defined($buffer) and length $buffer;

	my $mailer = new Mail::Mailer 'sendmail'
		or die "Can't create mailer: $!\n";

	$mailer->open(\%mailinfo);
	print {$mailer} 
		'Checked: ' . join("\nChecked: ", @ARGV) . "\n\n" .
		$buffer .
		"\n-- \n${hostname}:$0\n";

	$mailer->close or die "Can't send mail: $!\n";
}

sub usage (;$)
{
	my $exval = EX_USAGE;
	$exval = $_[0] if defined $_[0];
	select STDERR if $exval;

	my $prog = $0;
	$prog =~ s{.*/}{};

	print "Usage: $prog [-q] [-m]|[-M mailto] [-[sSx] servers] host [host ...]\n";
	print " -h   this help\n -q   quiet\n";
	print " -m   mail mode, to <invoker>\@$defaultmaildomain\n";
	print " -M   mail mode, to <mailto>\n";
	print " -s   RBL servers to this list (comma-separated)\n";
	print " -S   add this list to standard RBL servers\n";
	print " -x   eXclude this comma-separated list from servers to check\n";
	print " host hostname or IP to query in RBLs\n";

	exit $exval;
}