File Coverage

blib/lib/WWW/Honeypot/httpBL.pm

Criterion	Covered	Total	%
statement	21	104	20.1
branch	0	38	0.0
condition	0	37	0.0
subroutine	7	21	33.3
pod	7	9	77.7
total	35	209	16.7

package WWW::Honeypot::httpBL;

use 5.008008;
use strict;
use warnings;

use Carp;
use Net::hostent;
use Socket;

use constant 'LOOKUP_DOMAIN' => 'dnsbl.httpbl.org';

our $VERSION = '0.01';

my $search_engines = {
  '0' => 'Undocumented',
  '1' => 'Alta Vista',
  '2' => 'Ask',
  '3' => 'Baidu',
  '4' => 'Excite',
  '5' => 'Google',
  '6' => 'Looksmart',
  '7' => 'Lycos',
  '8' => 'MSN',
  '9' => 'Yahoo',
  '10' => 'InfoSeek',
  '11' => 'Miscellaneous'
};

sub new {
  my $pkg = shift;

  my $self = {};
  bless $self, $pkg;

  if (! $self->_init(@_)) {
    return undef;
  }

  return $self;
}

sub _init {
  my $self = shift;
  my $args = (ref($_[0]) eq "HASH") ? shift : {@_};

  $self->{'_debug'}      = $args->{'debug'};
  $self->{'_key'}        = $args->{'access_key'};
  $self->{'_current_ip'}              = '';
  $self->{'_current_response'}        = '';
  $self->{'_current_response_octets'} = [];

  return 1;
}

sub access_key {
  my $self = shift;
  my $key  = shift;

  if ($key) {
    $self->{'_key'} = $key;
  }

  return $self->{'_key'};
}

sub fetch {
  my $self = shift;
  my $ip   = shift;

  $self->_reset();

  carp("No Access Key!") && return unless $self->access_key();
  carp("Nothing to fetch!") && return unless $ip;

  unless ($ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
     my $err_str = "That doesn't look like an IP address!";
     carp($err_str) && return $err_str;
  }

  $self->_lookup($self->_reverse_IP($ip));

  return $self->{_current_response} ? ($self->_parse_response()) : undef;
}

sub threat_score {
  my $self = shift;

  return ( $self->{_current_response} && !$self->is_search_engine() ) ?
           ${$self->{_current_response_octets}}[2] : undef;
}

sub days_since_last_actvity {
  my $self = shift;

  return ( $self->{_current_response} && !$self->is_search_engine() ) ?
           ${$self->{_current_response_octets}}[1] : undef;
}

sub is_search_engine {
  my $self = shift;

  return undef unless $self->{_current_response};

  if ( ${$self->{_current_response_octets}}[3] == 0 ) {
    my $serial_number = ${$self->{_current_response_octets}}[2];
    return $search_engines->{$serial_number};
  } else {
    return;
  }
}

sub is_suspicious {
  my $self = shift;

  return undef unless $self->{_current_response};

  my $c = ${$self->{_current_response_octets}}[3];
  if ($c == 1 || $c == 3 || $c == 5 || $c == 7) {
    return 1;
  } else {
    return undef;
  }
}

sub is_harvester {
  my $self = shift;

  return undef unless $self->{_current_response};

  my $c = ${$self->{_current_response_octets}}[3];
  if ($c == 2 || $c == 3 || $c == 6 || $c == 7) {
    return 1;
  } else {
    return undef;
  }
}

sub is_comment_spammer {
  my $self = shift;

  return undef unless $self->{_current_response};

  my $c = ${$self->{_current_response_octets}}[3];

  if ($c == 4 || $c == 5 || $c == 6 || $c == 7) {
    return 1;
  } else {
    return undef;
  }
}

# Internal methods below

sub _lookup {
  my $self        = shift;
  my $reversed_ip = shift;

  my $str = join('.', $self->access_key(), $reversed_ip, LOOKUP_DOMAIN);

  my $h   = gethost($str);

  return unless $h;

  $self->{_current_response} = inet_ntoa($h->addr);
}

sub _reverse_IP {
  my $self = shift;
  my $ip   = shift;

  my @parts = split(/\./, $ip);
  return join('.', reverse(@parts));
}

sub _parse_response {
  my $self = shift;

  my @octets = split(/\./, $self->{_current_response});
  push(@{$self->{_current_response_octets}}, @octets);
  return @octets;
}

sub _reset {
  my $self = shift;

  $self->{'_current_ip'}              = '';
  $self->{'_current_response'}        = '';
  $self->{'_current_response_octets'} = [];
}

1;
__END__