[2] | 1 | # DNSBL
|
---|
| 2 | # Functions for interacting with the DNSBL database
|
---|
[40] | 3 | ##
|
---|
| 4 | # $Id: DNSBL.pm 54 2014-12-11 22:22:28Z kdeugau $
|
---|
[49] | 5 | # Copyright 2009-2011,2014 Kris Deugau <kdeugau@deepnet.cx>
|
---|
[40] | 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 | ##
|
---|
[2] | 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 |
|
---|
[36] | 31 | $VERSION = 2.1;
|
---|
[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 |
|
---|
[36] | 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!
|
---|
[2] | 45 | # 1 not available so we don't $self->shoot(foot)
|
---|
| 46 | our %bitfields = (
|
---|
[50] | 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
|
---|
[2] | 56 | 0 => 16,
|
---|
| 57 | 1 => 8,
|
---|
| 58 | 2 => 4,
|
---|
[50] | 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 |
|
---|
[2] | 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
|
---|
[24] | 84 | # defaults: (overridden by entries in db:autolist)
|
---|
[2] | 85 | our %autolist = (
|
---|
[10] | 86 | 31 => 1,
|
---|
[2] | 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,
|
---|
[15] | 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,
|
---|
[2] | 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 |
|
---|
[48] | 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 |
|
---|
[2] | 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;
|
---|
[25] | 145 | $self->dbclose() if $dbh;
|
---|
[2] | 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 {
|
---|
[25] | 157 | my $self = shift;
|
---|
| 158 | my $dbhost = shift;
|
---|
| 159 | my $dbname = shift;
|
---|
| 160 | my $dbuser = shift;
|
---|
| 161 | my $dbpass = shift;
|
---|
[2] | 162 | ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
|
---|
[25] | 163 | $dbh = DBI->connect("DBI:Pg:host=$dbhost;dbname=$dbname", $dbuser, $dbpass, {
|
---|
[2] | 164 | AutoCommit => 0,
|
---|
| 165 | PrintError => 1
|
---|
| 166 | })
|
---|
| 167 | or die "database inaccessible: ".$DBI::errstr;
|
---|
[24] | 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 | }
|
---|
[2] | 173 | return $dbh;
|
---|
| 174 | }
|
---|
| 175 |
|
---|
[5] | 176 |
|
---|
[23] | 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 ".
|
---|
[32] | 183 | "FROM iplist i INNER JOIN blocks b ON i.parent = b.block INNER JOIN orgs o ON b.orgid = o.orgid ".
|
---|
[23] | 184 | "WHERE b.block >>= ? ".
|
---|
| 185 | "GROUP BY b.block,b.level,b.listme,o.listme ORDER BY b.block");
|
---|
[32] | 186 | $sthmoron = $dbh->prepare("SELECT ip,s4list FROM iplist WHERE parent = ?");
|
---|
[23] | 187 | }
|
---|
| 188 |
|
---|
| 189 |
|
---|
[5] | 190 | ## DNSBL::ipexists()
|
---|
| 191 | # return report count if the IP has been reported, otherwise return undef
|
---|
[2] | 192 | sub ipexists {
|
---|
| 193 | my $self = shift;
|
---|
| 194 | my $ip = shift;
|
---|
[5] | 195 | my $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
|
---|
[2] | 196 | $sth->execute($ip);
|
---|
| 197 | my ($ret) = $sth->fetchrow_array();
|
---|
| 198 | return $ret;
|
---|
[5] | 199 | } # end ipexists()
|
---|
[2] | 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 $sth;
|
---|
| 208 | my $rows = 0;
|
---|
| 209 | if ($rep =~ /^[\d.]+$/) {
|
---|
| 210 | # weesa gonna ASS-U-ME IP addresses are sanely formatted.
|
---|
[32] | 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";
|
---|
[2] | 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
|
---|
| 247 | sub 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. :/
|
---|
| 264 | sub 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 |
|
---|
[54] | 274 | # take an arbitrary IP range and an IP, and return the CIDR block (if any) the IP is in.
|
---|
| 275 | sub range2cidr {
|
---|
| 276 | my $self = shift;
|
---|
| 277 | my $rstart = shift;
|
---|
| 278 | my $rend = shift;
|
---|
| 279 | my $ip = shift;
|
---|
| 280 |
|
---|
| 281 | $rstart = new NetAddr::IP $rstart;
|
---|
| 282 | $rend = new NetAddr::IP $rend;
|
---|
| 283 | # Basic algoithm: Set the mask on the IP, and see if both $rstart and $rend
|
---|
| 284 | # are within the range defined by that IP/mask. Continue making the mask
|
---|
| 285 | # larger until success.
|
---|
| 286 |
|
---|
| 287 | my $mask;
|
---|
| 288 | for ($mask = 32; $mask > 0; $mask--) {
|
---|
| 289 | my $ip = NetAddr::IP->new("$ip/$mask");
|
---|
| 290 | if (NetAddr::IP->new($ip->network->addr) >= $rstart &&
|
---|
| 291 | NetAddr::IP->new($ip->broadcast->addr) <= $rend) {
|
---|
| 292 | next;
|
---|
| 293 | } else {
|
---|
| 294 | $mask++;
|
---|
| 295 | last;
|
---|
| 296 | }
|
---|
| 297 | }
|
---|
| 298 | my $realnet = NetAddr::IP->new("$ip/$mask")->network;
|
---|
| 299 |
|
---|
| 300 | return "$realnet";
|
---|
| 301 | } # end range2cidr()
|
---|
| 302 |
|
---|
| 303 |
|
---|
[2] | 304 | # add a block. requires the orgid
|
---|
| 305 | ##fixme needs error handling
|
---|
| 306 | sub addblock {
|
---|
| 307 | my $self = shift;
|
---|
| 308 | my $blockin = shift;
|
---|
| 309 | my $orgid = shift;
|
---|
| 310 | my $level = shift;
|
---|
| 311 | $blockin =~ s/^\s+//;
|
---|
| 312 | $blockin =~ s/\s+$//;
|
---|
| 313 | my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
|
---|
| 314 |
|
---|
[11] | 315 | return "$blockin not a single CIDR range" if !$block;
|
---|
| 316 |
|
---|
[32] | 317 | # local $dbh->{AutoCommit} = 1; # force autocommit
|
---|
[2] | 318 |
|
---|
[32] | 319 | my $sth;
|
---|
| 320 | eval {
|
---|
| 321 | my $parent = '0/0';
|
---|
| 322 | if ($level > 0) {
|
---|
| 323 | $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
|
---|
| 324 | $sth->execute("$block");
|
---|
| 325 | ($parent) = $sth->fetchrow_array;
|
---|
| 326 | }
|
---|
| 327 | $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level,parent,ipcount) VALUES (?,?,?,?,".
|
---|
| 328 | "(SELECT count(*) FROM iplist WHERE ip << ?))");
|
---|
| 329 | $sth->execute("$block",$orgid,$level,$parent,"$block");
|
---|
| 330 | $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
|
---|
| 331 | $sth->execute("$block",$parent,"$block");
|
---|
| 332 | $dbh->commit;
|
---|
| 333 | };
|
---|
| 334 | if ($@) {
|
---|
| 335 | my $msg = $@;
|
---|
| 336 | eval { dbh->rollback; };
|
---|
| 337 | return "failed to add $block: $msg";
|
---|
| 338 | }
|
---|
[2] | 339 | # nb: no need to return anything, since the CIDR block is the key
|
---|
| 340 | }
|
---|
| 341 |
|
---|
| 342 |
|
---|
| 343 | sub blockexists {
|
---|
| 344 | my $self = shift;
|
---|
| 345 | my $block = shift;
|
---|
| 346 | my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
|
---|
| 347 | $sth->execute($block);
|
---|
| 348 | my ($ret) = $sth->fetchrow_array();
|
---|
| 349 | return $ret;
|
---|
| 350 | }
|
---|
| 351 |
|
---|
| 352 |
|
---|
| 353 | # returns list (block,orgname) for the block that contains the passed IP.
|
---|
| 354 | # accepts a level argument if you don't want the top-level registrar allocation block
|
---|
| 355 | sub getcontainer {
|
---|
| 356 | my $self = shift;
|
---|
| 357 | my $ip = shift;
|
---|
| 358 | my $level = shift || 0;
|
---|
| 359 | my $sth = $dbh->prepare("SELECT b.block,o.orgname FROM blocks b INNER JOIN orgs o ".
|
---|
| 360 | "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
|
---|
| 361 | $sth->execute($ip,$level);
|
---|
| 362 | return $sth->fetchrow_array();
|
---|
| 363 | } # end getcontainer()
|
---|
| 364 |
|
---|
| 365 |
|
---|
[29] | 366 | # Get info about whether a block, IP or org is listed
|
---|
| 367 | # Returns ?
|
---|
| 368 | sub islisted {
|
---|
| 369 | my $self = shift;
|
---|
| 370 | my $entity = shift;
|
---|
| 371 |
|
---|
| 372 | my $sth;
|
---|
| 373 |
|
---|
| 374 | if ($entity =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
|
---|
| 375 | # looking for IP
|
---|
| 376 |
|
---|
| 377 | $sth = $dbh->prepare("SELECT ip,s4list FROM iplist WHERE ip=?");
|
---|
| 378 | $sth->execute($entity);
|
---|
| 379 | my @ret = $sth->fetchrow_array;
|
---|
| 380 | return @ret if @ret;
|
---|
| 381 |
|
---|
| 382 | } elsif ($entity =~ m|^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/(\d+)$|) {
|
---|
| 383 | # block
|
---|
| 384 |
|
---|
| 385 | my $masklen = $1;
|
---|
| 386 |
|
---|
| 387 | $sth = $dbh->prepare("SELECT block,listme FROM blocks WHERE block=?");
|
---|
| 388 | $sth->execute($entity);
|
---|
| 389 | my ($block,$listme) = $sth->fetchrow_array;
|
---|
| 390 |
|
---|
| 391 | return if !$block;
|
---|
| 392 |
|
---|
[32] | 393 | $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
|
---|
[29] | 394 | $sth->execute($entity);
|
---|
| 395 | my ($bcount) = $sth->fetchrow_array;
|
---|
| 396 | my @ret = ( ($bcount >= $autolist{$masklen}), $listme);
|
---|
| 397 | return @ret;
|
---|
| 398 |
|
---|
| 399 | } else {
|
---|
| 400 | # org
|
---|
| 401 |
|
---|
| 402 | $sth = $dbh->prepare("SELECT orgid,listme FROM orgs WHERE orgname=?");
|
---|
| 403 | $sth->execute($entity);
|
---|
| 404 | my ($orgid,$listme) = $sth->fetchrow_array;
|
---|
| 405 | return $listme if $orgid;
|
---|
| 406 |
|
---|
| 407 | }
|
---|
| 408 |
|
---|
| 409 | return undef;
|
---|
| 410 |
|
---|
| 411 | } # end islisted()
|
---|
| 412 |
|
---|
| 413 |
|
---|
[2] | 414 | # whee! Recursion is Fun!
|
---|
| 415 | # Call ourself to dig down through the layers of blocks from registar-allocation
|
---|
[48] | 416 | # (level 0) to final block (level n, not to exceed $maxlvl)
|
---|
[2] | 417 | # Take a reference to a hash, and stuff it full of blacklisting goodness.
|
---|
| 418 | # Optionally accept a level, block-container, and OOB block and org arguments for
|
---|
| 419 | # the container to check and return
|
---|
| 420 | # Returns no value directly
|
---|
| 421 | # Calls itself to walk down the tree of containers
|
---|
| 422 | sub export {
|
---|
| 423 | my $self = shift;
|
---|
| 424 | my $listhosts = shift;
|
---|
| 425 |
|
---|
| 426 | # Export data as CIDR netblocks or classful (A/B/C) blocks
|
---|
| 427 | # Assume classful as it's more compatible with different DNS servers
|
---|
| 428 | my $mode = shift || 'class';
|
---|
| 429 |
|
---|
| 430 | # Assume we're checking the whole enchilada if we don't get told where to look.
|
---|
| 431 | my $level = shift || 0;
|
---|
| 432 | my $container = shift || '0.0.0.0/0';
|
---|
[23] | 433 | my $bitmask = shift || 0;
|
---|
[2] | 434 |
|
---|
[48] | 435 | if ($level > $maxlvl) {
|
---|
[2] | 436 | warn "getting too deep, breaking off! ($container, $level)\n";
|
---|
| 437 | return;
|
---|
| 438 | }
|
---|
| 439 |
|
---|
| 440 | # fiddle $container into a sane state.
|
---|
| 441 | if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
|
---|
| 442 | $container =~ s|/(\d+)$|.0/$1|;
|
---|
| 443 | } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
|
---|
| 444 | $container =~ s|/(\d+)$|.0.0/$1|;
|
---|
| 445 | } elsif ($container =~ m|^\d+/(\d+)$|) {
|
---|
| 446 | $container =~ s|/(\d+)$|.0.0.0/$1|;
|
---|
| 447 | }
|
---|
| 448 |
|
---|
[32] | 449 | my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE parent = ?");
|
---|
[2] | 450 | $sth->execute($container);
|
---|
| 451 | my ($nblocks) = $sth->fetchrow_array();
|
---|
| 452 |
|
---|
[23] | 453 | # need this for a bunch of things, may as well do it here
|
---|
| 454 | my ($masklen) = ($container =~ m|/(\d+)$|);
|
---|
| 455 |
|
---|
| 456 | # Update the bitmask variable with the current block info as needed.
|
---|
| 457 | # Much faster than retrieving this data later (~3x faster!).
|
---|
| 458 | my $listme;
|
---|
| 459 | my $listorg;
|
---|
| 460 | my $bcount;
|
---|
| 461 | if ($container ne '0.0.0.0/0') {
|
---|
[32] | 462 | $sth = $dbh->prepare("SELECT b.ipcount,b.listme,o.listme ".
|
---|
[23] | 463 | "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
|
---|
| 464 | "WHERE b.block = ?");
|
---|
| 465 | $sth->execute($container);
|
---|
[32] | 466 | ($bcount,$listme,$listorg) = $sth->fetchrow_array();
|
---|
[23] | 467 |
|
---|
| 468 | $bitmask |= $bitfields{$level-1} if $bcount >= $autolist{$masklen};
|
---|
[36] | 469 | $bitmask |= $bitfields{"block".($level-1)} if $listme;
|
---|
| 470 | $bitmask |= $bitfields{"org".($level-1)} if $listorg;
|
---|
[23] | 471 | }
|
---|
| 472 |
|
---|
| 473 | # hm. can't seem to move this prepare elsewhere. :(
|
---|
[2] | 474 | if ($nblocks > 0) {
|
---|
[23] | 475 | my $sthsubblocks = $dbh->prepare("SELECT block FROM blocks ".
|
---|
[32] | 476 | "WHERE level = ? AND parent = ?");
|
---|
[23] | 477 | $sthsubblocks->execute($level, $container);
|
---|
| 478 | while (my ($cidr) = $sthsubblocks->fetchrow_array()) {
|
---|
| 479 | $self->export($listhosts,$mode,$level+1,$cidr,$bitmask);
|
---|
[2] | 480 | }
|
---|
| 481 | } # avoid checking content of subs if we don't have any
|
---|
| 482 |
|
---|
| 483 | # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
|
---|
| 484 | return if $container eq '0.0.0.0/0';
|
---|
| 485 |
|
---|
| 486 | ##fixme: need a way to dig out orphan IPs at all levels - IPs not found in a
|
---|
| 487 | # subblock of the current container when the current container *has* subblocks
|
---|
| 488 | # NB: this may be better handled as an out-of-band data-integrity-checker
|
---|
| 489 |
|
---|
| 490 | # decrement level here so the right bitfield setting gets picked. this segment
|
---|
| 491 | # is inherently off-by-one from the block-recursion loop, and I can't see a
|
---|
| 492 | # better way to work around that. >:(
|
---|
| 493 | $level--;
|
---|
| 494 |
|
---|
[4] | 495 | if ($mode eq 'cidr') {
|
---|
[23] | 496 | $listhosts->{$container} |= $bitmask if $bitmask && ($listme || $listorg || ($bcount >= $autolist{$masklen}));
|
---|
[2] | 497 | } else {
|
---|
| 498 | # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
|
---|
| 499 | # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
|
---|
| 500 | # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting
|
---|
| 501 |
|
---|
[23] | 502 | if ($bitmask) {
|
---|
[2] | 503 | my @blocksubs;
|
---|
| 504 | if ($masklen <= 30 && $masklen > 24) {
|
---|
| 505 | my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
|
---|
| 506 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
| 507 | my $host = "$net$entry";
|
---|
| 508 | $listhosts->{$host} = 0 if !defined($listhosts->{$host});
|
---|
[23] | 509 | $listhosts->{$host} |= $bitmask;
|
---|
[2] | 510 | }
|
---|
| 511 | } elsif ($masklen <= 24 && $masklen > 16) {
|
---|
| 512 | my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
|
---|
| 513 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
| 514 | my $twofour = "$net$entry.*";
|
---|
[23] | 515 | $listhosts->{$twofour} |= $bitmask;
|
---|
[2] | 516 | }
|
---|
| 517 | } elsif ($masklen <= 16 && $masklen > 8) {
|
---|
| 518 | my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
|
---|
| 519 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
| 520 | my $sixteen = "$net$entry.*";
|
---|
[23] | 521 | $listhosts->{$sixteen} |= $bitmask;
|
---|
[2] | 522 | }
|
---|
| 523 | } elsif ($masklen <= 8) {
|
---|
| 524 | my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
|
---|
| 525 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
---|
| 526 | my $eight = "$entry.*";
|
---|
[23] | 527 | $listhosts->{$eight} |= $bitmask;
|
---|
[2] | 528 | }
|
---|
| 529 | }
|
---|
| 530 |
|
---|
| 531 | } # generate autolist entries for ips/octets not (yet) seen in reports
|
---|
| 532 |
|
---|
| 533 | } # cidr vs classful mode
|
---|
| 534 |
|
---|
[23] | 535 | $sthmoron->execute($container);
|
---|
| 536 | while (my ($ip,$moron) = $sthmoron->fetchrow_array()) {
|
---|
| 537 | $listhosts->{$ip} |= $bitmask;
|
---|
[2] | 538 | if ($moron) {
|
---|
| 539 | $listhosts->{$ip} = $bitfields{slist};
|
---|
| 540 | } else {
|
---|
| 541 | $listhosts->{$ip} |= $bitfields{ip};
|
---|
| 542 | }
|
---|
| 543 | }
|
---|
| 544 |
|
---|
| 545 | # get IPs which for reasons unknown are apparently allocated directly from the
|
---|
| 546 | # parent registry (and so do not have containing netblocks in this system) O_o
|
---|
| 547 | # select * from iplist where not (select count(*) from blocks where ip << block) > 0;
|
---|
| 548 |
|
---|
| 549 | return;
|
---|
| 550 | } # end export()
|
---|
| 551 |
|
---|
| 552 |
|
---|
| 553 | sub export_alt {
|
---|
| 554 | my $self = shift;
|
---|
| 555 | my $listhosts = shift;
|
---|
| 556 | my $level = shift || 0;
|
---|
| 557 | my $container = shift || '0.0.0.0/0';
|
---|
| 558 | my $oobblock = shift || 0;
|
---|
| 559 | my $ooborg = shift || 0;
|
---|
| 560 |
|
---|
| 561 | #print "\nDEBUG: called with $level, $container, $oobblock, $ooborg\n";
|
---|
| 562 | # if $level > 2 or $container =~ /^64\.76\./;
|
---|
| 563 | # my %listhosts;
|
---|
| 564 |
|
---|
| 565 | # $level = 0 if !$level;
|
---|
| 566 | if ($level > 3) {
|
---|
| 567 | warn "getting too deep, breaking off!\n";
|
---|
| 568 | return;
|
---|
| 569 | }
|
---|
| 570 |
|
---|
| 571 | my $sth = $dbh->prepare("select ip,s4list from iplist order by ip");
|
---|
| 572 | my $bsth = $dbh->prepare("select b.block,b.listme,b.level,o.listme ".
|
---|
| 573 | "from blocks b inner join orgs o on b.orgid=o.orgid ".
|
---|
| 574 | "where b.block >> ?");
|
---|
| 575 | while (my ($ip,$s4list) = $sth->fetchrow_array) {
|
---|
| 576 | $bsth->execute($ip);
|
---|
| 577 | while (my ($block,$blisted,$blevel,$olisted) = $bsth->fetchrow_array) {
|
---|
| 578 | $listhosts->{$ip} |= 0;
|
---|
| 579 | }
|
---|
| 580 | }
|
---|
| 581 |
|
---|
| 582 | } # end export_alt()
|
---|
| 583 |
|
---|
| 584 |
|
---|
| 585 | ## DNSBL::autolist_block()
|
---|
| 586 | # check if a block should be autolisted
|
---|
| 587 | sub autolist_block {
|
---|
| 588 | my $self = shift;
|
---|
| 589 | my $block = shift;
|
---|
| 590 |
|
---|
| 591 | my $cidr = new NetAddr::IP "$block";
|
---|
[32] | 592 | my $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
|
---|
[2] | 593 | $sth->execute("$cidr");
|
---|
| 594 | my ($count) = $sth->fetchrow_array;
|
---|
| 595 |
|
---|
| 596 | return 1 if $count >= $autolist{$cidr->masklen};
|
---|
| 597 | return 0;
|
---|
| 598 | } # end autolist_block()
|
---|
| 599 |
|
---|
| 600 |
|
---|
| 601 | # make Perl happy
|
---|
| 602 | 1;
|
---|