rbld.pl

#!/usr/local/bin/perl
#
# Hunnypot: Copyright 2004 Jeremy Kister
# Released under Perl's Artistic License.
# Function: serve records out of the honey pot in a RBL DNS server
# Author: Jeremy Kister (hunnypot-devel @t jeremykister.com) 
#

use strict;
use DBI;
use Net::DNS::Nameserver; # blocking

my $servername = 'rbl.example.net';
my $dbun = 'dbun';
my $dbpw = 'dbpw';
my $driver = 'mysql';
my $dsn = "DBI:${driver}:";
my $dbserver = 'mysql.example.net';
my $dbname = 'dbname';

if($driver =~ /Sybase/){
   $dsn .= "server=$dbserver";
}else{
   $dsn .= "host=${dbserver};database=${dbname}";
}

chdir('/') || die "cannot chdir /: $!\n";
my $old = ($^T - 172800);
my $dbh = DBI->connect($dsn, $dbun, $dbpw, {RaiseError => 1});

my $ns = Net::DNS::Nameserver->new(
     LocalAddr    => '127.0.0.1',
     LocalPort    => 53,
     ReplyHandler => \&reply_handler,
     Verbose      => 0,
 ) || die "couldn't create nameserver object\n";
 
$ns->main_loop;

sub reply_handler {
	my ($qname, $qclass, $qtype, $peerhost) = @_;
	return unless($qtype eq 'A' || $qtype eq 'TXT' || $qtype eq 'ANY');
	my ($rdata, @ans, @auth, @add);
	my $rcode = 'REFUSED';

	if($qname =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.${servername}.?$/){
		my $ip = "$4.$3.$2.$1";
		my $sql = 'SELECT times FROM hunnypot WHERE timestamp > ' . $old;
		$sql .= ' AND ip = ' . $dbh->quote($ip);
		my $sth = $dbh->prepare($sql);
		$sth->execute;
		my $count=0;
		while(my $row = $sth->fetchrow_hashref){
			my $times = $row->{times};
			$count += $times;
		}
		if($count > 3){
			#dns reply here
			$rcode = 'NOERROR';
			if($count > 255){
				$rdata = "127.0.0.255";
			}else{
				$rdata = "127.0.0.$count";
			}
			my $ttl = '43200';
			if($qtype eq 'A' || $qtype eq 'ANY'){
				push @ans, Net::DNS::RR->new("$qname $ttl IN A ${rdata}");
			}
			if($qtype eq 'TXT' || $qtype eq 'ANY'){
				my $txt = "\"See {ip}\"";
				push @ans, Net::DNS::RR->new("$qname $ttl IN TXT ${txt}");
			}
			push @auth, Net::DNS::RR->new("${servername} $ttl IN NS ${servername}");
	
		}else{
			$rcode = 'NXDOMAIN';
		}
	}
	return($rcode, \@ans, \@auth, \@add, { aa => 1 });
}