source: trunk/dnsbl/DNSBL.pm@ 50

Last change on this file since 50 was 50, checked in by Kris Deugau, 9 years ago

/trunk/dnsbl

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