Index: /trunk/dnsbl/DNSBL.pm
===================================================================
--- /trunk/dnsbl/DNSBL.pm	(revision 3)
+++ /trunk/dnsbl/DNSBL.pm	(revision 3)
@@ -0,0 +1,450 @@
+# 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 = (
+	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;
+}
+
+# return true if the IP has been reported
+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;
+}
+
+
+# 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.
+
+  local $dbh->{AutoCommit} = 1;	# force autocommit
+
+  my $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level) VALUES (?,?,?)");
+  $sth->execute("$block",$orgid,$level);
+  # 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' || $mode eq 'rbldnsd') {
+    $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;
Index: /trunk/dnsbl/browse.cgi
===================================================================
--- /trunk/dnsbl/browse.cgi	(revision 3)
+++ /trunk/dnsbl/browse.cgi	(revision 3)
@@ -0,0 +1,117 @@
+#!/usr/bin/perl
+# quickndirty browse-the-damned-by-web
+
+use strict;
+use warnings;
+use DBI;
+use CGI::Carp qw(fatalsToBrowser);
+use HTML::Template;
+
+use DNSBL;
+
+my $dnsbl = new DNSBL;
+
+my $dbh = $dnsbl->connect;
+
+print "Content-Type: text/html\n\n";
+
+my @lvl0 = ("foo", "bar", "bax");
+my $template = HTML::Template->new(filename => 'templates/browse.tmpl');
+
+my $basesql = "SELECT b.block,o.orgname,b.listme,o.listme,b.comments ".
+	"FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
+	"WHERE b.block <<= ";
+my $sth0 = $dbh->prepare($basesql."'0/0' AND b.level=0 ORDER BY block");
+#my $sth0 = $dbh->prepare($basesql."'76.73.0.0/17' AND b.level=0 ORDER BY block");
+my $sth1 = $dbh->prepare($basesql."? AND b.level=1 ORDER BY block");
+my $sth2 = $dbh->prepare($basesql."? AND b.level=2 ORDER BY block");
+my $sthiplist = $dbh->prepare("select * from iplist where ip <<= ? order by ip");
+
+print $template->output;
+
+my %ipseen;
+
+$sth0->execute;
+while (my ($block0,$org0,$listmeb0,$listmeo0,$comments0) = $sth0->fetchrow_array) {
+  print "<div class=\"lvl0".($dnsbl->autolist_block($block0) ? ' auto0"' : '"').
+	"><span".($listmeb0 ? ' class=b0list' : '').">$block0</span> ".
+	"<span".($listmeo0 ? ' class=b0org' : '').">$org0</span>\n";
+  $sth1->execute($block0);
+  if ($sth1->rows > 0) {
+    while (my ($block1,$org1,$listmeb1,$listmeo1,$comments1) = $sth1->fetchrow_array) {
+# lvl 1 div open
+      print "  <div class=\"lvl1".($dnsbl->autolist_block($block1) ? ' auto1"' : '"').
+	"><span".($listmeb1 ? ' class=b1list' : '').">$block1</span> ".
+	"<span".($listmeo1 ? ' class=b1org' : '').">$org1</span>\n";
+      $sth2->execute($block1);
+      if ($sth2->rows > 0) {
+        while (my ($block2,$org2,$listmeb2,$listmeo2,$comments2) = $sth2->fetchrow_array) {
+# lvl 2 div open
+          print "    <div class=\"lvl2".($dnsbl->autolist_block($block2) ? ' auto2"' : '"').
+		"><span".($listmeb2 ? ' class=b2list' : '').">$block2</span> ".
+		"<span".($listmeo2 ? ' class=b2org' : '').">$org2</span>\n";
+          $sthiplist->execute($block2);
+          print "      <div class=iplist>\n";
+          while (my @data4 = $sthiplist->fetchrow_array) {
+            print "        $data4[0]<br>\n";
+            $ipseen{$data4[0]} = 1;
+          }
+          print "      </div>\n";
+# lvl2 div close
+          print "    </div>\n";
+        }
+      } else {
+        $sthiplist->execute($block1);
+        print "    <div class=iplist>\n";
+        while (my @data4 = $sthiplist->fetchrow_array) {
+          print "      $data4[0]<br>\n";
+          $ipseen{$data4[0]} = 1;
+        }
+        print "    </div>\n";
+      }
+
+      my $sqlalt = "select ip from iplist where ip << ?";
+      my $sthalt = $dbh->prepare($sqlalt);
+      $sthalt->execute($block1);
+      my @newips;
+      while (my @data4 = $sthalt->fetchrow_array) {
+        push @newips, $data4[0] if !$ipseen{$data4[0]};
+        $ipseen{$data4[0]} = 1;
+      }
+      if ($#newips > -1) {
+        print "    <div class=iplist>\n";
+        foreach (@newips) {
+          print "      $_<br>\n";
+        }
+        print "    </div>\n";
+      }
+# lvl 1 div close
+      print "  </div>\n";
+    }
+  } else {
+    $sthiplist->execute($block0);
+    print "  <div class=iplist>\n";
+    while (my @data4 = $sthiplist->fetchrow_array) {
+      print "    $data4[0]<br>\n";
+      $ipseen{$data4[0]} = 1;
+    }
+    print "  </div>\n";
+  }
+
+  my $sqlalt = "select ip from iplist where ip << ?";
+  my $sthalt = $dbh->prepare($sqlalt);
+  $sthalt->execute($block0);
+  my @newips;
+  while (my @data4 = $sthalt->fetchrow_array) {
+    push @newips, $data4[0] if (!$ipseen{$data4[0]});
+  }
+  if ($#newips > -1) {
+    print "  <div class=iplist>\n";
+    foreach (@newips) {
+      print "    $_<br>\n";
+    }
+    print "  </div>\n";
+  }
+
+  print "</div>\n";
+}
Index: /trunk/dnsbl/check-iplist.pl
===================================================================
--- /trunk/dnsbl/check-iplist.pl	(revision 3)
+++ /trunk/dnsbl/check-iplist.pl	(revision 3)
@@ -0,0 +1,48 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use DBI;
+
+use DNSBL;
+
+my $dnsbl = new DNSBL;
+
+my $dbh = $dnsbl->connect;
+
+print "checking IP containment...\n";
+my $sth = $dbh->prepare("select ip from iplist order by ip");
+$sth->execute;
+my $cksth = $dbh->prepare("select block from blocks where block >> ?");
+while (my @data = $sth->fetchrow_array) {
+  $cksth->execute($data[0]);
+  print "$data[0] has no container\n" if $cksth->rows == 0;
+}
+
+print "checking level 2 blocks...\n";
+$sth = $dbh->prepare("select block from blocks where level=2");
+$sth->execute;
+$cksth = $dbh->prepare("select block from blocks where block >> ? and level=1");
+while (my @data = $sth->fetchrow_array) {
+  $cksth->execute($data[0]);
+  print "$data[0] has no container\n" if $cksth->rows == 0;
+}
+
+print "checking level 1 blocks...\n";
+$sth = $dbh->prepare("select block from blocks where level=1");
+$sth->execute;
+$cksth = $dbh->prepare("select block from blocks where block >> ? and level=0");
+while (my @data = $sth->fetchrow_array) {
+  $cksth->execute($data[0]);
+  print "$data[0] has no container\n" if $cksth->rows == 0;
+}
+
+print "checking for empty blocks\n";
+$sth = $dbh->prepare("select block from blocks");
+$sth->execute;
+$cksth = $dbh->prepare("select ip from iplist where ip << ?");
+while (my @data = $sth->fetchrow_array) {
+  $cksth->execute($data[0]);
+  print "$data[0] has no IPs\n" if $cksth->rows == 0;
+}
+
Index: /trunk/dnsbl/dnsbl-db-feeder
===================================================================
--- /trunk/dnsbl/dnsbl-db-feeder	(revision 3)
+++ /trunk/dnsbl/dnsbl-db-feeder	(revision 3)
@@ -0,0 +1,52 @@
+#!/usr/bin/perl
+# Feed IP or URI data into DNSBL database
+# 2009/05/26 kdeugau@deepnet.cx
+
+use strict;
+use warnings;
+use DBI;
+use DNSBL;
+
+my $DSN = "DBI:Pg:host=dbhost;dbname=dnsbl";
+my $user = "dnsbl";
+my $pass = "spambgone";
+
+die "need input!\n" if !$ARGV[0];
+
+### want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
+#my $dbh = DBI->connect($DSN, $user, $pass, {
+#	AutoCommit => 0,
+#	PrintError => 0
+#	})
+#	or die "database inaccessible: ".$DBI::errstr;
+
+my $dnsbl = new DNSBL;
+
+$dnsbl->connect;
+$dnsbl->report($ARGV[0]);
+
+#$dnsbl->dbclose();
+
+exit 0;
+
+my $sth;
+
+#if ($ARGV[0] =~ /^[\d.]+$/) {
+#  # weesa gonna ASS-U-ME IP addresses are sanely formatted.
+#  $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
+#  $sth->execute($ARGV[0]) or die "eep?  ".$dbh->errstr."\n";
+#  my $rows = $sth->rows;
+#  if ($rows == 0) {
+#    $sth = $dbh->prepare("INSERT INTO iplist (ip) VALUES (?)");
+#  } elsif ($rows == 1) {
+#    my ($cnt) = ($sth->fetchrow_array());
+#    $sth = $dbh->prepare("UPDATE iplist SET count=count+1 WHERE ip=?");
+#  } else {
+#    die "die.die.die: db corrupt: found $rows matches on $ARGV[0]\n";
+#  }
+#  $sth->execute($ARGV[0]);
+#} else {
+#}
+
+#$dbh->commit;
+#$dbh->disconnect;
Index: /trunk/dnsbl/dnsbl.cgi
===================================================================
--- /trunk/dnsbl/dnsbl.cgi	(revision 3)
+++ /trunk/dnsbl/dnsbl.cgi	(revision 3)
@@ -0,0 +1,83 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use CGI::Carp qw (fatalsToBrowser);
+use CGI::Simple;
+use HTML::Template;
+use DNSBL;
+
+# Set up the CGI object...
+my $q = new CGI::Simple;
+# ... and get query-string params as well as POST params if necessary
+$q->parse_query_string;
+
+my %webvar;
+# This is probably excessive fiddling, but it puts the parameters somewhere my fingers know about...
+foreach ($q->param()) {
+  $webvar{$_} = $q->param($_);
+}
+
+my $dnsbl = new DNSBL;
+
+$dnsbl->connect;
+
+print "Content-type: text/html\n\n";
+
+my $page;
+my $templatedir = "templates";
+
+# decide which page to spit out...
+if (!$webvar{page}) {
+  $page = HTML::Template->new(filename => "$templatedir/index.tmpl");
+} else {
+  $page = HTML::Template->new(filename => "$templatedir/$webvar{page}.tmpl");
+}
+
+if ($webvar{page} eq 'report') {
+  $page->param(ip => $webvar{ip});
+  for (my $i=0; $i<3; $i++) {
+    my ($block,$org) = $dnsbl->getcontainer($webvar{ip},$i);
+    if ($block) {
+      $page->param("block$i" => $block);
+      $page->param("org$i" => $org);
+    }
+  }
+} elsif ($webvar{page} eq 'dbreport') {
+  my $count = $dnsbl->report($webvar{ip});
+  my $org0id = $dnsbl->orgexists($webvar{org0});
+  if (!$org0id) {
+    $org0id = $dnsbl->addorg($webvar{org0});
+    $page->param(org0 => $webvar{org0});
+  }
+  if (!$dnsbl->blockexists($webvar{block0})) {
+    $dnsbl->addblock($webvar{block0}, $org0id, 0);
+    $page->param(block0 => $webvar{block0});
+  }
+# yes, this is grotty.  PTHBTT!
+  if ($webvar{block1}) {
+    my $org1id = $dnsbl->orgexists($webvar{org1});
+    if (!$org1id) {
+      $org1id = $dnsbl->addorg($webvar{org1});
+      $page->param(org1 => $webvar{org1});
+    }
+    if (!$dnsbl->blockexists($webvar{block1})) {
+      $dnsbl->addblock($webvar{block1}, $org1id, 1);
+      $page->param(block1 => $webvar{block1});
+    }
+    if ($webvar{block2}) {
+      my $org2id = $dnsbl->orgexists($webvar{org2});
+      if (!$org2id) {
+        $org2id = $dnsbl->addorg($webvar{org2});
+        $page->param(org2 => $webvar{org2});
+      }
+      if (!$dnsbl->blockexists($webvar{block2})) {
+        $dnsbl->addblock($webvar{block2}, $org2id, 2);
+        $page->param(block2 => $webvar{block2});
+      }
+    }
+  }
+
+  $page->param(ip => $webvar{ip});
+}
+print $page->output;
Index: /trunk/dnsbl/dnsbl.sql
===================================================================
--- /trunk/dnsbl/dnsbl.sql	(revision 3)
+++ /trunk/dnsbl/dnsbl.sql	(revision 3)
@@ -0,0 +1,104 @@
+--
+-- PostgreSQL database dump
+--
+
+SET client_encoding = 'UTF8';
+SET check_function_bodies = false;
+SET client_min_messages = warning;
+
+--
+-- Name: SCHEMA public; Type: COMMENT; Schema: -; Owner: postgres
+--
+
+COMMENT ON SCHEMA public IS 'Standard public schema';
+
+
+SET search_path = public, pg_catalog;
+
+SET default_tablespace = '';
+
+SET default_with_oids = false;
+
+--
+-- Name: blocks; Type: TABLE; Schema: public; Owner: dnsbl; Tablespace: 
+--
+
+CREATE TABLE blocks (
+    block cidr NOT NULL,
+    listme boolean DEFAULT false,
+    orgid integer,
+    "level" integer DEFAULT 0,
+    comments text DEFAULT ''::text
+);
+
+
+--
+-- Name: iplist; Type: TABLE; Schema: public; Owner: dnsbl; Tablespace: 
+--
+
+CREATE TABLE iplist (
+    ip inet NOT NULL,
+    count integer DEFAULT 1,
+    s4list boolean DEFAULT false,
+    added timestamp with time zone DEFAULT now()
+);
+
+
+--
+-- Name: orgs; Type: TABLE; Schema: public; Owner: dnsbl; Tablespace: 
+--
+
+CREATE TABLE orgs (
+    orgid serial NOT NULL,
+    listme boolean DEFAULT false,
+    orgname character varying(100) DEFAULT ''::character varying NOT NULL,
+    comments text
+);
+
+
+--
+-- Name: blocks_pkey; Type: CONSTRAINT; Schema: public; Owner: dnsbl; Tablespace: 
+--
+
+ALTER TABLE ONLY blocks
+    ADD CONSTRAINT blocks_pkey PRIMARY KEY (block);
+
+
+--
+-- Name: iplist_pkey; Type: CONSTRAINT; Schema: public; Owner: dnsbl; Tablespace: 
+--
+
+ALTER TABLE ONLY iplist
+    ADD CONSTRAINT iplist_pkey PRIMARY KEY (ip);
+
+
+--
+-- Name: orgs_pkey; Type: CONSTRAINT; Schema: public; Owner: dnsbl; Tablespace: 
+--
+
+ALTER TABLE ONLY orgs
+    ADD CONSTRAINT orgs_pkey PRIMARY KEY (orgid);
+
+
+--
+-- Name: blocks_orgid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: dnsbl
+--
+
+ALTER TABLE ONLY blocks
+    ADD CONSTRAINT blocks_orgid_fkey FOREIGN KEY (orgid) REFERENCES orgs(orgid);
+
+
+--
+-- Name: public; Type: ACL; Schema: -; Owner: postgres
+--
+
+REVOKE ALL ON SCHEMA public FROM PUBLIC;
+REVOKE ALL ON SCHEMA public FROM postgres;
+GRANT ALL ON SCHEMA public TO postgres;
+GRANT ALL ON SCHEMA public TO PUBLIC;
+
+
+--
+-- PostgreSQL database dump complete
+--
+
Index: /trunk/dnsbl/export-dnsbl
===================================================================
--- /trunk/dnsbl/export-dnsbl	(revision 3)
+++ /trunk/dnsbl/export-dnsbl	(revision 3)
@@ -0,0 +1,85 @@
+#!/usr/bin/perl
+# Export DNSBL data
+# 2009/05/26 kdeugau@deepnet.cx
+# need to stub it out so it can use a module to actually write zone
+# data for different NS software
+# completed 2008/08/14
+
+use strict;
+use warnings;
+use DBI;
+
+use DNSBL;
+
+my $dnsbl = new DNSBL;
+
+$dnsbl->connect;
+
+my %iplist;
+my $ipref = \%iplist;
+
+my $mode = $ARGV[0] || 'tiny';
+
+#$dnsbl->export($ipref,$mode,1,'65.60/18');
+#$dnsbl->export($ipref,$mode,1,'67.136.0.0/14');
+#$dnsbl->export($ipref,$mode,1,'83.76/15');
+#$dnsbl->export($ipref,$mode,1,'76.73.0.0/17');
+#$dnsbl->export($ipref,$mode,1,'174.36.0.0/15');
+$dnsbl->export($ipref,$mode);
+
+##fixme - mode should pick actual output, not just export mode
+if ($mode eq 'cidr') {
+  # more or less raw CIDR block-and-IP info
+  foreach (sort ipcmp keys %iplist) {
+    print "$_:127.0.0.$iplist{$_}:".
+	($iplist{$_} & 2 ? '$ relayed a reported spam' : 'Netblock listed on one or more criteria')."\n";
+  }
+} elsif ($mode eq 'rbldnsd') {
+  # need extra cmd args
+  die "need subgroup spec (iplist, cidrlist) as well\n" if !$ARGV[1];
+  if ($ARGV[1] eq 'iplist') {
+    foreach (sort ipcmp keys %iplist) {
+      print "$_:127.0.0.$iplist{$_}:\$ relayed a reported spam\n" if $iplist{$_} & 2;
+    }
+  } elsif ($ARGV[1] eq 'cidrlist') {
+    foreach (sort ipcmp keys %iplist) {
+      print "$_:127.0.0.$iplist{$_}:Netblock listed on one or more criteria\n" if ! ($iplist{$_} & 2);
+    }
+  }
+  # no output if second arg is unknown.
+} else {
+  foreach (sort ipcmp keys %iplist) {
+#foreach (sort keys %iplist) {
+    my ($o1,$o2,$o3,$o4) = (/^(\d+)\.([\d*]+)(?:\.([\d*]+)(?:\.([\d*]+))?)?$/);
+    print "+".(defined($o4) ? "$o4." : '').(defined($o3) ? "$o3." : '').(defined($o2) ? "$o2." : '').
+	"$o1.spamhosts.company.com:127.0.0.$iplist{$_}:900:::\n";
+  }
+}
+
+exit 0;
+
+# IP address comparison sub
+sub ipcmp {
+  my ($a1,$a2,$a3,$a4,$a5) = ($a =~ /^(\d+)\.([\d*]+)(?:\.([\d*]+)(?:\.([\d*]+))?)?(?:\/(\d+))?$/);
+  my ($b1,$b2,$b3,$b4,$b5) = ($b =~ /^(\d+)\.([\d*]+)(?:\.([\d*]+)(?:\.([\d*]+))?)?(?:\/(\d+))?$/);
+# le sigh.  knew it wasn't going to be simple...
+  $b2 = -1 if $b2 && $b2 eq '*';
+  $b3 = -1 if $b3 && $b3 eq '*';
+  $b4 = -1 if $b4 && $b4 eq '*';
+  $b5 = 128 if !defined($b5);
+  $a2 = -1 if $a2 && $a2 eq '*';
+  $a3 = -1 if $a3 && $a3 eq '*';
+  $a4 = -1 if $a4 && $a4 eq '*';
+  $a5 = 128 if !defined($a5);
+  return 1 if $a1 > $b1;
+  return -1 if $a1 < $b1;
+  return 1 if $a2 > $b2;
+  return -1 if $a2 < $b2;
+  return 1 if $a3 > $b3;
+  return -1 if $a3 < $b3;
+  return 1 if $a4 > $b4;
+  return -1 if $a4 < $b4;
+  return 1 if $a5 > $b5;
+  return -1 if $a5 < $b5;
+  return 0;
+}
Index: /trunk/dnsbl/extract-data
===================================================================
--- /trunk/dnsbl/extract-data	(revision 3)
+++ /trunk/dnsbl/extract-data	(revision 3)
@@ -0,0 +1,315 @@
+#!/usr/bin/perl
+# Extract relay IP, URI hosts from mail in folder
+# Hack-n-patch from:
+# Heavily reworked from original:
+# dmz@dmzs.com - March 19, 2004
+# http://www.dmzs.com/tools/files/spam.phtml
+# LGPL
+# by:
+# Kris Deugau <kdeugau@deepnet.cx> 2009/01/21
+# Kris Deugau <kdeugau@deepnet.cx> 2009/05/19
+##wrapreq libmail-imapclient-perl (>=3.11), libio-socket-ssl-perl, install-sa
+##wrapver 0.1
+##wrapsum Extract relay IP and URI hosts from mail in IMAP folder
+# $Id$
+# $URL$
+
+use strict;
+use warnings;
+use Time::Local;
+use POSIX qw(strftime);
+use IO::Socket::SSL;
+use Mail::IMAPClient;
+use Getopt::Std;
+use NetAddr::IP;
+
+# hmm. can't make (enough) sense of the docs.  gonna have to parse headers for IPs myself...  :/
+# but we did find enough to extract the URIs...
+use lib '/opt/spamassassin/share/perl/5.8.8';
+use Mail::SpamAssassin;
+use Mail::SpamAssassin::PerMsgStatus;
+
+my %opts;
+getopts("druv", \%opts);
+
+my $debug = ($opts{d} ? 1 : 0);
+my $sadebug = 0;	# sa-learn -D spits out a LOT of useless crap - better to only activate if specifically needed
+my $imapdebug = 0;	# so does Mail::IMAPClient...  as in, the whole content of all the mail you look at.  O_o
+my $delete_after_learning = 0;	# set to 1 if you want to delete mail right away after learning
+				# - note this makes it rather harder to deep-scan the messages to create local rules
+my $verbose = ($opts{v} ? 1 : 0);
+
+my $tmpdir = '/var/tmp';
+my $salearn = '/usr/local/bin/sa-learn';
+my $learnargs = ($sadebug ? ' -D' : '').' --showdots ';
+
+die "eeep!  $salearn doesn't exist!\n" if ! -e $salearn;
+
+my $folder = 'reported.needsextraction';
+#my $folder = 'confirmed';
+
+# non-SSL IMAP settings:
+#my $imap = Mail::IMAPClient->new( Server=> 'imapmailhost:143',
+#                                  User => 'imapspamuser',
+#                                  Password => 'imapspamuserpassword',
+#                                  Debug => $imapdebug);
+
+my $imap = Mail::IMAPClient->new(
+	User => 'junkmail', 
+	Password => 'k3c86z2',
+	Socket   => IO::Socket::SSL->new(
+		Proto    => 'tcp',
+		PeerAddr => 'mail.company.com',
+		PeerPort => 993, # IMAP over SSL standard port
+		),
+	Debug => $imapdebug,
+	);
+
+if (!defined($imap)) { die "IMAP Login Failed"; }
+
+my $msgcount = $imap->message_count($folder);
+
+# If debugging, print out the total counts for each mailbox
+print $msgcount, " message(s) to process\n" if $debug;
+
+## Process the spam mailbox
+$imap->select($folder);
+my @msgs = $imap->search("ALL");
+
+# Since the data goes into files anyway, why not make a mockery of a maildir and let sa-learn iterate over it?
+#my $spamtmp = "$tmpdir/spam.".time.".$$";  # this should give us a suitably pseudorandom directory
+#mkdir $spamtmp or die "couldn't create temporary pen for spam: $!";
+
+my $spamtest = Mail::SpamAssassin->new();
+  # don't keep dereferencing this
+
+my %iplist;
+my %urilist;
+
+for (my $i=0; $i<$msgcount; $i++) {
+  my $msg = $imap->message_string($msgs[$i]);
+
+  my $mail = $spamtest->parse($msg);
+  my $status = $spamtest->check($mail);
+
+# stolen from SA plugin bits
+#sub parsed_metadata {
+#  my ($self, $opts) = @_;
+#  my $scanner = $status->{permsgstatus};
+
+  my $skip_domains = $status->{main}->{conf}->{uridnsbl_skip_domains};
+
+  # Generate the full list of html-parsed domains.
+  my $uris = $status->get_uri_detail_list();
+
+#  print "$msgs[$i]\n";
+  my %msguris;
+
+  while (my($uri, $info) = each %{$uris}) {
+    # we want to skip mailto: uris
+    next if ($uri =~ /^mailto:/);
+
+    # no domains were found via this uri, so skip
+    next unless ($info->{domains});
+
+    next if $info->{types}->{img};
+    foreach ( keys %{ $info->{domains} } ) {
+      if (exists $skip_domains->{$_}) {
+        next;
+      }
+      $msguris{$_}++;
+      #print "  ".$_."\n";
+    }
+
+  #  print "$uri ".$info->{anchor_text}."\n";
+  }
+
+  foreach (keys %msguris) {
+#    print "  $_ $msguris{$_}\n";
+    $urilist{$_}++;
+  }
+
+  # now, get the relay IP
+
+  my %headerlist = %{$imap->parse_headers($msgs[$i], "Received")};
+  my $recvnum = 0;
+  my $recv = $headerlist{'Received'}[$recvnum];
+  next if !$recv;
+
+  my $relayip;
+
+  #Received: from mail.company.com [ip.add.re.ss]
+  #        by localhost with POP3 (fetchmail-6.2.5)
+  #        for kdeugau@localhost (single-drop); Fri, 15 May 2009 11:45:10 -0400 (EDT)
+  if ($recv =~ /from mail\.company\.com \[ip\.add\.re\.ss\]\s*by localhost with POP3 \(fetchmail/) {
+    $recvnum += 1;
+    $recv = $headerlist{'Received'}[$recvnum];
+  }
+
+  if ($recv =~ /^by mx\d\.company\.com \(Postfix, from userid \d+\)/) {
+    $recvnum++;
+    $recv = $headerlist{'Received'}[$recvnum];
+  }
+
+# le sigh.  gotta bypass a message if we can't parse the headers.  Outlook
+# does an admirable job of mangling things for us.  >:(
+  if ($recv !~ /by mx\d\.company\.com \(Postfix\)/) {
+    print "phtui:  $recv\n";
+    next;
+  }
+
+##fixme
+# le sigh.  skip IP extraction on tagged spam reported as nonspam, since the real spam is a layer deeper.
+next if $recv =~ /from localhost by mfs\d with SpamAssassin/;
+
+# Postini puts the "real" received: header one layer further out - SA is configured to compensate for this so we do too
+  #IP-Network                    64.18.0.0/20
+  #IP-Network-Block              064.018.000.000 - 064.018.015.255
+  #Org-Name                      Postini, Inc.
+  if ($recv =~ /\[64\.18\.(?:[0-9]|1[0-5])\.\d+]\) by mx\d\.company\.com/) {
+    $recv = $recv = $headerlist{'Received'}[++$recvnum];
+#Received: from source ([208.95.48.65]) (using TLSv1) by
+# exprod5mx230.postini.com ([64.18.4.10]) with SMTP; Fri, 10 Jul 
+    my ($tmprelayip) = ($recv =~ /from source \(\[([\d.]+)\]\) (?:\(using TLSv1\) )?by exprod\dm[xo]b?\d+\.postini\.com/);
+    $relayip = new NetAddr::IP $tmprelayip;
+  } else {
+    my ($tmprelayip) = ($recv =~ /\[([\d+.]+)\]\) by mx\d\.company\.com/);
+    $relayip = new NetAddr::IP $tmprelayip;
+  }
+
+# Hotmail/Windows Live Mail may originate or relay spam, but we can't blacklist them
+  #Received: from blu0-omc4-s23.blu0.hotmail.com (blu0-omc4-s23.blu0.hotmail.com
+  # [65.55.111.162]) by mx2.company.com (Postfix)
+#  next if $recv =~ /from (?:bay|blu|col|snt)0-omc\d+-s\d+\.(?:bay|blu|col|snt)0\.hotmail\.com 
+\((?:bay|blu|col|snt)0-omc\d+-s\d+\.(?:bay|blu|col|snt)0\.hotmail\.com \[65.5[2345].\d+\.\d+\]\) by mx\d\.company\.com/;
+  #IP-Network                    65.52.0.0/14
+  #IP-Network-Block              065.052.000.000 - 065.055.255.255
+  #Org-Name                      Microsoft Corp
+  my $hotmail1 = new NetAddr::IP "65.52.0.0/14";
+print "$.: $recv\n" if !defined ($relayip);
+  next if $relayip->within($hotmail1);
+
+# AOL may originate or relay spam, but we can't blacklist them
+  #Received: from omr-m33.mx.aol.com (omr-m33.mx.aol.com [64.12.143.145]) by
+  # mx1.company.com (Postfix) with ESMTP id 7B9431C3255 for <webmaster@tyenet.com>;
+  next if $recv =~ /from (?:omr|imo)-[dm]\d+\.mx\.aol\.com \((?:omr|imo)-[dm]\d+\.mx\.aol\.com \[[\d.]+\]\) by mx\d\.company\.com/;
+
+# Google may relay spam, GMail may originate it, but we can't blacklist them.
+  #IP-Network                    209.85.128.0/17
+  #IP-Network-Block              209.085.128.000 - 209.085.255.255
+  #Org-Name                      Google Inc.
+  next if $recv =~ /\[209\.85\.(?:1(?:2[89]|[3-9]\d)|2(?:[0-4]\d|5[0-5]))\.\d+\]\) by mx\d\.company\.com/;
+  #OrgName:    Google Inc.
+  #NetRange:   72.14.192.0 - 72.14.255.255
+  #CIDR:       72.14.192.0/18
+  next if $recv =~ /\[72\.14\.(?:19[2-9]|2(?:[0-4]\d|5[0-5]))\.\d+\]\) by mx\d\.company\.com/;
+
+# Yahoo! may ... yadda yadda yadda  (geeze they've got a whack of netblocks for mail...)
+  #IP-Network                    98.136.0.0/14
+  #IP-Network-Block              098.136.000.000 - 098.139.255.255
+  #Org-Name                      Yahoo! Inc.
+  my $yahoo1 = new NetAddr::IP "98.136.0.0/14";
+  next if $relayip->within($yahoo1);
+  #IP-Network                    66.196.64.0/18
+  #IP-Network-Block              066.196.064.000 - 066.196.127.255
+  #Org-Name                      Inktomi Corporation
+  # Inktomi ~~ Yahoo!
+  my $yahoo2 = new NetAddr::IP "66.196.64.0/18";
+  next if $relayip->within($yahoo2);
+  #IP-Network                    67.195.0.0/16
+  #IP-Network-Block              067.195.000.000 - 067.195.255.255
+  #Org-Name                      Yahoo! Inc.
+  my $yahoo3 = new NetAddr::IP "67.195.0.0/16";
+  next if $relayip->within($yahoo3);
+  #IP-Network                    69.147.64.0/18
+  #IP-Network-Block              069.147.064.000 - 069.147.127.255
+  #Org-Name                      Yahoo! Inc.
+  my $yahoo4 = new NetAddr::IP "69.147.64.0/18";
+  next if $relayip->within($yahoo4);
+  #IP-Network                    206.190.32.0/19
+  #IP-Network-Block              206.190.032.000 - 206.190.063.255
+  #Org-Name                      Yahoo! Broadcast Services, Inc.
+  my $yahoo5 = new NetAddr::IP "206.190.32.0/18";
+  next if $relayip->within($yahoo5);
+  #IP-Network                    68.142.192.0/18
+  #IP-Network-Block              068.142.192.000 - 068.142.255.255
+  #Org-Name                      Inktomi Corporation
+  my $yahoo6 = new NetAddr::IP "68.142.192.0/18";
+  next if $relayip->within($yahoo6);
+  #IP-Network                    216.252.96.0/19
+  #IP-Network-Block              216.252.096.000 - 216.252.127.255
+  #Org-Name                      Yahoo! Inc.
+  my $yahoo7 = new NetAddr::IP "216.252.96.0/19";
+  next if $relayip->within($yahoo7);
+  #inetnum:      124.83.128.0 - 124.83.255.255
+  #descr:        Yahoo! Japan
+  my $yahoo8 = new NetAddr::IP "124.83.128.0/17";
+  next if $relayip->within($yahoo8);
+
+# and the same goes for Bell Canada.  *le sigh*
+#IP-Network                    209.226.0.0/16
+#IP-Network-Block              209.226.000.000 - 209.226.255.255
+#Org-Name                      Bell Canada
+#Received: from tomts35-srv.bellnexxia.net (tomts35.bellnexxia.net
+# [209.226.175.109]) by mx2.company.com (Postfix) with ESMTP id B415C16752D for
+# <user@compnay.com>; Sat,  4 Jul 2009 10:48:24 -0400 (EDT)
+# hmm.  tomts\d(-srv)?.bellnexxia.net only seem to be in .175/24.  we'll just drop those ones for now...
+# especially since there appear to be hosted customers etc in the same ARIN allocation above.
+  my $bell1 = new NetAddr::IP "209.226.175.0/24";
+  next if $relayip->within($bell1);
+#  next if $recv =~ /\[209\.226\.175\.\d+\] by mx\d\.company\.com/;
+
+# ... and your little dog too!
+#IP-Network                    208.82.236.0/22
+#IP-Network-Block              208.082.236.000 - 208.082.239.255
+#Org-Name                      Craigslist, Inc.
+  my $craigslist1 = new NetAddr::IP "208.82.236.0/22";
+  next if $relayip->within($craigslist1);
+
+  $iplist{$relayip->addr}++ if $relayip;
+#  print "$recv\n";
+#  print "$relayip\n\n";
+#  print $imap->get_header($msgs[$i], "From"); print "\n";
+
+
+#  last if $i > 15;
+  sleep 1;
+} # IMAP message iteration
+
+# mm.  don't really need times on the IP lists
+#if ($opts{r}) {
+#  print strftime("# %Y/%m/%d %H:%M", localtime())."\n";
+#}
+foreach my $ip (sort keys %iplist) {
+  $ip =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/;
+  if ($opts{r}) {
+    print "+$4.$3.$2.$1.spamhosts.company.com:127.0.0.2:900:::\n";
+  } else {
+    print "$ip\t $iplist{$ip}\n";
+  }
+}
+
+if ($opts{u}) {
+  print strftime("# %Y/%m/%d %H:%M", localtime())."\n";
+}
+foreach my $uri (sort keys %urilist) {
+  if ($opts{u}) {
+    my @hout = qx { host $uri.multi.uribl.com; host $uri.uribl.company.com };
+    if ($hout[0] =~ /NXDOMAIN/ && $hout[1] =~ /NXDOMAIN/) {
+      print "+$uri.uribl.company.com:127.0.0.2:900:::\n";
+    }
+  } else {
+    # URI plus count
+    print "$uri: $urilist{$uri}\n";
+  }
+}
+
+$imap->close();
+
+# Close IMAP connection cleanly.
+$imap->logout();
+
+# integrate learned stuff - journal sync etc IFF bayes_journal is set AND you want to sync right away
+# irrelevant for SQL Bayes
+#my $sarebuild = `/usr/bin/sa-learn --rebuild`;
+#print "-------\nRebuild: ",$sarebuild,"\n-------\n" if $debug;
Index: /trunk/dnsbl/import-cur.cgi
===================================================================
--- /trunk/dnsbl/import-cur.cgi	(revision 3)
+++ /trunk/dnsbl/import-cur.cgi	(revision 3)
@@ -0,0 +1,34 @@
+#!/usr/bin/perl
+# import current zone data
+
+use strict;
+use warnings;
+
+use DNSBL;
+
+print "Content-type: text/plain\n\n";
+
+my $dnsbl = new DNSBL;
+$dnsbl->connect;
+
+open EXISTING, "<spamhosts.company.com";
+
+while (<EXISTING>) {
+  next if /^#/;
+  next if /^\s*$/;
+  next if /^\+\*\./;
+  if ($_ !~ /^\+(\d+)\.(\d+)\.(\d+)\.(\d+)\.spamhosts.company.com:127.0.0.(\d+):/) {
+    print;
+    next;
+  }
+  my $ip = "$4.$3.$2.$1";  my $bitfield = 0+$5;
+  next if $dnsbl->ipexists($ip);
+  if ($bitfield & 2) {
+    print "$ip\tlisted\t".
+	($bitfield & 4 ? 'block' : '')."\t".
+	($bitfield & 8 ? 'upstr' : '')."\t".
+	($bitfield & 16 ? 'OOB' : '')."\n";
+  }
+  print "$ip\t**moron listing**\n" if $bitfield & 128;
+#  last if $. > 180;
+}
Index: /trunk/dnsbl/index.shtml
===================================================================
--- /trunk/dnsbl/index.shtml	(revision 3)
+++ /trunk/dnsbl/index.shtml	(revision 3)
@@ -0,0 +1,1 @@
+<!--#include virtual="/dnsbl.cgi" -->
Index: /trunk/dnsbl/orgmove
===================================================================
--- /trunk/dnsbl/orgmove	(revision 3)
+++ /trunk/dnsbl/orgmove	(revision 3)
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+# move blocks listed with one org to another.  intended for orgs that have several bytestrings as names in WHOIS.
+
+use strict;
+use warnings;
+use DBI;
+
+use DNSBL;
+
+my $dnsbl = new DNSBL;
+
+my $dbh = $dnsbl->connect;
+
+$dbh->{AutoCommit} = 0;
+
+my $sth1 = $dbh->prepare("update blocks set orgid=? where orgid=?");
+my $sth2 = $dbh->prepare("delete from orgs where orgid=?");
+
+print "updating orgid $ARGV[0] to $ARGV[1]...\n";
+$sth1->execute($ARGV[1],$ARGV[0]) or die "died horribly: $!\n";
+print "failed org change ($ARGV[0] -> $ARGV[1]): ".$sth1->errstr."\n" if $sth1->err;
+$sth2->execute($ARGV[0]);
+print "failed org delete ($ARGV[0]): ".$sth2->errstr."\n" if $sth2->err;
+
+$dbh->commit;
Index: /trunk/dnsbl/templates/browse.tmpl
===================================================================
--- /trunk/dnsbl/templates/browse.tmpl	(revision 3)
+++ /trunk/dnsbl/templates/browse.tmpl	(revision 3)
@@ -0,0 +1,83 @@
+<html><head><title>show all IPs and listing status</title>
+<style>
+<!--
+.lvl0 {
+  background: #99ff99;
+  border: 1px solid #000000;
+  margin: 2px;
+  padding: 2px;
+  width: 600px;
+}
+.auto0 {
+  background: #ffffcc;
+}
+.b0list {
+  background: #ffcc99;
+  border: 1px solid #000000;
+  margin: 1px;
+}
+.b0org {
+  background: #ffcccc;
+  border: 1px solid #000000;
+  margin: 1px;
+}
+.lvl1 {
+  background: #33ff33;
+  border: 1px solid #000000;
+  margin: 2px;
+  padding: 2px;
+  position: relative;
+  left: 150px;
+  top: 0px;
+  width: 450px;
+}
+.auto1 {
+  background: #ffff00;
+}
+.b1list {
+  background: #ff9900;
+  border: 1px solid #000000;
+  margin: 1px;
+}
+.b1org {
+  background: #ff0000;
+  border: 1px solid #000000;
+  margin: 1px;
+}
+.lvl2 {
+  background: #009900;
+  border: 1px solid #000000;
+  margin: 2px;
+  padding: 2px;
+  position: relative;
+  left: 150px;
+  top: 0px;
+  width: 300px;
+}
+.auto2 {
+  background: #999900;
+}
+.b2list {
+  background: #cc6600;
+  border: 1px solid #000000;
+  margin: 1px;
+}
+.b2org {
+  background: #990000;
+  border: 1px solid #000000;
+  margin: 1px;
+}
+.iplist {
+  background: #00ffff;
+  border: 1px solid #000000;
+  margin: 2px;
+  padding: 2px;
+  position: relative;
+  left: 150px;
+  top: 0px;
+  width: 150px;
+}
+-->
+</style>
+</head>
+<body>
Index: /trunk/dnsbl/templates/dbreport.tmpl
===================================================================
--- /trunk/dnsbl/templates/dbreport.tmpl	(revision 3)
+++ /trunk/dnsbl/templates/dbreport.tmpl	(revision 3)
@@ -0,0 +1,15 @@
+<html>
+<head>
+<title>added <TMPL_VAR NAME=ip></title>
+</head>
+<body>
+added <TMPL_VAR NAME=ip>
+<TMPL_IF org0><br>added <TMPL_VAR NAME=org0></TMPL_IF>
+<TMPL_IF block0><br>added level 0 block <TMPL_VAR NAME=block0></TMPL_IF>
+<TMPL_IF org1><br>added <TMPL_VAR NAME=org1></TMPL_IF>
+<TMPL_IF block1><br>added level 1 block <TMPL_VAR NAME=block1></TMPL_IF>
+<TMPL_IF org2><br>added <TMPL_VAR NAME=org2></TMPL_IF>
+<TMPL_IF block2><br>added level 2 block <TMPL_VAR NAME=block2></TMPL_IF>
+<hr><a href="/">Back</a>
+</body>
+</html>
Index: /trunk/dnsbl/templates/index.tmpl
===================================================================
--- /trunk/dnsbl/templates/index.tmpl	(revision 3)
+++ /trunk/dnsbl/templates/index.tmpl	(revision 3)
@@ -0,0 +1,14 @@
+<html>
+<head>
+<title>DNSBL database</title>
+</head>
+<body>
+<table>
+<form action="dnsbl.cgi"><input type=hidden name=page value=report>
+<tr><td>Enter an IP:</td>
+<td><input name=ip></td></tr>
+<tr><td><input type=submit></td></tr>
+</form>
+</table>
+</body>
+</html>
Index: /trunk/dnsbl/templates/report.tmpl
===================================================================
--- /trunk/dnsbl/templates/report.tmpl	(revision 3)
+++ /trunk/dnsbl/templates/report.tmpl	(revision 3)
@@ -0,0 +1,47 @@
+<html>
+<head>
+<title>adding <TMPL_VAR NAME=ip></title>
+</head>
+<body>
+<table border=1><tr><td>
+adding <TMPL_VAR NAME=ip></td></tr>
+<form action="dnsbl.cgi">
+<input type=hidden name=page value=dbreport>
+<input type=hidden name=ip value=<TMPL_VAR NAME=ip>>
+
+<tr><td>Registrar delegation</td></tr>
+<tr>
+<td>Netblock:</td>
+<td><input name=block0 value="<TMPL_VAR block0>" size=40></td>
+</tr>
+<tr>
+<td>Org/Person:</td>
+<td><input name=org0 value="<TMPL_VAR org0>" size=40></td>
+</tr>
+
+<tr><td>1st subdelegation</td></tr>
+<tr>
+<td>Netblock:</td>
+<td><input name=block1 value="<TMPL_VAR block1>" size=40></td>
+</tr>
+<tr>
+<td>Org/Person:</td>
+<td><input name=org1 value="<TMPL_VAR org1>" size=40></td>
+</tr>
+
+<tr><td>2nd subdelegation</td></tr>
+<tr>
+<td>Netblock:</td>
+<td><input name=block2 value="<TMPL_VAR block2>" size=40></td>
+</tr>
+<tr>
+<td>Org/Person:</td>
+<td><input name=org2 value="<TMPL_VAR org2>" size=40></td>
+</tr>
+
+<tr><td><input type=submit></td></tr>
+
+</form>
+</table>
+</body>
+</html>
