source: trunk/dnsbl/DNSBL.pm

# DNSBL
# Functions for interacting with the DNSBL database
##
# $Id: DNSBL.pm 104 2025-09-24 17:20:10Z kdeugau $
# Copyright 2009-2012,2014,2018,2025 Kris Deugau <kdeugau@deepnet.cx>
# 
#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version. 
# 
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
# 
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
##

package DNSBL;

use strict;
use warnings;
use Exporter;

use DBI;
use NetAddr::IP;

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

$VERSION        = 3.0;
@ISA            = qw(Exporter);
@EXPORT_OK      = qw( $dbh );

@EXPORT         = qw( $dbh );
%EXPORT_TAGS    = ( ALL => [qw(
                )]
        );

## "constants"

# w00t!  somewhere along the line, by accident or intent, SA's
# check_dnsbl_sub can now check up to 24 bits of an DNSBL return value!
# 1 not available so we don't $self->shoot(foot)
our %bitfields = (
    # ip
        ip => 2,
    # "I'm a total spamming moron!" - per-IP only!
        slist => 128,

    # Block listings.  Ordering for levels 0, 1, 2 not ideal due to evolution of code.
    # Levels 3 and higher are more coherently ordered

    # Automatically listed blocks based on IP counts
        0 => 16,
        1 => 8,
        2 => 4,
        3 => 4096,
        4 => 32768,
        5 => 262144,
        6 => 2097152,

    # Out-of-band
        org0    => 32,
        block0  => 64,
        org1    => 256,
        org2    => 512,
        block1  => 1024,
        block2  => 2048,
        org3    => 8192,
        block3  => 16384,
        org4    => 65536,
        block4  => 131072,
        org5    => 524288,
        block5  => 1048576,
        org6    => 4194304,
        block6  => 8388608,

);

# 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
# defaults: (overridden by entries in db:autolist)
our %autolist = (
        31 => 1,
        30 => 1,
        29 => 2,
        28 => 3,
        27 => 4,
        26 => 5,
        25 => 6,
        24 => 7,
        23 => 8,
        22 => 10,
        21 => 13,
        20 => 16,
        19 => 19,
        18 => 22,
        17 => 26,
        16 => 30,
        15 => 34,
        14 => 38,
        13 => 42,
        12 => 46,
        11 => 50,
        10 => 54,
        9 => 58,
        8 => 62,
        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);

# hard max depth.  There are not enough bits in a 32-bit IP in 127/8 for more than 7 sets of 3 block-level
# flags, plus one for the IP, plus one for an "alternate" IP flag, plus reserving the least significant bit
# as a "don't use this because Reasons"
our $maxlvl = 6;

# variables
our $dbh;

our $err;
our $errstr = '';

# basic object subs
sub new {
  my $this = shift;
  my $class = ref($this) || $this;
  my %args = @_;

  # Prepopulate a basic config.  Note some of these *will* cause errors if left unset.
  my %defconfig = (
        dbhost => "localhost",
        dbname => "dnsbl",
        dbuser => "dnsbl",
        dbpass => "spambgone",
        misc => {
                blzone => "spamhosts.example.com",
                altblzone => "company.dnsbl",
                bladmin => "systems.example.com",
                ttl => 600,
                soa => "600 600 600 600",
                iplisted => '$ relayed a reported spam',
                blocklisted => 'Netblock listed on one or more criteria',
        },
  );

  my %siteconfig;
  my $dbhost;
  my $dbname;
  my $dbuser;
  my $dbpass;
  if (defined($args{configfile})) {
    if (-e $args{configfile} && -f $args{configfile}) {
      my $ret = eval `cat $args{configfile}`;
      unless ($ret) {
        if ($@) { $errstr = "couldn't parse $args{configfile}: $@\n"; return; }
        if (!defined($ret)) { $errstr = "couldn't load $args{configfile}: $!\n"; return; }
        if (!$ret) { $errstr = "couldn't load $args{configfile}\n"; return; }
      }
      # crossload legacy variables, but prefer new %siteconfig values
      $siteconfig{dbhost} = $dbhost if !$siteconfig{dbhost} && $dbhost;
      $siteconfig{dbname} = $dbname if !$siteconfig{dbname} && $dbname;
      $siteconfig{dbuser} = $dbuser if !$siteconfig{dbuser} && $dbuser;
      $siteconfig{dbpass} = $dbpass if !$siteconfig{dbpass} && $dbpass;
    }
  }

  # Assemble the object.  Apply configuration hashes in order of precedence.
  my $self = {
        # Hardcoded defaults
        %defconfig,
        # Default config file OR caller-specified one, loaded above
        %siteconfig,
        # Caller-specified arguments
        %args
        };
  bless $self, $class;

  return $self;
} # new()

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

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

## specific object subs:

sub connect {
  my $self = shift;
  # after jumping a HUUUGE number of PG versions, AutoCommit => 0 produced some bizarre bugs
  $dbh = DBI->connect("DBI:Pg:host=$self->{dbhost};dbname=$self->{dbname}", $self->{dbuser}, $self->{dbpass}, {
        AutoCommit => 1,
        PrintError => 0
        })
        or die "database inaccessible: ".$DBI::errstr;
  my $sth = $dbh->prepare("SELECT masklen,ipcount FROM autolist");
  $sth->execute;
  while (my ($masklen,$ipcount) = $sth->fetchrow_array) {
    $autolist{$masklen} = $ipcount;
  }
  $sth = $dbh->prepare("SELECT key,value FROM misc");
  $sth->execute;
  while (my ($key,$value) = $sth->fetchrow_array) {
    $self->{misc}{$key} = $value;
  }
  return $dbh;
}


## DNSBLDB::initexport()
# Prepare a couple of statement handles for later processing in export().  Assists in ~3x speed increase.
my $parsth;
my $sthmoron;
sub initexport {
  $parsth = $dbh->prepare("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.parent = 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");
  $sthmoron = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE parent = ?");
}


## 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, exclude FROM iplist WHERE ip=?");
  $sth->execute($ip);
  my $ret = $sth->fetchrow_arrayref();
  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 $exclude = shift || 'n';
  $exclude = 'y' if $exclude eq 'on';
  my $sth;
  my $rows = 0;

  local $dbh->{AutoCommit} = 0;
  local $dbh->{RaiseError} = 1;

  if ($rep =~ /^[\d.]+$/) {
    # weesa gonna ASS-U-ME IP addresses are sanely formatted.
    eval {
      $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,parent,exclude) VALUES ".
                "(?,(SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1),?)");
        $sth->execute($rep, $rep, $exclude) or die "couldn't add entry for $rep: ".$dbh->errstr."\n";
      } elsif ($rows == 1) {
        $sth = $dbh->prepare("UPDATE iplist SET count=count+1,".
                " exclude = ? WHERE ip = ?");
        $sth->execute($exclude, $rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
      } else {
        die "db corrupt: found $rows matches on $rep\n";
      }
      $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ?");
      $sth->execute($rep);
      my $updsth = $dbh->prepare("UPDATE blocks SET ipcount=(".
        "SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n'".
        ") WHERE block = ?");
      while (my ($block) = $sth->fetchrow_array) {
        $updsth->execute($block,$block);
      }
      $dbh->commit;
    };
    if ($@) {
      my $msg = $@;
      return "failed adding $rep: $msg";
    }
  } else {
    return;
  }
  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();


# take an arbitrary IP range and an IP, and return the CIDR block (if any) the IP is in.
sub range2cidr {
  my $self = shift;
  my $rstart = shift;
  my $rend = shift;
  my $ip = shift;

  $rstart = new NetAddr::IP $rstart;
  $rend = new NetAddr::IP $rend;
  # Basic algoithm:  Set the mask on the IP, and see if both $rstart and $rend
  # are within the range defined by that IP/mask.  Continue making the mask
  # larger until success.

  my $mask;
  for ($mask = 32; $mask > 0; $mask--) {
    my $ip = NetAddr::IP->new("$ip/$mask");
    if (NetAddr::IP->new($ip->network->addr)   >= $rstart    &&
        NetAddr::IP->new($ip->broadcast->addr) <= $rend) {
      next;
    } else {
      $mask++;
      last;
    }
  }
  my $realnet = NetAddr::IP->new("$ip/$mask")->network;

  return "$realnet";
} # end range2cidr()


# add a block.  requires the orgid
##fixme needs error handling
sub addblock {
  my $self = shift;
  my $blockin = shift;
  my $orgid = shift;
  my $level = shift;
  my $exclude = shift || 'n';
  my $comment = 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} = 0;
  local $dbh->{RaiseError} = 1;

  my $sth;
  eval {
    my $parent = '0/0';
    if ($level > 0) {
      $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
      $sth->execute("$block");
      ($parent) = $sth->fetchrow_array;
    }
    $dbh->do("INSERT INTO blocks (block,orgid,level,parent,exclude,comments,ipcount) VALUES (?,?,?,?,?,?,".
        "(SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n'))",
        undef, "$block",$orgid,$level,$parent,$exclude,$comment,"$block");
    $dbh->do("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?", undef, "$block", $parent, "$block");
    $dbh->commit;
  };
  if ($@) {
    my $msg = $@;
    eval { dbh->rollback; };
    return "failed to add $block: $msg";
  }
  # nb: no need to return anything, since the CIDR block is the key
}


# Update a netblock entry.  Supports (un)setting the exclude flag and the comment.
# Does NOT do any magic around leftover IPs within the block
sub updateblock {
  my $self = shift;
  my $blockin = shift;
  my $orgid = shift;
  my $level = shift;
  my $exclude = shift || 'n';
  my $comment = 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} = 0;
  local $dbh->{RaiseError} = 1;

  my $sth;
  eval {
    my $parent = '0/0';
    if ($level > 0) {
      $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
      $sth->execute("$block");
      ($parent) = $sth->fetchrow_array;
    }
    $sth = $dbh->prepare("UPDATE blocks SET exclude = ?, comments = ?, ipcount = ".
        "(SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n')".
        " WHERE block = ?");
    $sth->execute($exclude, $comment, "$block", "$block");
    $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
    $sth->execute("$block", $parent, "$block");
    $dbh->commit;
  };
  if ($@) {
    my $msg = $@;
    eval { dbh->rollback; };
    return "failed to update $block: $msg";
  }
  # nb: no need to return anything, since the CIDR block is the key
} # updateblock()


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,blockcomment,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,b.comments,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()


# Get info about whether a block, IP or org is listed
# Returns ?
sub islisted {
  my $self = shift;
  my $entity = shift;

  my $sth;

  if ($entity =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
    # looking for IP

    $sth = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE ip=?");
    $sth->execute($entity);
    my @ret = $sth->fetchrow_array;
    return @ret if @ret;

  } elsif ($entity =~ m|^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/(\d+)$|) {
    # block

    my $masklen = $1;

    $sth = $dbh->prepare("SELECT block,listme,exclude,ipcount FROM blocks WHERE block = ?");
    $sth->execute($entity);
    my ($block, $listme, $exclude, $bcount) = $sth->fetchrow_array;

    return if !$block;

    my @ret = ( ($bcount >= $autolist{$masklen}), $listme, $exclude);
    return @ret;

  } else {
    # org

    $sth = $dbh->prepare("SELECT orgid,listme FROM orgs WHERE orgname=?");
    $sth->execute($entity);
    my ($orgid,$listme) = $sth->fetchrow_array;
    return $listme if $orgid;

  }

  return undef;

} # end islisted()


# 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 $maxlvl)
# 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 $bitmask = shift || 0;

  if ($level == 0) {
    $errstr = '';
  }

  return if ($errstr =~ /no connection to the server/);
  if ($level > $maxlvl) {
    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|;
  }


  # catch database-went-away errors
  local $dbh->{RaiseError} = 1;
  eval {


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

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

# Update the bitmask variable with the current block info as needed.
# Much faster than retrieving this data later (~3x faster!).
  my $listme;
  my $listorg;
  my $bcount;
  my $bexclude;
  if ($container ne '0.0.0.0/0') {
    $sth = $dbh->prepare("SELECT b.ipcount,b.listme,b.exclude,o.listme ".
        "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
        "WHERE b.block = ?");
    $sth->execute($container);
    ($bcount,$listme,$bexclude,$listorg) = $sth->fetchrow_array();
    $bcount = 0 if !$bcount;
    $bitmask |= $bitfields{$level-1} if $bcount >= $autolist{$masklen};
    $bitmask |= $bitfields{"block".($level-1)} if $listme;
    $bitmask |= $bitfields{"org".($level-1)} if $listorg;
  }

# hm.  can't seem to move this prepare elsewhere.  :(
  if ($nblocks > 0) {
    my $sthsubblocks = $dbh->prepare("SELECT block,exclude FROM blocks ".
        "WHERE level = ? AND parent = ?");
    $sthsubblocks->execute($level, $container);
    while (my ($cidr, $exclude) = $sthsubblocks->fetchrow_array()) {
      if ($exclude) {
        $listhosts->{$cidr} = -1;
      } else { # don't check subtrees of an excluded block;  rbldnsd doesn't support deep flip-flopping like that
        $self->export($listhosts,$mode,$level+1,$cidr,$bitmask)
          or die $errstr;
      }
    }
  } # 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--;

  if ($mode eq 'cidr') {
    $listhosts->{$container} |= $bitmask if $bitmask && ($listme || $listorg || ($bcount >= $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 ($bitmask) {
      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} |= $bitmask;
        }
      } 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} |= $bitmask;
        }
      } 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} |= $bitmask;
        }
      } 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} |= $bitmask;
        }
      }

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

  } # cidr vs classful mode

  $sthmoron->execute($container);
  while (my ($ip,$moron,$exclude) = $sthmoron->fetchrow_array()) {
    if ($moron) {
      $listhosts->{$ip} = $bitfields{slist};
    } elsif ($exclude) {
      $listhosts->{$ip} = -1;
    } else {
      $listhosts->{$ip} |= $bitmask;
      $listhosts->{$ip} |= $bitfields{ip};
    }
  }


  }; # db-went-away-catching eval
  if ($@) {
    $errstr = $@;
    warn "export truncated: $errstr\n";
    return;
  }


# 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 1;
} # end export()


## 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 ipcount FROM blocks WHERE block = ?");
  $sth->execute("$cidr");
  my ($count) = $sth->fetchrow_array;

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


# make Perl happy
1;