source: trunk/dnsbl/DNSBL.pm@ 11

# DNSBL
# Functions for interacting with the DNSBL database

package DNSBL;

use strict;
use warnings;
use Exporter;
use DBI;
use NetAddr::IP;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION        = 2.0;
@ISA            = qw(Exporter);
@EXPORT_OK      = qw(
        );

@EXPORT         = (); # Export nothing by default.
%EXPORT_TAGS    = ( ALL => [qw(
                )]
        );

## "constants"

# 8 bits available
# 128 is per-IP shitlist
# 2 is IP hitlist
# 1 not available so we don't $self->shoot(foot)
our %bitfields = (
    # block levels
        0 => 16,
        1 => 8,
        2 => 4,
    # ip
        ip => 2,
    # OOB
        org => 32,
        block => 64,
    # "I'm a total spamming moron!" - per-IP only!
        slist => 128
);

# probably needs some tuning;  even 7 hits in a /24 is a pretty small percentage
# number of IPs in a block of the given masklength needed to have that block automatically listed
our %autolist = (
        31 => 1,
        30 => 1,
        29 => 2,
        28 => 3,
        27 => 4,
        26 => 5,
        25 => 6,
        24 => 7,
        23 => 8,
        22 => 10,
        21 => 12,
        20 => 14,
        19 => 16,
        18 => 18,
        17 => 20,
        16 => 22,
        15 => 24,
        14 => 26,
        13 => 28,
        12 => 30,
        11 => 32,
        10 => 34,
        9 => 36,
        8 => 38,
        7 => 2**31,
        6 => 2**31,
        5 => 2**31,
        4 => 2**31,
        3 => 2**31,
        2 => 2**31,
        1 => 2**31,
        0 => 2**31
);

# le sigh.  constants for masklength iterationing
our @howmany = (1,128,64,32,16,8,4,2,1,128,64,32,16,8,4,2,1,128,64,32,16,8,4,2,1,128,64,32,16,8,4,2);

# variables
our $dbh;

our $err;
our $errstr;

# basic object subs
sub new {
# iff we want to start taking arguments, or doing other things on instantiation
#  my $self = {};
#  bless $self, "DNSBL";
#  return $self;
  bless {};
}

sub DESTROY {
  my $self = shift;
  $self->dbclose();
}

# JIC someone wants to close the db but not finish the script
sub dbclose {
  $dbh->rollback;
  $dbh->disconnect;
}

## specific object subs:

sub connect {
  my $DSN = "DBI:Pg:host=dbhost;dbname=dnsbl";
#  my $DSN = "DBI:Pg:dbname=dnsbl";
  my $user = "dnsbl";
  my $pass = "spambgone";
  ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
  $dbh = DBI->connect($DSN, $user, $pass, {
        AutoCommit => 0,
        PrintError => 1
        })
        or die "database inaccessible: ".$DBI::errstr;
  return $dbh;
}


## DNSBL::ipexists()
# return report count if the IP has been reported, otherwise return undef
sub ipexists {
  my $self = shift;
  my $ip = shift;
  my $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
  $sth->execute($ip);
  my ($ret) = $sth->fetchrow_array();
  return $ret;
} # end ipexists()


# report an IP or URI to the db
# increments a hit counter iff the reported IP or URI exists, otherwise it adds it
sub report {
  my $self = shift;
  my $rep = shift;
  my $sth;
  my $rows = 0;
  if ($rep =~ /^[\d.]+$/) {
    # weesa gonna ASS-U-ME IP addresses are sanely formatted.
    $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
    $sth->execute($rep) or die "eep?  ".$dbh->errstr."\n";
    $rows = $sth->rows;
    if ($rows == 0) {
      $sth = $dbh->prepare("INSERT INTO iplist (ip) VALUES (?)");
    } elsif ($rows == 1) {
      $sth = $dbh->prepare("UPDATE iplist SET count=count+1 WHERE ip=?");
    } else {
      die "db corrupt: found $rows matches on $rep\n";
    }
    $sth->execute($rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
  } else {
    return;
  }
  $dbh->commit;
  return $rows;
} # end report()


# add a new org
# return the orgid
# if the org exists, return the orgid anyway
sub addorg {
  my $self = shift;
  my $orgname = shift;
  my $listme = shift || 'n';
  my $ret = $self->orgexists($orgname);
  return $ret if $ret;
  my $sth = $dbh->prepare("INSERT INTO orgs (orgname,listme) VALUES (?,?)");
  $sth->execute($orgname,$listme) or die "couldn't add org $orgname: ".$dbh->errstr."\n";
  $dbh->commit;
  $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
  $sth->execute($orgname);
  my ($orgid) = $sth->fetchrow_array();
  return $orgid;
} # end addorg


# checks for existence - nb, exact match!  No way to really handle anything else.  :/
sub orgexists {
  my $self = shift;
  my $org = shift;
  my $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
  $sth->execute($org);
  my ($ret) = $sth->fetchrow_array();
  return $ret;
} # end orgexists();


# add a block.  requires the orgid
##fixme needs error handling
sub addblock {
  my $self = shift;
  my $blockin = shift;
  my $orgid = shift;
  my $level = shift;
  $blockin =~ s/^\s+//;
  $blockin =~ s/\s+$//;
  my $block = new NetAddr::IP "$blockin";       # need this to clean up messes like ranges.  sigh.

  return "$blockin not a single CIDR range" if !$block;

  local $dbh->{AutoCommit} = 1; # force autocommit

  my $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level) VALUES (?,?,?)");
  $sth->execute("$block",$orgid,$level);
  return $sth->errstr if $sth->err;
  # nb: no need to return anything, since the CIDR block is the key
}


sub blockexists {
  my $self = shift;
  my $block = shift;
  my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
  $sth->execute($block);
  my ($ret) = $sth->fetchrow_array();
  return $ret;
}


# returns list (block,orgname) for the block that contains the passed IP.
# accepts a level argument if you don't want the top-level registrar allocation block
sub getcontainer {
  my $self = shift;
  my $ip = shift;
  my $level = shift || 0;
  my $sth = $dbh->prepare("SELECT b.block,o.orgname FROM blocks b INNER JOIN orgs o ".
        "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
  $sth->execute($ip,$level);
  return $sth->fetchrow_array();
} # end getcontainer()


# whee! Recursion is Fun!
# Call ourself to dig down through the layers of blocks from registar-allocation
# (level 0) to final block (level n, not to exceed 2)
# Take a reference to a hash, and stuff it full of blacklisting goodness.
# Optionally accept a level, block-container, and OOB block and org arguments for
# the container to check and return
# Returns no value directly
# Calls itself to walk down the tree of containers
sub export {
  my $self = shift;
  my $listhosts = shift;

# Export data as CIDR netblocks or classful (A/B/C) blocks
# Assume classful as it's more compatible with different DNS servers
  my $mode = shift || 'class';

# Assume we're checking the whole enchilada if we don't get told where to look.
  my $level = shift || 0;
  my $container = shift || '0.0.0.0/0';
  my $oobblock = shift || 0;
  my $ooborg = shift || 0;

  if ($level > 3) {
    warn "getting too deep, breaking off! ($container, $level)\n";
    return;
  }

# fiddle $container into a sane state.
  if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
    $container =~ s|/(\d+)$|.0/$1|;
  } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
    $container =~ s|/(\d+)$|.0.0/$1|;
  } elsif ($container =~ m|^\d+/(\d+)$|) {
    $container =~ s|/(\d+)$|.0.0.0/$1|;
  }

  my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block << ?");
  $sth->execute($container);
  my ($nblocks) = $sth->fetchrow_array();

  if ($nblocks > 0) {
    my $sql = "SELECT b.block,b.listme,o.orgname,o.listme ".
        "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
        "WHERE b.level=$level and b.block << '$container' ORDER BY b.block, masklen(b.block) DESC";
    $sth = $dbh->prepare($sql);
    $sth->execute();
    while (my ($cidr,$listblock,$org,$listorg) = $sth->fetchrow_array()) {
      $self->export($listhosts,$mode,$level+1,$cidr,$listblock,$listorg);
    }
  } # avoid checking content of subs if we don't have any

  # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
  return if $container eq '0.0.0.0/0';

##fixme:  need a way to dig out orphan IPs at all levels - IPs not found in a
# subblock of the current container when the current container *has* subblocks
# NB: this may be better handled as an out-of-band data-integrity-checker

  # decrement level here so the right bitfield setting gets picked.  this segment
  # is inherently off-by-one from the block-recursion loop, and I can't see a
  # better way to work around that.  >:(
  $level--;

  # need this for a bunch of things, may as well do it here
  my ($masklen) = ($container =~ m|/(\d+)$|);

# Snag all parent block "is-it-listed?" data, and stuff it into a single
# variable we can use later.  Much faster than retrieving this data
# individually, for each octet iteration.

  my $mycount = 0;
  my $sql = "SELECT count(i.ip),b.block,b.level,b.listme AS oobblock,o.listme AS ooborg ".
        "FROM iplist i INNER JOIN blocks b ON i.ip << b.block INNER JOIN orgs o ON b.orgid = o.orgid ".
        "WHERE b.block >>= ? ".
        "GROUP BY b.block,b.level,b.listme,o.listme ORDER BY b.block";
  my $parsth = $dbh->prepare($sql);
  $parsth->execute($container);
  my $pdata = 0;
  while (my ($pcount,$p,$plev,$pblock,$porg) = $parsth->fetchrow_array) {
    my ($pmasklen) = ($p =~ m|\d+/(\d+)$|);
    $pdata |= $bitfields{$plev} if $pcount >= $autolist{$pmasklen};
    $pdata |= $bitfields{block} if $pblock;
    $pdata |= $bitfields{org} if $porg;
    $mycount = $pcount if $p eq $container;
  }

  if ($mode eq 'cidr') {
    $listhosts->{$container} |= $pdata if $pdata && ($ooborg || $oobblock || ($mycount >= $autolist{$masklen}));
  } else {
  # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
  # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
  # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting

    if ($pdata) {
      my @blocksubs;
      if ($masklen <= 30 && $masklen > 24) {
        my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
        for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
          my $host = "$net$entry";
          $listhosts->{$host} = 0 if !defined($listhosts->{$host});
          $listhosts->{$host} |= $pdata;
        }
      } elsif ($masklen <= 24 && $masklen > 16) {
        my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
        for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
          my $twofour = "$net$entry.*";
          $listhosts->{$twofour} |= $pdata;
        }
      } elsif ($masklen <= 16 && $masklen > 8) {
        my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
        for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
          my $sixteen = "$net$entry.*";
          $listhosts->{$sixteen} |= $pdata;
        }
      } elsif ($masklen <= 8) {
        my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
        for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
          my $eight = "$entry.*";
          $listhosts->{$eight} |= $pdata;
        }
      }

#print "DEBUG1: $container, ".(@blocksubs + 0)."\n";
# this seems to be a BIG timesink...  execution time ~1:30 without, ~4:30 with
#if (0){
#    $sth = $dbh->prepare("select block,level,listme from blocks where block >> ?");
#    my $sth2 = $dbh->prepare("select count(*) from iplist where ip << ?");
#    foreach (@blocksubs) {
#print "  DEBUG: $_ container-is-listed check\n";
# collect info on container block(s)
#      $sth->execute($container);
#      while (my ($parent, $plev, $listme) = $sth->fetchrow_array()) {
#       $sth2->execute($parent);
#       my ($parlen) = ($parent =~ m|/(\d+)|);
#       my ($parcount) = $sth2->fetchrow_array();
#print "  DEBUG: $parent: $parlen, $parcount, $plev\n";
#       $listhosts->{$_} |= $bitfields{$plev} if $parcount >= $autolist{$parlen};  #hmm.
#       $listhosts->{$_} |= $bitfields{block} if $listme;
#      }
#    }
#}

    } # generate autolist entries for ips/octets not (yet) seen in reports

  } # cidr vs classful mode

  $sth = $dbh->prepare("SELECT ip,s4list FROM iplist WHERE ip << ? ORDER BY ip");
  $sth->execute($container);
  while (my ($ip,$moron) = $sth->fetchrow_array()) {
    $listhosts->{$ip} |= $pdata;
    if ($moron) {
      $listhosts->{$ip} = $bitfields{slist};
    } else {
      $listhosts->{$ip} |= $bitfields{ip};
    }
  }

# get IPs which for reasons unknown are apparently allocated directly from the
# parent registry (and so do not have containing netblocks in this system)  O_o
#  select * from iplist where not (select count(*) from blocks where ip << block) > 0;

  return;
} # end export()


sub export_alt {
  my $self = shift;
  my $listhosts = shift;
  my $level = shift || 0;
  my $container = shift || '0.0.0.0/0';
  my $oobblock = shift || 0;
  my $ooborg = shift || 0;

#print "\nDEBUG: called with $level, $container, $oobblock, $ooborg\n";
# if $level > 2 or $container =~ /^64\.76\./;
#  my %listhosts;

#  $level = 0 if !$level;
  if ($level > 3) {
    warn "getting too deep, breaking off!\n";
    return;
  }

  my $sth = $dbh->prepare("select ip,s4list from iplist order by ip");
  my $bsth = $dbh->prepare("select b.block,b.listme,b.level,o.listme ".
        "from blocks b inner join orgs o on b.orgid=o.orgid ".
        "where b.block >> ?");
  while (my ($ip,$s4list) = $sth->fetchrow_array) {
    $bsth->execute($ip);
    while (my ($block,$blisted,$blevel,$olisted) = $bsth->fetchrow_array) {
      $listhosts->{$ip} |= 0;
    }
  }
  
} # end export_alt()


## DNSBL::autolist_block()
# check if a block should be autolisted
sub autolist_block {
  my $self = shift;
  my $block = shift;

  my $cidr = new NetAddr::IP "$block";
  my $sth = $dbh->prepare("select count(*) from iplist where ip << ?");
  $sth->execute("$cidr");
  my ($count) = $sth->fetchrow_array;

  return 1 if $count >= $autolist{$cidr->masklen};
  return 0;
} # end autolist_block()


# make Perl happy
1;