1 | # DNSBL
|
---|
2 | # Functions for interacting with the DNSBL database
|
---|
3 | ##
|
---|
4 | # $Id: DNSBL.pm 69 2018-07-19 21:03:38Z kdeugau $
|
---|
5 | # Copyright 2009-2012,2014,2018 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 |
|
---|
21 | package DNSBL;
|
---|
22 |
|
---|
23 | use strict;
|
---|
24 | use warnings;
|
---|
25 | use Exporter;
|
---|
26 | use DBI;
|
---|
27 | use NetAddr::IP;
|
---|
28 |
|
---|
29 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
|
---|
30 |
|
---|
31 | $VERSION = 2.2;
|
---|
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)
|
---|
46 | our %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)
|
---|
85 | our %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
|
---|
121 | 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);
|
---|
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"
|
---|
126 | our $maxlvl = 6;
|
---|
127 |
|
---|
128 | # variables
|
---|
129 | our $dbh;
|
---|
130 |
|
---|
131 | our $err;
|
---|
132 | our $errstr = '';
|
---|
133 |
|
---|
134 | # basic object subs
|
---|
135 | sub 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 |
|
---|
143 | sub 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
|
---|
149 | sub dbclose {
|
---|
150 | $dbh->rollback;
|
---|
151 | $dbh->disconnect;
|
---|
152 | }
|
---|
153 |
|
---|
154 | ## specific object subs:
|
---|
155 |
|
---|
156 | sub 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.
|
---|
179 | my $parsth;
|
---|
180 | my $sthmoron;
|
---|
181 | sub 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,exclude FROM iplist WHERE parent = ?");
|
---|
187 | }
|
---|
188 |
|
---|
189 |
|
---|
190 | ## DNSBL::ipexists()
|
---|
191 | # return report count if the IP has been reported, otherwise return undef
|
---|
192 | sub ipexists {
|
---|
193 | my $self = shift;
|
---|
194 | my $ip = shift;
|
---|
195 | my $sth = $dbh->prepare("SELECT count, exclude FROM iplist WHERE ip=?");
|
---|
196 | $sth->execute($ip);
|
---|
197 | my $ret = $sth->fetchrow_arrayref();
|
---|
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
|
---|
204 | sub report {
|
---|
205 | my $self = shift;
|
---|
206 | my $rep = shift;
|
---|
207 | my $exclude = shift;
|
---|
208 | my $sth;
|
---|
209 | my $rows = 0;
|
---|
210 | if ($rep =~ /^[\d.]+$/) {
|
---|
211 | # weesa gonna ASS-U-ME IP addresses are sanely formatted.
|
---|
212 | eval {
|
---|
213 | $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
|
---|
214 | $sth->execute($rep) or die "eep? ".$dbh->errstr."\n";
|
---|
215 | $rows = $sth->rows;
|
---|
216 | if ($rows == 0) {
|
---|
217 | $sth = $dbh->prepare("INSERT INTO iplist (ip,parent,exclude) VALUES ".
|
---|
218 | "(?,(SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1),?)");
|
---|
219 | $sth->execute($rep,$rep,($exclude ? 'y' : 'n')) or die "couldn't add entry for $rep: ".$dbh->errstr."\n";
|
---|
220 | } elsif ($rows == 1) {
|
---|
221 | $sth = $dbh->prepare("UPDATE iplist SET count=count+1,".
|
---|
222 | " exclude=".($exclude ? "'y'" : "'n'"). " WHERE ip=?");
|
---|
223 | $sth->execute($rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
|
---|
224 | } else {
|
---|
225 | die "db corrupt: found $rows matches on $rep\n";
|
---|
226 | }
|
---|
227 | $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ?");
|
---|
228 | $sth->execute($rep);
|
---|
229 | my $updsth = $dbh->prepare("UPDATE blocks SET ipcount=(SELECT count(*) FROM iplist WHERE ip << ? AND exclude='n') WHERE block=?");
|
---|
230 | while (my ($block) = $sth->fetchrow_array) {
|
---|
231 | $updsth->execute($block,$block);
|
---|
232 | }
|
---|
233 | $dbh->commit;
|
---|
234 | };
|
---|
235 | if ($@) {
|
---|
236 | my $msg = $@;
|
---|
237 | return "failed adding $rep: $msg";
|
---|
238 | }
|
---|
239 | } else {
|
---|
240 | return;
|
---|
241 | }
|
---|
242 | return $rows;
|
---|
243 | } # end report()
|
---|
244 |
|
---|
245 |
|
---|
246 | # add a new org
|
---|
247 | # return the orgid
|
---|
248 | # if the org exists, return the orgid anyway
|
---|
249 | sub addorg {
|
---|
250 | my $self = shift;
|
---|
251 | my $orgname = shift;
|
---|
252 | my $listme = shift || 'n';
|
---|
253 | my $ret = $self->orgexists($orgname);
|
---|
254 | return $ret if $ret;
|
---|
255 | my $sth = $dbh->prepare("INSERT INTO orgs (orgname,listme) VALUES (?,?)");
|
---|
256 | $sth->execute($orgname,$listme) or die "couldn't add org $orgname: ".$dbh->errstr."\n";
|
---|
257 | $dbh->commit;
|
---|
258 | $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
|
---|
259 | $sth->execute($orgname);
|
---|
260 | my ($orgid) = $sth->fetchrow_array();
|
---|
261 | return $orgid;
|
---|
262 | } # end addorg
|
---|
263 |
|
---|
264 |
|
---|
265 | # checks for existence - nb, exact match! No way to really handle anything else. :/
|
---|
266 | sub orgexists {
|
---|
267 | my $self = shift;
|
---|
268 | my $org = shift;
|
---|
269 | my $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
|
---|
270 | $sth->execute($org);
|
---|
271 | my ($ret) = $sth->fetchrow_array();
|
---|
272 | return $ret;
|
---|
273 | } # end orgexists();
|
---|
274 |
|
---|
275 |
|
---|
276 | # take an arbitrary IP range and an IP, and return the CIDR block (if any) the IP is in.
|
---|
277 | sub range2cidr {
|
---|
278 | my $self = shift;
|
---|
279 | my $rstart = shift;
|
---|
280 | my $rend = shift;
|
---|
281 | my $ip = shift;
|
---|
282 |
|
---|
283 | $rstart = new NetAddr::IP $rstart;
|
---|
284 | $rend = new NetAddr::IP $rend;
|
---|
285 | # Basic algoithm: Set the mask on the IP, and see if both $rstart and $rend
|
---|
286 | # are within the range defined by that IP/mask. Continue making the mask
|
---|
287 | # larger until success.
|
---|
288 |
|
---|
289 | my $mask;
|
---|
290 | for ($mask = 32; $mask > 0; $mask--) {
|
---|
291 | my $ip = NetAddr::IP->new("$ip/$mask");
|
---|
292 | if (NetAddr::IP->new($ip->network->addr) >= $rstart &&
|
---|
293 | NetAddr::IP->new($ip->broadcast->addr) <= $rend) {
|
---|
294 | next;
|
---|
295 | } else {
|
---|
296 | $mask++;
|
---|
297 | last;
|
---|
298 | }
|
---|
299 | }
|
---|
300 | my $realnet = NetAddr::IP->new("$ip/$mask")->network;
|
---|
301 |
|
---|
302 | return "$realnet";
|
---|
303 | } # end range2cidr()
|
---|
304 |
|
---|
305 |
|
---|
306 | # add a block. requires the orgid
|
---|
307 | ##fixme needs error handling
|
---|
308 | sub addblock {
|
---|
309 | my $self = shift;
|
---|
310 | my $blockin = shift;
|
---|
311 | my $orgid = shift;
|
---|
312 | my $level = shift;
|
---|
313 | my $exclude = shift;
|
---|
314 | my $comment = shift;
|
---|
315 | $blockin =~ s/^\s+//;
|
---|
316 | $blockin =~ s/\s+$//;
|
---|
317 | my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
|
---|
318 |
|
---|
319 | return "$blockin not a single CIDR range" if !$block;
|
---|
320 |
|
---|
321 | # local $dbh->{AutoCommit} = 1; # force autocommit
|
---|
322 |
|
---|
323 | my $sth;
|
---|
324 | eval {
|
---|
325 | my $parent = '0/0';
|
---|
326 | if ($level > 0) {
|
---|
327 | $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
|
---|
328 | $sth->execute("$block");
|
---|
329 | ($parent) = $sth->fetchrow_array;
|
---|
330 | }
|
---|
331 | $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level,parent,exclude,comments,ipcount) VALUES (?,?,?,?,?,?,".
|
---|
332 | "(SELECT count(*) FROM iplist WHERE ip << ? AND exclude='n'))");
|
---|
333 | $sth->execute("$block",$orgid,$level,$parent,$exclude,$comment,"$block");
|
---|
334 | $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
|
---|
335 | $sth->execute("$block",$parent,"$block");
|
---|
336 | $dbh->commit;
|
---|
337 | };
|
---|
338 | if ($@) {
|
---|
339 | my $msg = $@;
|
---|
340 | eval { dbh->rollback; };
|
---|
341 | return "failed to add $block: $msg";
|
---|
342 | }
|
---|
343 | # nb: no need to return anything, since the CIDR block is the key
|
---|
344 | }
|
---|
345 |
|
---|
346 |
|
---|
347 | # Update a netblock entry. Supports (un)setting the exclude flag and the comment.
|
---|
348 | # Does NOT do any magic around leftover IPs within the block
|
---|
349 | sub updateblock {
|
---|
350 | my $self = shift;
|
---|
351 | my $blockin = shift;
|
---|
352 | my $orgid = shift;
|
---|
353 | my $level = shift;
|
---|
354 | my $exclude = shift;
|
---|
355 | my $comment = shift;
|
---|
356 | $blockin =~ s/^\s+//;
|
---|
357 | $blockin =~ s/\s+$//;
|
---|
358 | my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
|
---|
359 |
|
---|
360 | return "$blockin not a single CIDR range" if !$block;
|
---|
361 |
|
---|
362 | local $dbh->{AutoCommit} = 0;
|
---|
363 | local $dbh->{RaiseError} = 1;
|
---|
364 |
|
---|
365 | my $sth;
|
---|
366 | eval {
|
---|
367 | my $parent = '0/0';
|
---|
368 | if ($level > 0) {
|
---|
369 | $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
|
---|
370 | $sth->execute("$block");
|
---|
371 | ($parent) = $sth->fetchrow_array;
|
---|
372 | }
|
---|
373 | $sth = $dbh->prepare("UPDATE blocks SET exclude = ?, comments = ?, ipcount = ".
|
---|
374 | "(SELECT count(*) FROM iplist WHERE ip << ? AND exclude='n')".
|
---|
375 | " WHERE block = ?");
|
---|
376 | $sth->execute($exclude, $comment, "$block", "$block");
|
---|
377 | $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
|
---|
378 | $sth->execute("$block", $parent, "$block");
|
---|
379 | $dbh->commit;
|
---|
380 | };
|
---|
381 | if ($@) {
|
---|
382 | my $msg = $@;
|
---|
383 | eval { dbh->rollback; };
|
---|
384 | return "failed to update $block: $msg";
|
---|
385 | }
|
---|
386 | # nb: no need to return anything, since the CIDR block is the key
|
---|
387 | }
|
---|
388 |
|
---|
389 |
|
---|
390 | sub blockexists {
|
---|
391 | my $self = shift;
|
---|
392 | my $block = shift;
|
---|
393 | my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
|
---|
394 | $sth->execute($block);
|
---|
395 | my ($ret) = $sth->fetchrow_array();
|
---|
396 | return $ret;
|
---|
397 | }
|
---|
398 |
|
---|
399 |
|
---|
400 | # returns list (block,blockcomment,orgname) for the block that contains the passed IP.
|
---|
401 | # accepts a level argument if you don't want the top-level registrar allocation block
|
---|
402 | sub getcontainer {
|
---|
403 | my $self = shift;
|
---|
404 | my $ip = shift;
|
---|
405 | my $level = shift || 0;
|
---|
406 | my $sth = $dbh->prepare("SELECT b.block,b.comments,o.orgname FROM blocks b INNER JOIN orgs o ".
|
---|
407 | "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
|
---|
408 | $sth->execute($ip,$level);
|
---|
409 | return $sth->fetchrow_array();
|
---|
410 | } # end getcontainer()
|
---|
411 |
|
---|
412 |
|
---|
413 | # Get info about whether a block, IP or org is listed
|
---|
414 | # Returns ?
|
---|
415 | sub islisted {
|
---|
416 | my $self = shift;
|
---|
417 | my $entity = shift;
|
---|
418 |
|
---|
419 | my $sth;
|
---|
420 |
|
---|
421 | if ($entity =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
|
---|
422 | # looking for IP
|
---|
423 |
|
---|
424 | $sth = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE ip=?");
|
---|
425 | $sth->execute($entity);
|
---|
426 | my @ret = $sth->fetchrow_array;
|
---|
427 | return @ret if @ret;
|
---|
428 |
|
---|
429 | } elsif ($entity =~ m|^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/(\d+)$|) {
|
---|
430 | # block
|
---|
431 |
|
---|
432 | my $masklen = $1;
|
---|
433 |
|
---|
434 | $sth = $dbh->prepare("SELECT block,listme,exclude,ipcount FROM blocks WHERE block = ?");
|
---|
435 | $sth->execute($entity);
|
---|
436 | my ($block, $listme, $exclude, $bcount) = $sth->fetchrow_array;
|
---|
437 |
|
---|
438 | return if !$block;
|
---|
439 |
|
---|
440 | my @ret = ( ($bcount >= $autolist{$masklen}), $listme, $exclude);
|
---|
441 | return @ret;
|
---|
442 |
|
---|
443 | } else {
|
---|
444 | # org
|
---|
445 |
|
---|
446 | $sth = $dbh->prepare("SELECT orgid,listme FROM orgs WHERE orgname=?");
|
---|
447 | $sth->execute($entity);
|
---|
448 | my ($orgid,$listme) = $sth->fetchrow_array;
|
---|
449 | return $listme if $orgid;
|
---|
450 |
|
---|
451 | }
|
---|
452 |
|
---|
453 | return undef;
|
---|
454 |
|
---|
455 | } # end islisted()
|
---|
456 |
|
---|
457 |
|
---|
458 | # whee! Recursion is Fun!
|
---|
459 | # Call ourself to dig down through the layers of blocks from registar-allocation
|
---|
460 | # (level 0) to final block (level n, not to exceed $maxlvl)
|
---|
461 | # Take a reference to a hash, and stuff it full of blacklisting goodness.
|
---|
462 | # Optionally accept a level, block-container, and OOB block and org arguments for
|
---|
463 | # the container to check and return
|
---|
464 | # Returns no value directly
|
---|
465 | # Calls itself to walk down the tree of containers
|
---|
466 | sub export {
|
---|
467 | my $self = shift;
|
---|
468 | my $listhosts = shift;
|
---|
469 |
|
---|
470 | # Export data as CIDR netblocks or classful (A/B/C) blocks
|
---|
471 | # Assume classful as it's more compatible with different DNS servers
|
---|
472 | my $mode = shift || 'class';
|
---|
473 |
|
---|
474 | # Assume we're checking the whole enchilada if we don't get told where to look.
|
---|
475 | my $level = shift || 0;
|
---|
476 | my $container = shift || '0.0.0.0/0';
|
---|
477 | my $bitmask = shift || 0;
|
---|
478 |
|
---|
479 | if ($level == 0) {
|
---|
480 | $errstr = '';
|
---|
481 | }
|
---|
482 |
|
---|
483 | return if ($errstr =~ /no connection to the server/);
|
---|
484 | if ($level > $maxlvl) {
|
---|
485 | warn "getting too deep, breaking off! ($container, $level)\n";
|
---|
486 | return;
|
---|
487 | }
|
---|
488 |
|
---|
489 | # fiddle $container into a sane state.
|
---|
490 | if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
|
---|
491 | $container =~ s|/(\d+)$|.0/$1|;
|
---|
492 | } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
|
---|
493 | $container =~ s|/(\d+)$|.0.0/$1|;
|
---|
494 | } elsif ($container =~ m|^\d+/(\d+)$|) {
|
---|
495 | $container =~ s|/(\d+)$|.0.0.0/$1|;
|
---|
496 | }
|
---|
497 |
|
---|
498 |
|
---|
499 | # catch database-went-away errors
|
---|
500 | local $dbh->{RaiseError} = 1;
|
---|
501 | eval {
|
---|
502 |
|
---|
503 |
|
---|
504 | my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE parent = ?");
|
---|
505 | $sth->execute($container);
|
---|
506 | my ($nblocks) = $sth->fetchrow_array();
|
---|
507 |
|
---|
508 | # need this for a bunch of things, may as well do it here
|
---|
509 | my ($masklen) = ($container =~ m|/(\d+)$|);
|
---|
510 |
|
---|
511 | # Update the bitmask variable with the current block info as needed.
|
---|
512 | # Much faster than retrieving this data later (~3x faster!).
|
---|
513 | my $listme;
|
---|
514 | my $listorg;
|
---|
515 | my $bcount;
|
---|
516 | my $bexclude;
|
---|
517 | if ($container ne '0.0.0.0/0') {
|
---|
518 | $sth = $dbh->prepare("SELECT b.ipcount,b.listme,b.exclude,o.listme ".
|
---|
519 | "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
|
---|
520 | "WHERE b.block = ?");
|
---|
521 | $sth->execute($container);
|
---|
522 | ($bcount,$listme,$bexclude,$listorg) = $sth->fetchrow_array();
|
---|
523 | $bitmask |= $bitfields{$level-1} if $bcount >= $autolist{$masklen};
|
---|
524 | $bitmask |= $bitfields{"block".($level-1)} if $listme;
|
---|
525 | $bitmask |= $bitfields{"org".($level-1)} if $listorg;
|
---|
526 | }
|
---|
527 |
|
---|
528 | # hm. can't seem to move this prepare elsewhere. :(
|
---|
529 | if ($nblocks > 0) {
|
---|
530 | my $sthsubblocks = $dbh->prepare("SELECT block,exclude FROM blocks ".
|
---|
531 | "WHERE level = ? AND parent = ?");
|
---|
532 | $sthsubblocks->execute($level, $container);
|
---|
533 | while (my ($cidr, $exclude) = $sthsubblocks->fetchrow_array()) {
|
---|
534 | if ($exclude) {
|
---|
535 | $listhosts->{$cidr} = -1;
|
---|
536 | } else { # don't check subtrees of an excluded block; rbldnsd doesn't support deep flip-flopping like that
|
---|
537 | $self->export($listhosts,$mode,$level+1,$cidr,$bitmask)
|
---|
538 | or die $errstr;
|
---|
539 | }
|
---|
540 | }
|
---|
541 | } # avoid checking content of subs if we don't have any
|
---|
542 |
|
---|
543 | # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
|
---|
544 | return if $container eq '0.0.0.0/0';
|
---|
545 |
|
---|
546 | ##fixme: need a way to dig out orphan IPs at all levels - IPs not found in a
|
---|
547 | # subblock of the current container when the current container *has* subblocks
|
---|
548 | # NB: this may be better handled as an out-of-band data-integrity-checker
|
---|
549 |
|
---|
550 | # decrement level here so the right bitfield setting gets picked. this segment
|
---|
551 | # is inherently off-by-one from the block-recursion loop, and I can't see a
|
---|
552 | # better way to work around that. >:(
|
---|
553 | $level--;
|
---|
554 |
|
---|
555 | if ($mode eq 'cidr') {
|
---|
556 | $listhosts->{$container} |= $bitmask if $bitmask && ($listme || $listorg || ($bcount >= $autolist{$masklen}));
|
---|
557 | } else {
|
---|
558 | # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
|
---|
559 | # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
|
---|
560 | # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting
|
---|
561 |
|
---|
562 | if ($bitmask) {
|
---|
563 | my @blocksubs;
|
---|
564 | if ($masklen <= 30 && $masklen > 24) {
|
---|
565 | my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
|
---|
566 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
567 | my $host = "$net$entry";
|
---|
568 | $listhosts->{$host} = 0 if !defined($listhosts->{$host});
|
---|
569 | $listhosts->{$host} |= $bitmask;
|
---|
570 | }
|
---|
571 | } elsif ($masklen <= 24 && $masklen > 16) {
|
---|
572 | my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
|
---|
573 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
574 | my $twofour = "$net$entry.*";
|
---|
575 | $listhosts->{$twofour} |= $bitmask;
|
---|
576 | }
|
---|
577 | } elsif ($masklen <= 16 && $masklen > 8) {
|
---|
578 | my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
|
---|
579 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
580 | my $sixteen = "$net$entry.*";
|
---|
581 | $listhosts->{$sixteen} |= $bitmask;
|
---|
582 | }
|
---|
583 | } elsif ($masklen <= 8) {
|
---|
584 | my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
|
---|
585 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
586 | my $eight = "$entry.*";
|
---|
587 | $listhosts->{$eight} |= $bitmask;
|
---|
588 | }
|
---|
589 | }
|
---|
590 |
|
---|
591 | } # generate autolist entries for ips/octets not (yet) seen in reports
|
---|
592 |
|
---|
593 | } # cidr vs classful mode
|
---|
594 |
|
---|
595 | $sthmoron->execute($container);
|
---|
596 | while (my ($ip,$moron,$exclude) = $sthmoron->fetchrow_array()) {
|
---|
597 | if ($moron) {
|
---|
598 | $listhosts->{$ip} = $bitfields{slist};
|
---|
599 | } elsif ($exclude) {
|
---|
600 | $listhosts->{$ip} = -1;
|
---|
601 | } else {
|
---|
602 | $listhosts->{$ip} |= $bitmask;
|
---|
603 | $listhosts->{$ip} |= $bitfields{ip};
|
---|
604 | }
|
---|
605 | }
|
---|
606 |
|
---|
607 |
|
---|
608 | }; # db-went-away-catching eval
|
---|
609 | if ($@) {
|
---|
610 | $errstr = $@;
|
---|
611 | warn "export truncated: $errstr\n";
|
---|
612 | return;
|
---|
613 | }
|
---|
614 |
|
---|
615 |
|
---|
616 | # get IPs which for reasons unknown are apparently allocated directly from the
|
---|
617 | # parent registry (and so do not have containing netblocks in this system) O_o
|
---|
618 | # select * from iplist where not (select count(*) from blocks where ip << block) > 0;
|
---|
619 |
|
---|
620 | return 1;
|
---|
621 | } # end export()
|
---|
622 |
|
---|
623 |
|
---|
624 | sub export_alt {
|
---|
625 | my $self = shift;
|
---|
626 | my $listhosts = shift;
|
---|
627 | my $level = shift || 0;
|
---|
628 | my $container = shift || '0.0.0.0/0';
|
---|
629 | my $oobblock = shift || 0;
|
---|
630 | my $ooborg = shift || 0;
|
---|
631 |
|
---|
632 | #print "\nDEBUG: called with $level, $container, $oobblock, $ooborg\n";
|
---|
633 | # if $level > 2 or $container =~ /^64\.76\./;
|
---|
634 | # my %listhosts;
|
---|
635 |
|
---|
636 | # $level = 0 if !$level;
|
---|
637 | if ($level > 3) {
|
---|
638 | warn "getting too deep, breaking off!\n";
|
---|
639 | return;
|
---|
640 | }
|
---|
641 |
|
---|
642 | my $sth = $dbh->prepare("select ip,s4list from iplist order by ip");
|
---|
643 | my $bsth = $dbh->prepare("select b.block,b.listme,b.level,o.listme ".
|
---|
644 | "from blocks b inner join orgs o on b.orgid=o.orgid ".
|
---|
645 | "where b.block >> ?");
|
---|
646 | while (my ($ip,$s4list) = $sth->fetchrow_array) {
|
---|
647 | $bsth->execute($ip);
|
---|
648 | while (my ($block,$blisted,$blevel,$olisted) = $bsth->fetchrow_array) {
|
---|
649 | $listhosts->{$ip} |= 0;
|
---|
650 | }
|
---|
651 | }
|
---|
652 |
|
---|
653 | } # end export_alt()
|
---|
654 |
|
---|
655 |
|
---|
656 | ## DNSBL::autolist_block()
|
---|
657 | # check if a block should be autolisted
|
---|
658 | sub autolist_block {
|
---|
659 | my $self = shift;
|
---|
660 | my $block = shift;
|
---|
661 |
|
---|
662 | my $cidr = new NetAddr::IP "$block";
|
---|
663 | my $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
|
---|
664 | $sth->execute("$cidr");
|
---|
665 | my ($count) = $sth->fetchrow_array;
|
---|
666 |
|
---|
667 | return 1 if $count >= $autolist{$cidr->masklen};
|
---|
668 | return 0;
|
---|
669 | } # end autolist_block()
|
---|
670 |
|
---|
671 |
|
---|
672 | # make Perl happy
|
---|
673 | 1;
|
---|