source: trunk/uribl/URIdb.pm@ 49

# URIdb
# Functions for interacting with the URI database
##
# $Id: URIdb.pm 41 2012-03-04 20:52:10Z kdeugau $
# Copyright 2010 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        = 1.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 %status = (
        0 => "Don't list",
        2 => "Black",
        4 => "Grey",
        8 => "Abused URL shortener/redirector"
);

# 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() 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;
  my $dbhost = shift;
  my $dbname = shift;
  my $dbuser = shift;
  my $dbpass = shift;
  ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
  $dbh = DBI->connect("DBI:Pg:host=$dbhost;dbname=$dbname", $dbuser, $dbpass, {
        AutoCommit => 0,
        PrintError => 1
        })
        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;
#  }
  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 || '';

  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 ":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, 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, not well-known 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";
    }
  } elsif ($target eq 'tinydns') {
  } elsif ($target eq 'bind') {
  } else {
  }
  return;
} # end export()


# make Perl happy
1;