source: trunk/dnsbl/DNSBL.pm@ 48

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

/trunk/dnsbl

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