1#!/usr/local/bin/perl 2 3package Net::DNSBL::Utilities; 4use strict; 5#use diagnostics; 6 7use File::SafeDO qw( 8 DO 9 doINCLUDE 10); 11use vars qw( 12 $VERSION @ISA @EXPORT_OK *UDP 13 $A1271 $A1272 $A1273 $A1274 $A1275 $A1276 $A1277 14 $SKIP_POSIX $SKIP_NetAddrIP $AuthBit $RABit 15); 16$A1271 = $A1272 = $A1273 = $A1274 = $A1275 = 0; 17$AuthBit = $SKIP_POSIX = $SKIP_NetAddrIP = 0; 18use AutoLoader 'AUTOLOAD'; 19require Exporter; 20@ISA = qw(Exporter); 21 22$VERSION = do { my @r = (q$Revision: 0.10 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; 23 24*DO = \&File::SafeDO::DO; 25*doINCLUDE = \&File::SafeDO::doINCLUDE; 26 27@EXPORT_OK = qw( 28 s_response 29 not_found 30 write_stats 31 bystat 32 statinit 33 cntinit 34 DO 35 doINCLUDE 36 open_udpNB 37 list2NetAddr 38 matchNetAddr 39 list2hash 40 A1271 41 A1272 42 A1273 43 A1274 44 A1275 45 A1276 46 A1277 47 list_countries 48 setAUTH 49 setRA 50); 51 52use Net::DNS::Codes qw( 53 BITS_QUERY 54 QR 55 NXDOMAIN 56 C_IN 57 AA 58 RA 59); 60use Net::DNS::ToolKit 0.16 qw( 61 newhead 62); 63use Net::DNS::ToolKit::RR; 64#use Net::DNS::ToolKit::Debug qw( 65# print_head 66# print_buf 67#); 68 69# used a lot, create once per session 70*UDP = \getprotobyname('udp'); 71 721; 73__END__ 74 75=head1 NAME 76 77Net::DNSBL::Utilities - functions for DNSBL daemons 78 79=head1 SYNOPSIS 80 81 use Net::DNSBL::Utilities qw( 82 s_response 83 not_found 84 write_stats 85 bystat 86 statinit 87 cntinit 88 list2hash 89 open_udpNB 90 DO 91 doINCLUDE 92 list2NetAddr 93 matchNetAddr 94 list_countries 95 setAUTH 96 setRA 97 A1271 98 A1272 99 A1273 100 A1274 101 A1275 102 A1276 103 A1277 104 ); 105 106 s_response($mp,$resp,$id,$qdcount,$ancount,$nscount,$arcount); 107 not_found($put,$name,$type,$id,$mp,$srp); 108 write_stats($sfile,$cp,$sinit,$csize,$cache); 109 $rv = bystat($cp); 110 $timestamp = statinit($Sfile,$cp); 111 cntinit($DNSBL,$cp); 112 list2hash(\@list,$cp,$val); 113 $sock = open_udpNB(); 114 $rv = DO($file,$nowarnings) 115 $rv = doINCLUDE($file,$nowarnings); 116 $rv=list2NetAddr(\@inlist,\@NAobject); 117 $rv = matchNetAddr($ip,\@NAobject); 118 ($countries,$code3s,$names) = list_countries; 119 setAUTH(true/false); 120 setRA(true/false); 121 $netaddr = A1271; 122 $netaddr = A1272; 123 $netaddr = A1273; 124 $netaddr = A1274; 125 $netaddr = A1275; 126 $netaddr = A1276; 127 $netaddr = A1277; 128 129=head1 DESCRIPTION 130 131B<Net::DNSBL::Utilities> contains functions used to build DNSBL 132emulator daemons. 133 134=over 4 135 136=item * s_response($mp,$resp,$id,$qdcount,$ancount,$nscount,$arcount); 137 138Put a short response into the message buffer pointed to by $mp by 139sticking a new header on the EXISTING received query. 140 141 input: msg pointer, 142 id of question, 143 qd, an, ns, ar counts 144 returns: nada 145 146=cut 147 148sub s_response { 149 my($mp,$resp,$id,$qdcount,$ancount,$nscount,$arcount) = @_; 150 my $newhead; 151 my $off = newhead(\$newhead, 152 $id, 153 BITS_QUERY | $AuthBit | QR | $resp, 154 $qdcount,$ancount,$nscount,$arcount, 155 ); 156 substr($$mp,0,$off) = $newhead; 157} 158 159=item * not_found($put,$name,$type,$id,$mp,$srp); 160 161Put a new 'not found' response in the buffer pointed to by $mp. 162 163 input: put, 164 name, 165 type, 166 id, 167 message buffer pointer, 168 SOA record pointer 169 returns: nothing 170 171=cut 172 173sub not_found { 174 my($put,$name,$type,$id,$mp,$srp) = @_; 175 my $off = newhead($mp, 176 $id, 177 BITS_QUERY | $AuthBit | QR | NXDOMAIN, 178 1,0,1,0, 179 ); 180 my @dnptrs; 181 ($off,@dnptrs) = $put->Question($mp,$off,$name,$type,C_IN); 182# ($off,@dnptrs) = 183 $put->SOA($mp,$off,\@dnptrs,@$srp); 184} 185 186=item * write_stats($sfile,$cp,$sinit,$csize,$cache); 187 188Write out the contents of the accumulated statistics buffer to the STATs file. 189 190 input: statistics file path, 191 pointer to count hash, 192 initial timestamp line text 193 cache flag/max size 194 current cache size 195 returns: nothing 196 197=cut 198 199sub write_stats { 200 my($sfile,$cp,$sinit,$csize,$cache) = @_; 201 if ($sfile) { # record sfile on DNSBL lookups 202 if (open(S,'>'. $sfile .'.tmp')) { 203 print S '# last update '. localtime(time) ."\n"; 204 print S $sinit; 205 if ($csize) { # if cacheing 206 print S "# cache allocated: $csize, used: $cache\n"; 207 } 208 my $total = 0; 209 foreach(sort { 210 bystat($cp); 211 } keys %$cp) { 212 next if $_ =~ /^(White|Passed)/; 213 $total += $cp->{"$_"}; 214 print S $cp->{"$_"}, "\t$_\n"; 215 } 216 print S "# $total\ttotal rejects\n#\n"; 217 foreach(qw(WhiteList Passed)) { 218 print S $cp->{$_},"\t$_\n" if exists $cp->{$_}; 219 } 220 close S; 221 } 222 rename $sfile .'.tmp', $sfile; 223 } 224} 225 226=item * $rv = bystat($cp); 227 228Return sort value +-1 or 0 for stat sort 229 230 input: $a,$b sort values 231 pointer to count hash 232 returns: sort decision value 233 234=cut 235 236sub bystat { 237 my $cp = shift; 238 if ($a =~ /\./ && $b !~ /\./) { # sort domains to top 239 -1; 240 } 241 elsif ($a !~ /\./ && $b =~ /\./) { 242 1; 243 } 244 elsif ($a =~ /Black|White|Pass/ && # sort White/Black/Passed to bottom 245 $b !~ /Black|White|Pass/) { 246 1; 247 } 248 elsif ($a !~ /Black|White|Pass/ && 249 $b =~ /Black|White|Pass/) { 250 -1; 251 } 252 else { # sort by value, then alpha 253 ($cp->{$b} <=> $cp->{$a}) || $a cmp $b; 254 } 255} 256 257=item * $timestamp = statinit($Sfile,$cp); 258 259Initialize the contents of the statistics hash with the file contents 260of $Sfile, if $Sfile exists and there are corresponding entries in 261the statistics hash. i.e. the statistics hash keys must first be 262initialized with the DNSBL (or LABEL) names. 263 264 input: statistics file path, 265 pointer to count hash 266 returns: timestamp line for file 267 or undef on failure 268 269=cut 270 271sub statinit { 272 my($Sfile,$cp) = @_; 273 my $sti = '# stats since '. localtime(time) ."\n"; 274 if ($Sfile) { # stats entry?? 275 if ( -e $Sfile) { # old file exists 276 if (open(S,$Sfile)) { # skip if bad open 277 foreach(<S>) { 278 $sti = $_ if $_ =~ /# stats since/; # use old init time if present 279 next unless $_ =~ /^(\d+)\s+(.+)/; 280 $cp->{"$2"} = $1 if exists $cp->{"$2"} # add only existing dnsbls 281 } 282 close S; 283 return $sti; 284 } 285 } 286 elsif ($Sfile =~ m|[^/]+$| && -d $`) { # directory exists, no file yet 287 return $sti; # ok to proceed 288 } 289 } 290 return undef; 291} 292 293=item * cntinit($DNSBL,$cp); 294 295Initialize the statistics count hash with DNSBL keys and set the counts to zero. 296 297For compatibility with other applications, LABEL names other than the 298DNSBL's must NOT contain '.' Only the keys in the DNSBL hash that contain 299'.'s are added to the count hash. 300 301The count hash is first emptied if it is not null to begin with. 302 303 input: pointer to DNSBL hash, 304 pointer to counts hash 305 returns: nothing 306 307=cut 308 309sub cntinit { 310 my ($DNSBL,$cp) = @_; 311 %$cp = (); 312 foreach(keys %$DNSBL) { 313 next unless $_ =~ /.+\..+/; # skip non-dnsbl entries 314 $cp->{"$_"} = 0; # set up statistics counters for preferential sort 315 } 316 $cp->{WhiteList} = 0; # add entries for known good/bad guys 317 $cp->{BlackList} = 0; 318 $cp->{Passed} = 0; 319} 320 321=item * list2hash(\@list,$cp,$val); 322 323Add a list of names as keys to the statistics count hash and set the hash 324value to $val or zero if $val is not present. 325 326For compatibility with other applications, the labels in "list" must not 327contain the character '.' 328 329 input: pointer to list of labels, 330 pointer to counts hash, 331 value [optional] 332 returns: nothing 333 334=cut 335 336sub list2hash { 337 my ($lp,$cp,$val) = @_; 338 return unless $lp; 339 $val = 0 unless $val; 340 foreach(@$lp) { 341 $cp->{"$_"} = $val; 342 } 343} 344 345=item * $rv = DO($file,$nowarnings); 346 347This is a fancy 'do file'. It first checks that the file exists and is 348readable, then does a 'do file' to pull the variables and subroutines into 349the current name space. 350 351See the documentation L<File::SafeDO> 352 353 input: file/path/name 354 returns: last value in file 355 or undef on error 356 prints warning 357 358=item * $rv = DO($file,$nowarnings); 359 360This is a fancy 'do file'. It first checks that the file exists and is 361readable, then does a 'do file' to pull the variables and subroutines into 362the current name space. 363 364See the documentation L<File::SafeDO> 365 366 input: file/path/name 367 returns: last value in file 368 or undef on error 369 prints warning 370 371=item * $sock = open_udpNB(); 372 373Open and return a non-blocking UDP socket object 374 375 input: none 376 returns: pointer to socket object 377 or undef on failure 378 379=cut 380 381sub open_udpNB { 382# my $proto = getprotobyname('udp'); 383 _loadSocket() unless $A1271; 384 unless ($SKIP_POSIX) { 385 require POSIX; 386 $SKIP_POSIX = 1; 387 } 388 my $flags; 389 local *SOCKET; 390 return undef unless socket(SOCKET,&Socket::PF_INET,&Socket::SOCK_DGRAM,$UDP); 391 return *SOCKET if (($flags = fcntl(SOCKET,&POSIX::F_GETFL(),0)) || 1) && 392 fcntl(SOCKET,&POSIX::F_SETFL(),$flags | &POSIX::O_NONBLOCK()); 393 close SOCKET; 394 return undef; 395} 396 397=item * $rv=list2NetAddr(\@inlist,\@NAobject); 398 399Build of NetAddr object structure from a list of IPv4 addresses or address 400ranges. This object is passed to B<matchNetAddr> to check if a given IP 401address is contained in the list. 402 403 input: array reference pointer 404 to a list of addresses 405 406 i.e. 11.22.33.44 407 11.22.33.0/24 408 11.22.33.0/255.255.255.0 409 11.22.33.20-11.22.33.46 410 11.22.33.20 - 11.22.33.46 411 412 output: Number of objects created 413 or undef on error 414 415The NAobject array is filled with NetAddr::IP::Lite object references. 416 417=cut 418 419sub list2NetAddr { 420 my($inref,$outref) = @_; 421 return undef 422 unless ref $inref eq 'ARRAY' 423 && ref $outref eq 'ARRAY'; 424 unless ($SKIP_NetAddrIP) { 425 require NetAddr::IP::Lite; 426 $SKIP_NetAddrIP = 1; 427 } 428 @$outref = (); 429 my $IP; 430 no strict; 431 foreach $IP (@$inref) { 432 $IP =~ s/\s//g; 433 # 11.22.33.44 434 if ($IP =~ /^\d+\.\d+\.\d+\.\d+$/o) { 435 push @$outref, NetAddr::IP::Lite->new($IP), 0; 436 } 437 # 11.22.33.44 - 11.22.33.49 438 elsif ($IP =~ /^(\d+\.\d+\.\d+\.\d+)\s*\-\s*(\d+\.\d+\.\d+\.\d+)$/o) { 439 push @$outref, NetAddr::IP::Lite->new($1), NetAddr::IP::Lite->new($2); 440 } 441 # 11.22.33.44/63 442 elsif ($IP =~ m|^\d+\.\d+\.\d+\.\d+/\d+$|) { 443 push @$outref, NetAddr::IP::Lite->new($IP), 0; 444 } 445 # 11.22.33.44/255.255.255.224 446 elsif ($IP =~ m|^(\d+\.\d+\.\d+\.\d+)/(\d+\.\d+\.\d+\.\d+)$|o) { 447 push @$outref, NetAddr::IP::Lite->new($1,$2), 0; 448 } 449# ignore un-matched IP patterns 450 } 451 return (scalar @$outref)/2; 452} 453 454=item * $rv = matchNetAddr($ip,\@NAobject); 455 456Check if an IP address appears in a list of NetAddr objects. 457 458 input: dot quad IP address, 459 reference to NetAddr objects 460 output: true if match else false 461 462=cut 463 464sub matchNetAddr { 465 my($ip,$naref) = @_; 466 return 0 unless $ip && $ip =~ /\d+\.\d+\.\d+\.\d+/; 467 $ip =~ s/\s//g; 468 $ip = new NetAddr::IP::Lite($ip); 469 my $i; 470 for($i=0; $i <= $#{$naref}; $i += 2) { 471 my $beg = $naref->[$i]; 472 my $end = $naref->[$i+1]; 473 if ($end) { 474 return 1 if $ip >= $beg && $ip <= $end; 475 } else { 476 return 1 if $ip->within($beg); 477 } 478 } 479 return 0; 480} 481 482=item * ($countries,$code3s,$names) = list_countries; 483 484The function returns the list of 2 character, 3 character and country code 485names from the Geo::IP::PurePerl module if it is installed. 486 487 input: none 488 returns: \@countries,\@code3s,\@names 489 blessed into callers namespace 490 491NOTE: this process is very inefficient and should not be called in a 492repetitive fashion. 493 494If Geo::IP::PurePerl is not installed, the function returns and empty array 495and sets $@; 496 497=cut 498 499sub list_countries { 500 eval { 501 require Geo::IP::PurePerl or die "could not find need module Geo::IP::PurePerl\n"; 502 }; 503 return () if $@; 504 my $key = 'Geo/IP/PurePerl.pm'; 505 my $file = $INC{$key}; 506 my $stuff; 507 open(S,$file); 508 while ($stuff = <S>) { 509 last if $stuff =~ /countries\s+=\s+\(/; 510 } 511 while ($stuff .= <S>) { 512 last if (@_ = $stuff =~ /;/g) >= 3; 513 } 514 close S; 515 my($countries,$code3s,$names) = ([],[],[]); 516 $stuff =~ s/my\s+\@/\@\$/g; 517 518 eval "$stuff"; 519 520 my $caller = caller; 521 bless $countries, $caller; 522 bless $code3s, $caller; 523 bless $names, $caller; 524 return ($countries,$code3s,$names); 525} 526 527=item * setAUTH(true/false); 528 529Set the Authoratitive Answer bit true or false for all replys 530 531 input: true/false 532 returns: nothing 533 534=cut 535 536sub setAUTH { 537 if ($_[0]) { 538 $AuthBit = AA(); 539 } else { 540 $AuthBit = 0; 541 } 542} 543 544=item * setRA(true/false); 545 546Set the Recursion Allowed bit true or false for all replys 547 548 input: true/false 549 returns: nothing 550 551=cut 552 553sub setRA { 554 if ($_[0]) { 555 $RABit = RA(); 556 } else { 557 $RABit = 0; 558 } 559} 560 561=item * $netaddr = A127x 562 563Functions A1271, A1272, A1273, etc..., return the packed network address for 564127.0.0.1, 127.0.0.2, etc.... respectively 565 566=back 567 568=cut 569 570sub _loadSocket { 571 require Socket; 572 import Socket(@Socket::Export); 573 $A1271 = inet_aton('127.0.0.1'); 574 $A1272 = inet_aton('127.0.0.2'); 575 $A1273 = inet_aton('127.0.0.3'); 576 $A1274 = inet_aton('127.0.0.4'); 577 $A1275 = inet_aton('127.0.0.5'); 578 $A1276 = inet_aton('127.0.0.6'); 579 $A1277 = inet_aton('127.0.0.7'); 580} 581 582sub A1271 { 583 _loadSocket unless $A1271; 584 $A1271; 585} 586 587sub A1272 { 588 _loadSocket unless $A1272; 589 $A1272; 590} 591 592sub A1273 { 593 _loadSocket unless $A1273; 594 $A1273; 595} 596 597sub A1274 { 598 _loadSocket unless $A1274; 599 $A1274; 600} 601 602sub A1275 { 603 _loadSocket unless $A1275; 604 $A1275; 605} 606 607sub A1276 { 608 _loadSocket unless $A1276; 609 $A1276; 610} 611 612sub A1277 { 613 _loadSocket unless $A1277; 614 $A1277; 615} 616 617=head1 DEPENDENCIES 618 619 Net::DNS::Codes 620 Net::DNS::ToolKit 621 622=head1 EXPORT_OK 623 624 s_response 625 not_found 626 write_stats 627 bystat 628 statinit 629 cntinit 630 list2hash 631 open_udpNB 632 DO 633 list2NetAddr 634 matchNetAddr 635 list_countries 636 setAUTH 637 setRA 638 A1271 639 A1272 640 A1273 641 A1274 642 A1275 643 A1276 644 A1277 645 646=head1 AUTHOR 647 648Michael Robinton, michael@bizsystems.com 649 650=head1 COPYRIGHT 651 652Copyright 2003 - 2007, Michael Robinton & BizSystems 653This program is free software; you can redistribute it and/or modify 654it under the terms of the GNU General Public License as published by 655the Free Software Foundation; either version 2 of the License, or 656(at your option) any later version. 657 658This program is distributed in the hope that it will be useful, 659but WITHOUT ANY WARRANTY; without even the implied warranty of 660MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 661GNU General Public License for more details. 662 663You should have received a copy of the GNU General Public License 664along with this program; if not, write to the Free Software 665Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 666 667=head1 SEE ALSO 668 669L<Net::DNS::Codes>, L<Net::DNS::ToolKit>, L<Mail::SpamCannibal> 670 671=cut 672 6731; 674