hunnypot.pl

#!/usr/local/bin/perl

# Hunnypot: Copyright 2004 Jeremy Kister
# Released under Perl's Artistic License.
# Function: Get information about spammers and infected machines
# Author: Jeremy Kister (hunnypot-devel @t jeremykister.com)
#  :set tabstop=3 in vi
# version 0.6b

use strict;
use IO::Socket::INET;
use IO::Multiplex;
use Net::DNS;
use DBI;

chdir('/') || die "cannot chdir /: $!\n";

my $DEBUG = $ENV{'DEBUG'} || 0;
my $dbun = $ENV{'DBUN'};
my $dbpw = $ENV{'DBPW'};
my $driver = $ENV{'DRIVER'};
my $dsn = "DBI:${driver}:";
my $dbserver = $ENV{'DBSERVER'};
if($driver =~ /Sybase/){
	$dsn .= "server=$dbserver";
}else{
	$dsn .= "host=${dbserver};database=$ENV{'DBNAME'}";
}

my $heloname = $ENV{'HELONAME'} || 'hunnypot.localdomain';
my $ip = $ENV{'LISTEN_IP'} || '0.0.0.0';
my (%client,%smtpcache);

print "STARTING SERVER..\n" if($DEBUG);
unless(defined($dbun) && defined($dbpw) && defined($driver) && defined($dbserver)){
	print "proper environment variables not set; sleeping 10 seconds\n";
	sleep 10;
	die;
}

$| = 1;

my $mux = new IO::Multiplex;
my $server = IO::Socket::INET->new(Proto     => 'tcp',
                                   LocalAddr => $ip,
                                   LocalPort => 25,
                                   Listen    => 30,
                                   Reuse     => 1) ||
 die "cannot set up socket: $!\n";

my ($uid,$gid) = (getpwnam('nobody'))[2,3];
$( = $) = $gid;
$! = 0;
$< = $> = $uid; 
die "unable to chid nobody: $!\n" if($!);

my $dbh = DBI->connect($dsn, $dbun, $dbpw, {PrintError => 1});
until($dbh){
	$dbh = DBI->connect($dsn, $dbun, $dbpw, {PrintError => 1});
	unless($dbh){
		print "could not connect to database: $DBI::errstr (sleeping 10)\n";
		sleep 10;
	}
}

$SIG{ALRM} = sub {
	# clear unused smtp status cache
	while(my($key,$value) = each %smtpcache){
		if($value < (time() - 399)){
			print "removing smtpcache for $key ($value)\n" if($DEBUG);
			delete $smtpcache{$key};
		}
	}
	alarm(3600);
};

alarm(3600);
$mux->listen($server);

$mux->set_callback_object(__PACKAGE__);
$mux->loop;

sub mux_connection {
	my $package = shift;
	my $mux = shift;
	my $fh = shift;

	my $peer = $fh->peerhost();
	$client{ip}{$fh} = $peer;
	$client{$peer} ++;
		
	my $total = $mux->handles;
	if(($total > 20) || ($client{$peer} > 3)){
		$mux->write($fh, "451 too many concurrent connections\r\n");
		$mux->shutdown($fh,1);

		print "Disconnected: $peer ([$client{$peer}/3] [${total}/20] connections)\n";
	}else{
		$mux->write($fh, "220 ${heloname} ESMTP\r\n");
		$mux->set_timeout($fh, 30);
	
		print "Connection from: $peer ([$client{$peer}/3] [${total}/20])\n";
	}
}

sub mux_timeout {
	my $package = shift;
	my $mux = shift;
	my $fh = shift;

	$mux->write($fh, "451 timeout\r\n");
	$mux->shutdown($fh,1);
	
	print "$client{ip}{$fh} -> timeout\n" if($DEBUG);
}

sub mux_eof {
	my $package = shift;
	my $mux = shift;
	my $fh = shift;

	$mux->set_timeout($fh, undef);
	print "$client{ip}{$fh} -> eof\n" if($DEBUG);
	$mux->shutdown($fh,1);
}

sub mux_close {
	my $package = shift;
	my $mux = shift;
	my $fh = shift;

	print "$client{ip}{$fh} -> close\n" if($DEBUG);
	$client{$client{ip}{$fh}} --;
	
	foreach('ip','mf','rt','bytes'){
		delete $client{$_}{$fh}
	}

	$mux->close($fh);
	my @handles = $mux->handles;
	my $total = @handles;
	print "STATUS: [${total}/20]\n";
	if($total > 0){
		foreach my $handle (@handles){
			my $peerhost = $handle->peerhost();
			if($peerhost =~ /^(\d{1,3}\.){3}\d{1,3}$/){
				print "Remaining host: [${peerhost}]\n" if($DEBUG);
			}else{
				# bug in IO::Multiplex ?
				print "Removing rouge handle: [${peerhost}]\n" if($DEBUG);
				$mux->close($handle);
			}
		}
	}
}

sub mux_input {
	my $package = shift;
	my $mux = shift;
	my $fh = shift;
	my $input = shift;

	$mux->set_timeout($fh, undef);
	$mux->set_timeout($fh, 30);
	$$input =~ s{^(.*)\n+}{  } or return;
	chop(my $line = $1);
	$$input = '';

	$client{bytes}{$fh} += length($line);
	if($client{bytes}{$fh} > 1024){
		print "$client{ip}{$fh}: too much data - shutting down\n";
		$mux->write($fh, "451 too much data\r\n");
		$mux->shutdown($fh,1);
	}
	print "$client{ip}{$fh}: ${line}\n";
	if($line =~ /^(HE|EH)LO/i){
		$mux->write($fh, "250 ${heloname}\r\n");
	}elsif($line =~ /^VRFY/i){
		$mux->write($fh, "252 send some mail, i'll try my best\r\n");
	}elsif($line =~ /^MAIL FROM:\s*\]*)\>?/i){
		$client{mf}{$fh} = $1;
		$mux->write($fh, "250 ok\r\n");
	}elsif($line =~ /^RCPT TO:\s*\?/i){
		my $rt = $1;
		my $user = $2;
		my $domain = $3;
		if(exists($client{mf}{$fh})){
			$client{rt}{$fh} = $rt;

			my $remaining = ($smtpcache{$domain} - (time() - 399));
			if(exists($smtpcache{$domain}) && ($remaining > 0)){
				print "$client{ip}{$fh} -> have cache for $domain ($remaining remaining)\n" if($DEBUG);
			}else{
				my @mx = mx($domain);
				my $nummx = @mx;
				my $lastmx = $mx[-1];
				my $highest = $lastmx->exchange if(defined($lastmx));
				if($nummx > 1){
					foreach my $rr (@mx){
						my $exchanger = $rr->exchange;
						if(($exchanger =~ /^(127|0|10|255|224)\./) ||
						   ($exchanger =~ /^192\.168\./) ||
						   ($exchanger =~ /^172\.(1(6|7|8|9)|2\d|3(0|1))\./) ||
						   ($exchanger =~ /^192\.0\.2\./)){
							next;
						}else{
							# dont want to connect to lowest priority MX; that's me
							last if($exchanger eq $highest);

							print "$client{ip}{$fh} -> attempting connection to ${exchanger}..\n" if($DEBUG);
							my $sock = IO::Socket::INET->new(Proto => 'tcp',
							                                 PeerAddr => $exchanger,
							                                 PeerPort => 25,
							                                 Timeout  => 10);
							$mux->set_timeout($fh, undef);
							$mux->set_timeout($fh, 30); # because this could be time consuming
							if($sock){
								print "$client{ip}{$fh} -> connected.\n" if($DEBUG);
								my @banner = getlines($sock);
								if($banner[-1] =~ /^220\s/){
									print $sock "HELO ${heloname}\r\n";
									my @helo = getlines($sock);
									if($helo[-1] =~ /^250\s/){
										print $sock "MAIL FROM:<>\r\n";
										my @mf = getlines($sock);
										if($mf[-1] =~ /^250\s/){
											# this is as far as we can tset
											# (if we test RCPT TO, we run into greylisters,
											# invalid mailboxes, over quota, etc)
											print "$client{ip}{$fh} -> primary ok; caching data.\n" if($DEBUG);
											$smtpcache{$domain} = time();
											print $sock "QUIT\r\n";
											close $sock;
											last;
										}
									}
								}
							}else{
								print "$client{ip}{$fh} -> failed\n" if($DEBUG);
							}
						}
					}
				}else{
					print "$client{ip}{$fh} -> skipping socket test (only mx is me)\n" if($DEBUG);
					$smtpcache{$domain} = time(); # only MX must be me or an open relay scan
				}
			}
			if(exists($smtpcache{$domain})){
				$mux->write($fh, "250 ok\r\n");
				my $sql = 'SELECT id,times FROM hunnypot WHERE ip = ' . $dbh->quote($client{ip}{$fh});
				$sql .= ' AND mf = ' . $dbh->quote($client{mf}{$fh}) . ' AND rt = ';
				$sql .= $dbh->quote($client{rt}{$fh});
				my $sth = $dbh->prepare($sql);
				$sth->execute;
				my $row = $sth->fetchrow_hashref;
				my $id = $row->{id};
				my $times = $row->{times};
				if(defined($id) && defined($times)){
					my $new = ($times + 1);
					my $sql = 'UPDATE hunnypot SET times = ' . $new . ', timestamp = ' . time();
					$sql .= ' WHERE id = ' . $id;
					my $sth = $dbh->prepare($sql);
					$sth->execute;
				}else{
					my $sql = 'INSERT INTO hunnypot (timestamp,mf,rt,ip,times) VALUES (' . time();
					$sql .= ',' . $dbh->quote($client{mf}{$fh}) . ',' . $dbh->quote($client{rt}{$fh});
					$sql .= ',' . $dbh->quote($client{ip}{$fh}) . ',' . '1)';
					my $sth = $dbh->prepare($sql);
					$sth->execute;
				}
			}else{
				$mux->write($fh, "451 try later\r\n");
				delete $client{rt}{$fh};
				print "$client{ip}{$fh} -> Ignoring chatter: primary MXs off-line\n";
			}
		}else{
			$mux->write($fh, "503 MAIL first\r\n");
		}
	}elsif($line =~ /^DATA$/i){
		if(exists($client{mf}{$fh})){
			if(exists($client{rt}{$fh})){
				# give 400 instead of 500 in case main mail server really is off-line
				$mux->write($fh, "450 gotchya :)\r\n");
			}else{
				$mux->write($fh, "503 RCPT first\r\n");
			}
		}else{
			$mux->write($fh, "503 MAIL first\r\n");
		}
	}elsif($line =~ /^QUIT$/i){
		$mux->write($fh, "221 ${heloname}\r\n");
		$mux->shutdown($fh,1);
	}elsif($line =~ /^RSET$/i){
		delete $client{mf}{$fh};
		delete $client{rt}{$fh};
		$mux->write($fh, "250 flushed\r\n");
	}elsif($line =~ /^NOOP$/i){
		$mux->write($fh, "250 ok\r\n");
	}else{
		$mux->write($fh, "502 unimplemented\r\n");
	}
}

sub getlines {
   my $sock = shift;
   my @lines;
   while(<$sock>){
      if(/^\d+\s/){
         chomp;
         push @lines, $_;
         last;
      }else{
         push @lines, $_;
      }
   }
   return(@lines);
}