source: trunk/dnsbl/DNSBL.pm@ 40

Last change on this file since 40 was 40, checked in by Kris Deugau, 12 years ago

/trunk/dnsbl

Minor cleanups to prepare for semirelease
GPL-tag executables and Perl module from Makefile MANIFEST
  • Property svn:keywords set to Date Rev Author Id
File size: 15.8 KB
Line 
1# DNSBL
2# Functions for interacting with the DNSBL database
3##
4# $Id: DNSBL.pm 40 2012-03-04 20:02:13Z kdeugau $
5# Copyright 2009-2011 Kris Deugau <kdeugau@deepnet.cx>
6#
7# This program is free software: you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation, either version 3 of the License, or
10# (at your option) any later version.
11#
12# This program is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with this program. If not, see <http://www.gnu.org/licenses/>.
19##
20
21package DNSBL;
22
23use strict;
24use warnings;
25use Exporter;
26use DBI;
27use NetAddr::IP;
28
29use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
30
31$VERSION = 2.1;
32@ISA = qw(Exporter);
33@EXPORT_OK = qw(
34 );
35
36@EXPORT = (); # Export nothing by default.
37%EXPORT_TAGS = ( ALL => [qw(
38 )]
39 );
40
41## "constants"
42
43# w00t! somewhere along the line, by accident or intent, SA's
44# check_dnsbl_sub can now check up to 24 bits of an DNSBL return value!
45# 1 not available so we don't $self->shoot(foot)
46our %bitfields = (
47 # block levels
48 0 => 16,
49 1 => 8,
50 2 => 4,
51 # ip
52 ip => 2,
53 # OOB
54 org0 => 32,
55 block0 => 64,
56 org1 => 256,
57 org2 => 512,
58 block1 => 1024,
59 block2 => 2048,
60 # "I'm a total spamming moron!" - per-IP only!
61 slist => 128
62);
63
64# probably needs some tuning; even 7 hits in a /24 is a pretty small percentage
65# number of IPs in a block of the given masklength needed to have that block automatically listed
66# defaults: (overridden by entries in db:autolist)
67our %autolist = (
68 31 => 1,
69 30 => 1,
70 29 => 2,
71 28 => 3,
72 27 => 4,
73 26 => 5,
74 25 => 6,
75 24 => 7,
76 23 => 8,
77 22 => 10,
78 21 => 13,
79 20 => 16,
80 19 => 19,
81 18 => 22,
82 17 => 26,
83 16 => 30,
84 15 => 34,
85 14 => 38,
86 13 => 42,
87 12 => 46,
88 11 => 50,
89 10 => 54,
90 9 => 58,
91 8 => 62,
92 7 => 2**31,
93 6 => 2**31,
94 5 => 2**31,
95 4 => 2**31,
96 3 => 2**31,
97 2 => 2**31,
98 1 => 2**31,
99 0 => 2**31
100);
101
102# le sigh. constants for masklength iterationing
103our @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);
104
105# variables
106our $dbh;
107
108our $err;
109our $errstr;
110
111# basic object subs
112sub new {
113# iff we want to start taking arguments, or doing other things on instantiation
114# my $self = {};
115# bless $self, "DNSBL";
116# return $self;
117 bless {};
118}
119
120sub DESTROY {
121 my $self = shift;
122 $self->dbclose() if $dbh;
123}
124
125# JIC someone wants to close the db but not finish the script
126sub dbclose {
127 $dbh->rollback;
128 $dbh->disconnect;
129}
130
131## specific object subs:
132
133sub connect {
134 my $self = shift;
135 my $dbhost = shift;
136 my $dbname = shift;
137 my $dbuser = shift;
138 my $dbpass = shift;
139 ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
140 $dbh = DBI->connect("DBI:Pg:host=$dbhost;dbname=$dbname", $dbuser, $dbpass, {
141 AutoCommit => 0,
142 PrintError => 1
143 })
144 or die "database inaccessible: ".$DBI::errstr;
145 my $sth = $dbh->prepare("SELECT masklen,ipcount FROM autolist");
146 $sth->execute;
147 while (my ($masklen,$ipcount) = $sth->fetchrow_array) {
148 $autolist{$masklen} = $ipcount;
149 }
150 return $dbh;
151}
152
153
154## DNSBLDB::initexport()
155# Prepare a couple of statement handles for later processing in export(). Assists in ~3x speed increase.
156my $parsth;
157my $sthmoron;
158sub initexport {
159 $parsth = $dbh->prepare("SELECT count(i.ip),b.block,b.level,b.listme AS oobblock,o.listme AS ooborg ".
160 "FROM iplist i INNER JOIN blocks b ON i.parent = b.block INNER JOIN orgs o ON b.orgid = o.orgid ".
161 "WHERE b.block >>= ? ".
162 "GROUP BY b.block,b.level,b.listme,o.listme ORDER BY b.block");
163 $sthmoron = $dbh->prepare("SELECT ip,s4list FROM iplist WHERE parent = ?");
164}
165
166
167## DNSBL::ipexists()
168# return report count if the IP has been reported, otherwise return undef
169sub ipexists {
170 my $self = shift;
171 my $ip = shift;
172 my $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
173 $sth->execute($ip);
174 my ($ret) = $sth->fetchrow_array();
175 return $ret;
176} # end ipexists()
177
178
179# report an IP or URI to the db
180# increments a hit counter iff the reported IP or URI exists, otherwise it adds it
181sub report {
182 my $self = shift;
183 my $rep = shift;
184 my $sth;
185 my $rows = 0;
186 if ($rep =~ /^[\d.]+$/) {
187 # weesa gonna ASS-U-ME IP addresses are sanely formatted.
188 eval {
189 $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
190 $sth->execute($rep) or die "eep? ".$dbh->errstr."\n";
191 $rows = $sth->rows;
192 if ($rows == 0) {
193 $sth = $dbh->prepare("INSERT INTO iplist (ip,parent) VALUES ".
194 "(?,(SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1))");
195 $sth->execute($rep,$rep) or die "couldn't add entry for $rep: ".$dbh->errstr."\n";
196 } elsif ($rows == 1) {
197 $sth = $dbh->prepare("UPDATE iplist SET count=count+1 WHERE ip=?");
198 $sth->execute($rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
199 } else {
200 die "db corrupt: found $rows matches on $rep\n";
201 }
202 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ?");
203 $sth->execute($rep);
204 my $updsth = $dbh->prepare("UPDATE blocks SET ipcount=(SELECT count(*) FROM iplist WHERE ip << ?) WHERE block=?");
205 while (my ($block) = $sth->fetchrow_array) {
206 $updsth->execute($block,$block);
207 }
208 $dbh->commit;
209 };
210 if ($@) {
211 my $msg = $@;
212 return "failed adding $rep: $msg";
213 }
214 } else {
215 return;
216 }
217 return $rows;
218} # end report()
219
220
221# add a new org
222# return the orgid
223# if the org exists, return the orgid anyway
224sub addorg {
225 my $self = shift;
226 my $orgname = shift;
227 my $listme = shift || 'n';
228 my $ret = $self->orgexists($orgname);
229 return $ret if $ret;
230 my $sth = $dbh->prepare("INSERT INTO orgs (orgname,listme) VALUES (?,?)");
231 $sth->execute($orgname,$listme) or die "couldn't add org $orgname: ".$dbh->errstr."\n";
232 $dbh->commit;
233 $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
234 $sth->execute($orgname);
235 my ($orgid) = $sth->fetchrow_array();
236 return $orgid;
237} # end addorg
238
239
240# checks for existence - nb, exact match! No way to really handle anything else. :/
241sub orgexists {
242 my $self = shift;
243 my $org = shift;
244 my $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
245 $sth->execute($org);
246 my ($ret) = $sth->fetchrow_array();
247 return $ret;
248} # end orgexists();
249
250
251# add a block. requires the orgid
252##fixme needs error handling
253sub addblock {
254 my $self = shift;
255 my $blockin = shift;
256 my $orgid = shift;
257 my $level = shift;
258 $blockin =~ s/^\s+//;
259 $blockin =~ s/\s+$//;
260 my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
261
262 return "$blockin not a single CIDR range" if !$block;
263
264# local $dbh->{AutoCommit} = 1; # force autocommit
265
266 my $sth;
267 eval {
268 my $parent = '0/0';
269 if ($level > 0) {
270 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
271 $sth->execute("$block");
272 ($parent) = $sth->fetchrow_array;
273 }
274 $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level,parent,ipcount) VALUES (?,?,?,?,".
275 "(SELECT count(*) FROM iplist WHERE ip << ?))");
276 $sth->execute("$block",$orgid,$level,$parent,"$block");
277 $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
278 $sth->execute("$block",$parent,"$block");
279 $dbh->commit;
280 };
281 if ($@) {
282 my $msg = $@;
283 eval { dbh->rollback; };
284 return "failed to add $block: $msg";
285 }
286 # nb: no need to return anything, since the CIDR block is the key
287}
288
289
290sub blockexists {
291 my $self = shift;
292 my $block = shift;
293 my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
294 $sth->execute($block);
295 my ($ret) = $sth->fetchrow_array();
296 return $ret;
297}
298
299
300# returns list (block,orgname) for the block that contains the passed IP.
301# accepts a level argument if you don't want the top-level registrar allocation block
302sub getcontainer {
303 my $self = shift;
304 my $ip = shift;
305 my $level = shift || 0;
306 my $sth = $dbh->prepare("SELECT b.block,o.orgname FROM blocks b INNER JOIN orgs o ".
307 "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
308 $sth->execute($ip,$level);
309 return $sth->fetchrow_array();
310} # end getcontainer()
311
312
313# Get info about whether a block, IP or org is listed
314# Returns ?
315sub islisted {
316 my $self = shift;
317 my $entity = shift;
318
319 my $sth;
320
321 if ($entity =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
322 # looking for IP
323
324 $sth = $dbh->prepare("SELECT ip,s4list FROM iplist WHERE ip=?");
325 $sth->execute($entity);
326 my @ret = $sth->fetchrow_array;
327 return @ret if @ret;
328
329 } elsif ($entity =~ m|^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/(\d+)$|) {
330 # block
331
332 my $masklen = $1;
333
334 $sth = $dbh->prepare("SELECT block,listme FROM blocks WHERE block=?");
335 $sth->execute($entity);
336 my ($block,$listme) = $sth->fetchrow_array;
337
338 return if !$block;
339
340 $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
341 $sth->execute($entity);
342 my ($bcount) = $sth->fetchrow_array;
343 my @ret = ( ($bcount >= $autolist{$masklen}), $listme);
344 return @ret;
345
346 } else {
347 # org
348
349 $sth = $dbh->prepare("SELECT orgid,listme FROM orgs WHERE orgname=?");
350 $sth->execute($entity);
351 my ($orgid,$listme) = $sth->fetchrow_array;
352 return $listme if $orgid;
353
354 }
355
356 return undef;
357
358} # end islisted()
359
360
361# whee! Recursion is Fun!
362# Call ourself to dig down through the layers of blocks from registar-allocation
363# (level 0) to final block (level n, not to exceed 2)
364# Take a reference to a hash, and stuff it full of blacklisting goodness.
365# Optionally accept a level, block-container, and OOB block and org arguments for
366# the container to check and return
367# Returns no value directly
368# Calls itself to walk down the tree of containers
369sub export {
370 my $self = shift;
371 my $listhosts = shift;
372
373# Export data as CIDR netblocks or classful (A/B/C) blocks
374# Assume classful as it's more compatible with different DNS servers
375 my $mode = shift || 'class';
376
377# Assume we're checking the whole enchilada if we don't get told where to look.
378 my $level = shift || 0;
379 my $container = shift || '0.0.0.0/0';
380 my $bitmask = shift || 0;
381
382 if ($level > 3) {
383 warn "getting too deep, breaking off! ($container, $level)\n";
384 return;
385 }
386
387# fiddle $container into a sane state.
388 if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
389 $container =~ s|/(\d+)$|.0/$1|;
390 } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
391 $container =~ s|/(\d+)$|.0.0/$1|;
392 } elsif ($container =~ m|^\d+/(\d+)$|) {
393 $container =~ s|/(\d+)$|.0.0.0/$1|;
394 }
395
396 my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE parent = ?");
397 $sth->execute($container);
398 my ($nblocks) = $sth->fetchrow_array();
399
400 # need this for a bunch of things, may as well do it here
401 my ($masklen) = ($container =~ m|/(\d+)$|);
402
403# Update the bitmask variable with the current block info as needed.
404# Much faster than retrieving this data later (~3x faster!).
405 my $listme;
406 my $listorg;
407 my $bcount;
408 if ($container ne '0.0.0.0/0') {
409 $sth = $dbh->prepare("SELECT b.ipcount,b.listme,o.listme ".
410 "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
411 "WHERE b.block = ?");
412 $sth->execute($container);
413 ($bcount,$listme,$listorg) = $sth->fetchrow_array();
414
415 $bitmask |= $bitfields{$level-1} if $bcount >= $autolist{$masklen};
416 $bitmask |= $bitfields{"block".($level-1)} if $listme;
417 $bitmask |= $bitfields{"org".($level-1)} if $listorg;
418 }
419
420# hm. can't seem to move this prepare elsewhere. :(
421 if ($nblocks > 0) {
422 my $sthsubblocks = $dbh->prepare("SELECT block FROM blocks ".
423 "WHERE level = ? AND parent = ?");
424 $sthsubblocks->execute($level, $container);
425 while (my ($cidr) = $sthsubblocks->fetchrow_array()) {
426 $self->export($listhosts,$mode,$level+1,$cidr,$bitmask);
427 }
428 } # avoid checking content of subs if we don't have any
429
430 # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
431 return if $container eq '0.0.0.0/0';
432
433##fixme: need a way to dig out orphan IPs at all levels - IPs not found in a
434# subblock of the current container when the current container *has* subblocks
435# NB: this may be better handled as an out-of-band data-integrity-checker
436
437 # decrement level here so the right bitfield setting gets picked. this segment
438 # is inherently off-by-one from the block-recursion loop, and I can't see a
439 # better way to work around that. >:(
440 $level--;
441
442 if ($mode eq 'cidr') {
443 $listhosts->{$container} |= $bitmask if $bitmask && ($listme || $listorg || ($bcount >= $autolist{$masklen}));
444 } else {
445 # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
446 # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
447 # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting
448
449 if ($bitmask) {
450 my @blocksubs;
451 if ($masklen <= 30 && $masklen > 24) {
452 my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
453 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
454 my $host = "$net$entry";
455 $listhosts->{$host} = 0 if !defined($listhosts->{$host});
456 $listhosts->{$host} |= $bitmask;
457 }
458 } elsif ($masklen <= 24 && $masklen > 16) {
459 my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
460 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
461 my $twofour = "$net$entry.*";
462 $listhosts->{$twofour} |= $bitmask;
463 }
464 } elsif ($masklen <= 16 && $masklen > 8) {
465 my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
466 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
467 my $sixteen = "$net$entry.*";
468 $listhosts->{$sixteen} |= $bitmask;
469 }
470 } elsif ($masklen <= 8) {
471 my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
472 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
473 my $eight = "$entry.*";
474 $listhosts->{$eight} |= $bitmask;
475 }
476 }
477
478 } # generate autolist entries for ips/octets not (yet) seen in reports
479
480 } # cidr vs classful mode
481
482 $sthmoron->execute($container);
483 while (my ($ip,$moron) = $sthmoron->fetchrow_array()) {
484 $listhosts->{$ip} |= $bitmask;
485 if ($moron) {
486 $listhosts->{$ip} = $bitfields{slist};
487 } else {
488 $listhosts->{$ip} |= $bitfields{ip};
489 }
490 }
491
492# get IPs which for reasons unknown are apparently allocated directly from the
493# parent registry (and so do not have containing netblocks in this system) O_o
494# select * from iplist where not (select count(*) from blocks where ip << block) > 0;
495
496 return;
497} # end export()
498
499
500sub export_alt {
501 my $self = shift;
502 my $listhosts = shift;
503 my $level = shift || 0;
504 my $container = shift || '0.0.0.0/0';
505 my $oobblock = shift || 0;
506 my $ooborg = shift || 0;
507
508#print "\nDEBUG: called with $level, $container, $oobblock, $ooborg\n";
509# if $level > 2 or $container =~ /^64\.76\./;
510# my %listhosts;
511
512# $level = 0 if !$level;
513 if ($level > 3) {
514 warn "getting too deep, breaking off!\n";
515 return;
516 }
517
518 my $sth = $dbh->prepare("select ip,s4list from iplist order by ip");
519 my $bsth = $dbh->prepare("select b.block,b.listme,b.level,o.listme ".
520 "from blocks b inner join orgs o on b.orgid=o.orgid ".
521 "where b.block >> ?");
522 while (my ($ip,$s4list) = $sth->fetchrow_array) {
523 $bsth->execute($ip);
524 while (my ($block,$blisted,$blevel,$olisted) = $bsth->fetchrow_array) {
525 $listhosts->{$ip} |= 0;
526 }
527 }
528
529} # end export_alt()
530
531
532## DNSBL::autolist_block()
533# check if a block should be autolisted
534sub autolist_block {
535 my $self = shift;
536 my $block = shift;
537
538 my $cidr = new NetAddr::IP "$block";
539 my $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
540 $sth->execute("$cidr");
541 my ($count) = $sth->fetchrow_array;
542
543 return 1 if $count >= $autolist{$cidr->masklen};
544 return 0;
545} # end autolist_block()
546
547
548# make Perl happy
5491;
Note: See TracBrowser for help on using the repository browser.