source: trunk/uribl/URIdb.pm@ 101

# URIdb
# Functions for interacting with the URI database
##
# $Id: URIdb.pm 101 2025-09-24 15:01:28Z kdeugau $
# Copyright 2010,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 URIdb;

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( $dbh );

@EXPORT         = qw( $dbh );

%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 %status = (
        0 => "Don't list",
        2 => "Black",
        4 => "Grey",
        8 => "Abused URL shortener/redirector",
        16 => "High-risk domain",
);

# 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 => "uribl.company.com",
                altblzone => "uri.dnsbl",
                bladmin => "systems.company.com",
                ttl => 600,
                soa => "600 600 600 600",
        },
  );

  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;
}

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

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

## specific object subs:

sub connect {
  my $self = shift;
  ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
  $dbh = DBI->connect("DBI:Pg:host=$self->{dbhost};dbname=$self->{dbname}", $self->{dbuser}, $self->{dbpass}, {
        AutoCommit => 0,
        PrintError => 1
        })
        or die "database inaccessible: ".$DBI::errstr;
  my $sth = $dbh->prepare("SELECT key,value FROM misc");
  $sth->execute;
  while (my ($key,$value) = $sth->fetchrow_array) {
    $self->{misc}{$key} = $value;
  }
  $self->{misc}{blzone} = 'uribl.company.com' if !$self->{misc}{blzone};
  $self->{misc}{altblzone} = 'uribl.company.com' if !$self->{misc}{altblzone};
  return $dbh;
}


# report a URI to the db
# increments a hit counter iff the reported URI exists, otherwise it adds it
# requires the uri.
# can accept the listing level and a comment
sub report {
  my $self = shift;
  my $uri = shift;
  my $list = shift || 2;
  my $comment = shift || '';

  $uri =~ s/^\s+//;
  $uri =~ s/\s+$//;

  my $sth;
  my $rows = 0;
  $sth = $dbh->prepare("SELECT count FROM urilist WHERE uri=?");
  $sth->execute($uri) or die "eep?  ".$dbh->errstr."\n";
  $rows = $sth->rows;
  if ($rows == 0) {
    $sth = $dbh->prepare("INSERT INTO urilist (uri,list,comment) VALUES (?,?,?)");
    $sth->execute($uri,$list,$comment) or die "couldn't add $uri: ".$dbh->errstr."\n";
  } elsif ($rows == 1) {
    $sth = $dbh->prepare("UPDATE urilist SET count=count+1 WHERE uri=?");
    $sth->execute($uri) or die "couldn't update listing for $uri: ".$dbh->errstr."\n";
  } else {
    die "db corrupt: found $rows matches on $uri\n";
  }
  $dbh->commit;
  return $rows;
} # end report()


sub exists {
  my $self = shift;
  my $checkme = shift;

  my $sth = $dbh->prepare("SELECT count(*) FROM urilist WHERE uri=?");
  $sth->execute($checkme);
  my ($count) = $sth->fetchrow_array;
  return $count;
}


# Write the data straight to a DNS server's files.
# Takes a server type and open filehandle.
sub export {
  my $self = shift;
  my $target = shift;
  my $blfh = shift;

  my $sth;

  if ($target eq 'rbldnsd') {
    print $blfh "\$SOA 900 $self->{misc}{blzone} $self->{misc}{bladmin} 0 $self->{misc}{soa}\n".
        "\$NS 3600 127.0.0.1\n".
        "\$TTL $self->{misc}{ttl}\n";
    print $blfh ":127.0.0.2:Domain found in reported missed-spam, no legitimate root or www content\n";
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=2");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh ".$uri\n";
    }
    print $blfh ":127.0.0.4:Domain seen repeatedly in reported missed-spam, some legitimate root or www content\n";
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=4");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh ".$uri\n";
    }
    print $blfh ":127.0.0.8:Abused URL-shortener or redirector domain\n";
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=8");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh ".$uri\n";
    }
    print $blfh ":127.0.0.16:High-risk domain\n";
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=16");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh ".$uri\n";
    }
  } elsif ($target eq 'tinydns') {
    my $soa = $self->{misc}{soa};
    $soa =~ s/\s+/:/g;
    print $blfh "Z$self->{misc}{blzone}:$self->{misc}{blzone}:$self->{misc}{bladmin}::$soa\n";
    print $blfh "\&$self->{misc}{blzone}:127.0.0.1::3600\n";
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=2");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh "'$uri.$self->{misc}{blzone}:Domain found in reported missed-spam, no legitimate root or www content:$self->{misc}{ttl}::\n".
        "+$uri.$self->{misc}{blzone}:127.0.0.2:$self->{misc}{ttl}::\n";
    }
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=4");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh "'$uri.$self->{misc}{blzone}:Domain seen repeatedly in reported missed-spam, some legitimate root or www content:$self->{misc}{ttl}::\n".
        "+$uri.$self->{misc}{blzone}:127.0.0.4:$self->{misc}{ttl}::\n";
    }
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=8");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh "'$uri.$self->{misc}{blzone}:Abused URL-shortener or redirector domain:$self->{misc}{ttl}::\n".
        "+$uri.$self->{misc}{blzone}:127.0.0.8:$self->{misc}{ttl}::\n";
    }
    $sth = $dbh->prepare("SELECT uri FROM urilist WHERE list=16");
    $sth->execute;
    while (my ($uri) = $sth->fetchrow_array) {
      print $blfh "'$uri.$self->{misc}{blzone}:High-risk domain:$self->{misc}{ttl}::\n".
        "+$uri.$self->{misc}{blzone}:127.0.0.16:$self->{misc}{ttl}::\n";
    }
  } elsif ($target eq 'bind') {
  } else {
  }
  return;
} # end export()


# make Perl happy
1;