1#!/usr/local/bin/perl 2package Net::DNSBL::MultiDaemon; 3 4use strict; 5#use diagnostics; 6 7use vars qw( 8 $VERSION @ISA @EXPORT_OK %EXPORT_TAGS *R_Sin 9 $D_CLRRUN $D_SHRTHD $D_TIMONLY $D_QRESP $D_NOTME $D_ANSTOP $D_VERBOSE 10); 11require Exporter; 12@ISA = qw(Exporter); 13 14# DEBUG is a set of semaphores 15$D_CLRRUN = 0x1; # clear run flag and force unconditional return 16$D_SHRTHD = 0x2; # return short header message 17$D_TIMONLY = 0x4; # exit at end of timer section 18$D_QRESP = 0x8; # return query response message 19$D_NOTME = 0x10; # return received response not for me 20$D_ANSTOP = 0x20; # clear run OK flag if ANSWER present 21$D_VERBOSE = 0x40; # verbose debug statements to STDERR 22 23$VERSION = do { my @r = (q$Revision: 0.39 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; 24 25@EXPORT_OK = qw( 26 run 27 bl_lookup 28 set_extension 29); 30%EXPORT_TAGS = ( 31 debug => [qw($D_CLRRUN $D_SHRTHD $D_TIMONLY $D_QRESP $D_NOTME $D_ANSTOP $D_VERBOSE uniqueID)], 32); 33Exporter::export_ok_tags('debug'); 34 35my $FATans = 0; # this causes a response size overflow from some DNSBLS that have 36 # many mirrors, so only the local host authority record is returned 37 38sub fatreturn { return $FATans }; # for testing 39 40my $eXT = undef; # extension code for "Private Use" as defined in outlined in RFC-6195 41 # Query types 42 # Classes 43 # Types 44 45use Socket; 46use Net::DNS::Codes qw( 47 TypeTxt 48 T_A 49 T_AAAA 50 T_ANY 51 T_MX 52 T_CNAME 53 T_NS 54 T_TXT 55 T_SOA 56 T_AXFR 57 T_PTR 58 C_IN 59 PACKETSZ 60 HFIXEDSZ 61 QUERY 62 NOTIMP 63 FORMERR 64 NOERROR 65 REFUSED 66 NXDOMAIN 67 SERVFAIL 68 BITS_QUERY 69 RD 70 QR 71 CD 72); 73use Net::DNS::ToolKit 0.16 qw( 74 newhead 75 gethead 76 get_ns 77); 78use Net::DNS::ToolKit::RR; 79#use Net::DNS::ToolKit::Debug qw( 80# print_head 81# print_buf 82#); 83 84#use Data::Dumper; 85 86use Net::DNSBL::Utilities 0.07 qw( 87 s_response 88 not_found 89 write_stats 90 statinit 91 A1271 92 A1272 93 A1274 94 A1275 95 A1276 96 A1277 97 list2NetAddr 98 matchNetAddr 99 setAUTH 100 setRA 101); 102 103# target for queries about DNSBL zones, create once per session 104# this is a global so it can be altered during testing 105*R_Sin = \scalar sockaddr_in(53,scalar get_ns()); 106 107=head1 NAME 108 109Net::DNSBL::MultiDaemon - multi DNSBL prioritization 110 111=head1 SYNOPSIS 112 113 use Net::DNSBL::MultiDaemon qw( 114 :debug 115 run 116 bl_lookup 117 set_extension 118 ); 119 120 run($BLzone,$L,$R,$DNSBL,$STATs,$Run,$Sfile,$StatStamp,$DEBUG) 121 bl_lookup($put,$mp,$rtp,$sinaddr,$alarm,$rid,$id,$rip,$type,$zone,@blist); 122 123=head1 DESCRIPTION 124 125B<Net::DNSBL::MultiDaemon> is the Perl module that implements the B<multi_dnsbl> 126daemon. 127 128B<multi_dnsbl> is a DNS emulator daemon that increases the efficacy of DNSBL 129look-ups in a mail system. B<multi_dnsbl> may be used as a stand-alone DNSBL 130or as a plug-in for a standard BIND 9 installation. 131B<multi_dnsbl> shares a common configuration file format with the 132Mail::SpamCannibal sc_BLcheck.pl script so that DNSBL's can be maintained in 133a common configuration file for an entire mail installation. 134 135Because DNSBL usefulness is dependent on the nature and source of spam sent to a 136specific site and because sometimes DNSBL's may provide intermittant 137service, B<multi_dnsbl> interrogates them sorted in the order of B<greatest 138successful hits>. DNSBL's that do not respond within the configured timeout 139period are not interrogated at all after 6 consecutive failures, and 140thereafter will be retried not more often than once every hour until they 141come back online. This eliminates the need to place DNSBL's in a particular order in 142your MTA's config file or periodically monitor the DNSBL statistics and/or update 143the MTA config file. 144 145In addition to optimizing DNSBL interrogation, B<multi_dnsbl> may be 146configured to locally accept or reject specified IP's, IP ranges and to 147reject specified countries by 2 character country code. By adding a DNSBL 148entry of B<in-addr.arpa>, IP's will be rejected that do not return some kind 149of valid reverse DNS lookup. In addition, IP's can be rejected that have a 150PTR record that matchs a configurable GENERIC 'regexp' set. 151 152Reject codes are as follows: 153 154 query 2.0.0.127.{zonename} 127.0.0.2 155 blocked by configured DNSBL 127.0.0.2 156 no reverse DNS 127.0.0.4 157 BLOCKED (local blacklist) 127.0.0.5 158 Blocked by Country 127.0.0.6 159 Blocked GENERIC 127.0.0.7 160 161=head1 OPERATION 162 163The configuration file for B<multi_dnsbl> contains optional IGNORE (always 164pass), optional BLOCK (always reject), and optional BBC (block by country) entries against 165which all received queries are checked before external DNSBL's are queried. 166IP's which pass IGNORE, BLOCK, and BBC test are then checked against the 167prioritized list of DNSBL's to try when looking up an IP address for blacklisting. 168Internally, B<multi_dnsbl> maintains this list in sorted order (including 169'in-addr.arpa') based on the number of responses that 170resulted in an acceptable A record being returned from the DNSBL query. For 171each IP address query sent to B<multi_dnsbl>, a query is sent to each 172configured DNSBL sequentially until all DNSBL's have been queried or an 173acceptable A record is returned. 174 175Let us say for example that blackholes.easynet.nl (below) will return an A record 176and list.dsbl.org, bl.spamcop.net, dynablock.easynet.nl, will not. 177 178 LIST 179 9451 list.dsbl.org 180 6516 bl.spamcop.net 181 2350 dynablock.easynet.nl 182 575 blackholes.easynet.nl 183 327 cbl.abuseat.org 184 309 dnsbl.sorbs.net 185 195 dnsbl.njabl.org 186 167 sbl.spamhaus.org 187 22 spews.dnsbl.net.au 188 6 relays.ordb.org 189 1 proxies.blackholes.easynet.nl 190 0 dsbl.org 191 192A query to B<multi_dnsbl> (pseudo.dnsbl in this example) looks like this 193 194 QUERY 195 1.2.3.4.pseudo.dnsbl 196 | 197 V 198 #################### 199 # multi_dnsbl # 200 #################### 201 | RESPONSE 202 +--> 1.2.3.4.list.dsbl.org NXDOMAIN 203 | 204 +--> 1.2.3.4.bl.spamcop.net NXDOMAIN 205 | 206 +--> 1.2.3.4.dynablock.easynet.nl NXDOMAIN 207 | 208 +--> 1.2.3.4.blackholes.easynet.nl A-127.0.0.2 209 210The A record is returned to originator of the Query and the statistics count 211on blackholes.easynet.nl is incremented by one. 212 213=head1 INSTALLATION / CONFIGURATION / OPERATION 214 215B<multi_dnsbl> can be installed as either a standalone DNSBL or as a plug-in 216to a BIND 9 installation on the same host. In either case, copy the 217rc.multi_daemon script to the appropriate startup directory on your host and 218modify the start, stop, restart scripts as required. Operation of the script 219is as follows: 220 221 Syntax: ./rc.multi_dnsbl start /path/to/config.file 222 ./rc.multi_dnsbl start -v /path/to/config.file 223 ./rc.multi_dnsbl stop /path/to/config.file 224 ./rc.multi_dnsbl restart /path/to/config.file 225 226 The -v switch will print the scripts 227 actions verbosely to the STDERR. 228 229=head2 CONFIGURATION FILE 230 231The configuration file for B<multi_dnsbl> shares a common format with the 232Mail::SpamCannibal sc_BLcheck.pl script, facilitating common maintenance of 233DNSBL's for your MTA installation. 234 235The sample configuration file 236B<multi_dnsbl.conf.sample> is heavily commented with the details for each 237configuration element. If you plan to use a common configuration file in a 238SpamCannibal installation, simply add the following elements to the 239B<sc_BlackList.conf> file: 240 241 MDstatfile => '/path/to/statistics/file.txt', 242 MDpidpath => '/path/to/pidfiles', # /var/run 243 MDzone => 'pseudo.dnsbl', 244 245 # OPTIONAL 246 MDstatrefresh => 300, # seconds 247 MDipaddr => '0.0.0.0', # PROBABLY NOT WHAT YOU WANT 248 MDport => 9953, 249 MDcache => 10000, # an entry takes ~400 bytes 250 # default 10000 (to small) 251 252### WARNING ### 253 failure to set MDipaddr to a valid ip address will result 254 in the authority section return an NS record of INADDR_ANY 255 This will return an invalid NS record in stand alone operation 256 257=head2 STANDALONE OPERATION 258 259For standalone operation, simply set B<MDport = 53>, nothing more is 260required. 261 262Interrogating the installation will then return the first 263match from the configured list of DNSBL servers. 264 265 i.e. dig 2.0.0.127.pseudo.dnsbl 266 267 .... results 268 269=head2 PLUGIN to BIND 9 270 271B<multi_dnsbl> may be used as a plugin helper for a standard bind 9 272installation by adding a B<forward> zone to the configuration file as 273follows: 274 275 //zone pseudo.dnsbl 276 zone "pseudo.dnsbl" in { 277 type forward; 278 forward only; 279 forwarders { 280 127.0.0.1 port 9953; 281 }; 282 }; 283 284You may also wish to add one or more of the following statements with 285appropriate address_match_lists to restrict access to the facility. 286 287 allow-notify {}; 288 allow-query { address_match_list }; 289 allow-recursion { address_match_list }; 290 allow-transfer {}; 291 292=head2 MTA CONFIGURATION 293 294Access to DNSBL lookup is configured in the normal fashion for each MTA. 295Since MTA's generally must interrogate on port 53, B<multi_dnsbl> must be 296installed on a stand-alone server or as a plugin for BIND 9. 297 298A typical configuration line for B<sendmail M4> configuration file is shown 299below: 300 301 FEATURE(`dnsbl',`pseudo.dnsbl', 302 `554 Rejected $&{client_addr} found in http://www.my.blacklist.org')dnl 303 304=head1 SYSTEM SIGNALS 305 306B<multi_dnsbl> responds to the following system signals: 307 308=over 4 309 310=item * TERM 311 312Operations the statistics file is updated with the internal counts and the 313daemon then exits. 314 315=item * HUP 316 317Operations are stopped including an update of the optional statistics file, 318the configuration file is re-read and operations are restarted. 319 320=item * USR1 321 322The statistics file is updated on the next second tick. 323 324=item * USR2 325 326The statistics file is deleted, internal statistics then a new (empty) 327statistics file is written on the next second tick. 328 329=back 330 331=head1 PERL MODULE DESCRIPTION 332 333B<Net::DNSBL::MultiDaemon> provides most of the functions that implement 334B<multi_dnsbl> which is an MTA helper that interrogates a list of 335DNSBL servers in preferential order based on their success rate. 336 337The following describes the workings of individual functions 338used to implement B<multi_dnsbl>. 339 340=over 4 341 342=item * run($BLzone,$L,$R,$DNSBL,$STATs,$Run,$Sfile,$StatStamp,$DEBUG); 343 344This function is the 'run' portion for the DNSBL multidaemon 345 346 input: 347 $BLzone zone name, 348 $L local listen socket object pointer, 349 $R remote socket object pointer, 350 $DNSBL config hash pointer, 351 $STATs statistics hash pointer 352 $Run pointer to stats refresh time, # must be non-zero 353 $Sfile statistics file path, 354 $StatStamp stat file initial time stamp 355 356 returns: nothing 357 358=over 2 359 360=item * $BLzone 361 362The fully qualified domain name of the blacklist lookup 363 364=item * $L 365 366A pointer to a UDP listener object 367 368=item * $R 369 370A pointer to a unbound UDP socket 371used for interogation and receiving replies for the multiple DNSBL's 372 373=item * $DNSBL 374 375A pointer to the configuration hash of the form: 376 377 $DNSBL = { 378 # Always allow these addresses 379 'IGNORE' => [ # OPTIONAL 380 # a single address 381 '11.22.33.44', 382 # a range of ip's, ONLY VALID WITHIN THE SAME CLASS 'C' 383 '22.33.44.55 - 22.33.44.65', 384 # a CIDR range 385 '5.6.7.16/28', 386 # a range specified with a netmask 387 '7.8.9.128/255.255.255.240', 388 # you may want these 389 '10.0.0.0/8', 390 '172.16.0.0/12', 391 '192.168.0.0/16', 392 # this should ALWAYS be here 393 '127.0.0.0/8', # ignore all test entries and localhost 394 ], 395 396 # Do rhbl lookups only, default false 397 # all other rejection classes are disabled, IGNORE, BLOCK, BBC, in-addr.arpa 398 # RHBL need only be "true" for operation. If OPTIONAL URBL conditioning 399 # is needed, then the parameters in the has must be added 400 RHBL => { # optional URBL preparation 401 urblwhite => [ 402 '/path/to/cached/whitefile', 403 '/path/to/local/file' # see format of spamassassin file 404 ], 405 urblblack => [ 406 '/path/to/local/blacklist' 407 ], 408# NOTE: level 3 tld's should be first before level 2 tld's 409 urbltlds => [ 410 '/path/to/cached/tld3file', 411 '/path/to/cached/tld2file' 412 ], 413 urlwhite => [ 414 'http://spamassasin.googlecode.com/svn-history/r6/trunk/share/spamassassin/25_uribl.cf', 415 '/path/to/cached/whitefile' 416 ], 417 urltld3 => [ 418 'http://george.surbl.org/three-level-tlds', 419 '/path/to/cached/tld3file' 420 ], 421 urltld2 => [ 422 'http://george.surbl.org/two-level-tlds', 423 '/path/to/cached/tld2file' 424 ], 425 }, 426 427 # Authoratative answers 428 'AUTH' => 0, 429 430 # Always reject these addresses 431 'BLOCK' => [ # OPTIONAL 432 # same format as above 433 ], 434 435 # Always block these countries 436 'BBC' => [qw(CN TW RO )], 437 438 # Check for reverse lookup failures - OPTIONAL 439 'in-addr.arpa' => { 440 timeout => 15, # default timeout is 30 441 }, 442 443 # RBL zones as follows: OPTIONAL 444 'domain.name' => { 445 # mark this dnsbl to require right hand side domain processing 446 # requires URBL::Prepare 447# NOT IMPLEMENTED 448# urbl => 1, 449 acceptany => 'comment - treat any response as valid', 450 # or 451 accept => { 452 '127.0.0.2' => 'comment', 453 '127.0.0.3' => 'comment', 454 }, 455 # or 456 # mask the low 8 bits and accept any true result 457 acceptmask => 0x3D, # accepts 0011 1101 458 459 # timeout => 30, # default seconds to wait for dnsbl 460 }, 461 462 'next.domain' = { 463 etc.... 464 # included but extracted external to B<run> 465 466 MDzone => 'pseudo.dnsbl', 467 MDstatfile => '/path/to/statistics/file.txt', 468 MDpidpath => '/path/to/pidfiles 469 # OPTIONAL, defaults shown 470 # MDstatrefresh => 300, # max seconds for refresh 471 # MDipaddr => '0.0.0.0', # PROBABLY NOT WHAT YOU WANT 472 # MDport => 9953, 473 # syslog. Specify the facility, one of: 474 # LOG_EMERG LOG_ALERT LOG_CRIT LOG_ERR LOG_WARNING LOG_NOTICE LOG_INFO LOG_DEBUG 475 # MDsyslog => 'LOG_WARNING', 476 # 477 # cache lookups using the TTL of the providing DNSBL 478 # each cache entry takes about 400 bytes, minimum size = 1000 479 # MDcache => 1000, # 1000 is too small 480 }; 481 482Zone labels that are not of the form *.*... are ignored, making this hash 483table fully compatible with the SpamCannibal sc_Blacklist.conf file. 484 485=item * $STATs 486 487A pointer to a statistics collection array of the form: 488 489 $STATs = { 490 'domain.name' => count, 491 etc..., 492 'CountryCode' => count, 493 etc... 494 }; 495 496Initialize this array with 497cntinit($DNSBL,$cp) L<Net::DNSBL::Utilities>/cntinit, then 498list2hash($BBC,$cp) L<Net::DNSBL::Utilities>/list2hash, then 499statinit($Sfile,$cp) L<Net::DNSBL::Utilities>/statinit, below. 500 501=item * $Run 502 503A POINTER to the time in seconds to refresh the $STATs backing file. Even if 504there is not backing file used, this value must be a positive integer. 505Setting this value to zero will stop the daemon and force a restart. It is 506used by $SIG{HUP} to restart the daemon. 507 508=item * $Sfile 509 510The path to the STATISTICS backing file. 511 512 i.e. /some/path/to/filename.ext 513 514If $Sfile is undefined, then the time stamp need not be defined 515 516=item * $StatTimestamp 517 518Normally the value returned by 519statinit($Sfile,$cp) L<Net::DNSBL::Utilities>/statinit, below. 520 521=back 522 523=cut 524 525my %AVGs = (); # averages 526my %CNTs = (); # current counts 527my $tick = 0; # second ticker 528my $interval = 300; # averaging interval 529my $bucket = 24 * 60 * 60; # 24 hours for now... 530my $weight = 5; # weight new stuff higher than old stuff 531my $csize = 0; # cache size and switch 532my $cused = 0; # cache in use 533my ($now, $next); 534my $newstat; # new statistics flag, used by run 535 536sub average { 537 my $STATs = shift; 538 my $multiplier = $bucket / ($bucket + (($now + $interval - $next) * $weight)); 539 $next = $now + $interval; # next average event 540 foreach (keys %$STATs) { 541 next unless $_ =~ /\./; # only real domains 542 next unless exists $CNTs{"$_"}; 543 $AVGs{"$_"} = ($AVGs{"$_"} + ($weight * $CNTs{"$_"})) * $multiplier; 544 $CNTs{"$_"} = 0; 545 } 546} 547 548# increment statistics for "real" DNSBL's 549# input: STATS pointer 550# DNSBL string 551 552sub bump_stats { 553 my($STATs, $blist_0) = @_; 554 $STATs->{"$blist_0"} += 1; # bump statistics count 555 if (exists $CNTs{"$blist_0"}) { 556 $CNTs{"$blist_0"} += 1; 557 } else { 558 $CNTs{"$blist_0"} = 1; 559 $AVGs{"$blist_0"} = 1; 560 } 561 $newstat = 1 unless $newstat; # notify refresh that update may be needed 562} 563 564sub by_average { 565 my($STATs,$a,$b) = @_;; 566 if (exists $AVGs{"$b"} && exists $AVGs{"$a"}) { 567 return ($AVGs{"$b"} <=> $AVGs{"$a"}) 568 || 569 ($STATs->{"$b"} <=> $STATs->{"$a"}); 570 } 571 elsif (exists $AVGs{"$b"}) { 572 return 1; 573 } 574 elsif (exists $AVGs{"$a"}) { 575 return -1; 576 } else { 577 return ($STATs->{"$b"} <=> $STATs->{"$a"}); 578 } 579} 580 581# reverse digits in ipV4 address 582# 583# input: ip 584# returns: reversed ip 585# 586sub revIP { 587 join('.',reverse split /\./,$_[0]); 588} 589 590# cache takes about 400 bytes per entry 591# 592my %cache = ( 593# 594# ip address => { 595# expires => time, now + TTL from response or 3600 minimum 596# used => time, time cache item was last used 597# who => $blist[0], which DNSBL caused caching 598# txt => 'string', txt from our config file or empty 599# }, 600); 601my @topurge; # working array 602 603# for testing 604# set now and next, csize return pointers to internal averaging arrays and cache 605# 606sub set_nownext { 607 ($now,$next,$csize) = @_; 608 return($interval,\%AVGs,\%CNTs,\%cache,\@topurge); 609} 610 611# purge cache when called from "run" 612 613my $prp = -1; # run pointer, see "mode" below 614my $pai; # array index 615my $pnd; # array end 616 617# piecewise purge of expired cache items performs gnome sort while purging 618# 619# followed by conditional purge of cache size overrun of oldest touched 620# cache items or those that will expire the soonest 621# 622# input: nothing 623# returns: mode 624# -1 waiting to be initialized 625# 0 purging expired elements + gnome sort 626# 1 purging cache overrun 627 628sub purge_cache { 629 if ($prp == 0) { # run state to purge expired elements 630 my $k1 = $topurge[$pai]; 631#print STDERR "$pnd, $pai"; 632 if (exists $cache{$k1}) { 633 my $j = $pai +1; 634 my $k2 = $topurge[$j]; 635 if ($cache{$k1}->{expires} < $now) { 636 delete $cache{$k1}; 637 splice(@topurge,$pai,1); # remove element from cache array 638 $pnd--; 639#print STDERR " delete k1 = $k1\n"; 640 } 641 elsif (exists $cache{$k2}) { 642 if ($cache{$k2}->{expires} < $now) { 643 delete $cache{$k2}; 644 splice(@topurge,$j,1); # remove element from cache array 645 $pnd--; 646#print STDERR " delete k2 = $k2\n"; 647 } 648 elsif ( $cache{$k1}->{used} > $cache{$k2}->{used} # oldest use 649 || ($cache{$k1}->{used} == $cache{$k2}->{used} # or if equal, 650 && $cache{$k1}->{expires} > $cache{$k2}->{expires}) # expires soonest 651 ) { 652 @topurge[$pai,$j] = @topurge[$j,$pai]; 653 $pai--; 654 $pai = 0 if $pai < 0; 655#print STDERR " swap k1, k2 - $k1 <=> $k2\n"; 656 } 657 else { 658 $pai++; 659#print STDERR " k1, k2 ok - $k1 : $k2\n"; 660 } 661 } 662 else { 663 splice(@topurge,$j,1); # remove element from cache array 664 $pnd--; 665#print STDERR " remove k2 = $k2\n"; 666 } 667 } 668 else { 669 splice(@topurge,$pai,1); # remove element from cache array 670 $pnd--; 671#print STDERR " remove k1 = $k1\n"; 672 } 673 return $prp if $pai < $pnd; # reached end? 674# done, set next state 675 $pnd++; 676 $pnd -= $csize; 677 if ($pnd > 0) { # must delete overrun elements 678 $prp = 1; 679 $pai = 0; 680 } else { 681 $prp = -1; # set to initialization state 682 } 683 } 684 elsif ($prp > 0) { # remove cache over run 685 my $k = $topurge[$pai]; 686 delete $cache{$k} if exists $cache{$k}; 687 $pai++; 688 unless ($pai < $pnd) { 689 $prp = -1; 690 } 691 } 692 else { 693 return $prp unless $csize; # not enabled 694 $pnd = @topurge = keys %cache; 695 $cused = $pnd; # update amount of cache in use 696 return $prp unless $pnd; # nothing to do 697 $pnd--; # end of array 698 $pai = 0; # array index 699 $prp = 0; # run state sort 700 } 701 return $prp; 702} 703 704# setURBLdom 705# 706# sets breadcrumbs for stripped domain for URBL's 707# 708# input: remote IP or domain 709# remote ID 710# notRHBL 711# ubl method pointer 712# blacklist host array pointer UNUSED 713# remoteThreads ptr 714# return: 715# SCALAR $rid 716# ARRAY ($rid,$whitelistedDomain,$SURBLookupDomain) 717# or false or false 718 719# $bap is unused 720 721sub setURBLdom { 722 my($rip,$rid,$notRHBL,$ubl,$bap,$rtp,$n) = @_; 723 if ($notRHBL || ! $ubl) { # don't even need to check 724 return wantarray ? ($rid) : $rid; # or URBL::Prepare not loaded 725 } 726 $rid = uniqueID() unless $rid; # set $rid if it is empty 727 $rtp->{$rid} = {} unless exists $rtp->{$rid}; 728 729 my $domain = ''; 730 my $white = $ubl->urblwhite($rip); 731 unless ($white) { 732 $domain = $ubl->urbldomain($rip); 733 } 734 735 $rtp->{$rid}->{urbl} = $domain; 736 $rtp->{$rid}->{N} = $n; 737 return wantarray ? ($rid,$white,$domain) : $rid; 738} 739 740sub run { 741 my ($BLzone,$L,$R,$DNSBL,$STATs,$Run,$Sfile,$StatStamp,$DEBUG) = @_; 742#open(Tmp,'>>/tmp/multidnsbl.log'); 743#print Tmp "---------------------------\n"; 744 local *_alarm = sub {return $DNSBL->{"$_[0]"}->{timeout} || 30}; 745 $BLzone = lc $BLzone; 746 my $myip = $DNSBL->{MDipaddr} || ''; 747 if ($myip && $myip ne '0.0.0.0') { 748 $myip = inet_aton($myip); 749 } else { 750 $myip = A1271; 751 } 752 $DEBUG = 0 unless $DEBUG; 753 my $ROK = ($DEBUG & $D_CLRRUN) ? 0:1; 754 755 my ( $msg, $t, $targetIP, $cc, $comment, 756 $Oname,$Otype,$Oclass,$Ottl,$Ordlength,$Odata, 757 $off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode, 758 $qdcount,$ancount,$nscount,$arcount, 759 $name,$type,$class, 760 $ttl,$rdl,@rdata, 761 $l_Sin,$rip,$zone,@blist, 762 %remoteThreads,$rid, 763 $rin,$rout,$nfound, 764 $BBC,@NAignore,@NAblock, 765 $notRHBL,$ubl); 766 767 my $LogLevel = 0; 768 if ($DNSBL->{MDsyslog}) { # if logging requested 769 require Unix::Syslog; 770 import Unix::Syslog @Unix::Syslog::EXPORT_OK; 771 $LogLevel = eval "$DNSBL->{MDsyslog}"; 772## NOTE, logging must be initiated by the caller 773 } 774 775# generate NetAddr objects for addresses to always pass 776 if ($DNSBL->{IGNORE} && ref $DNSBL->{IGNORE} eq 'ARRAY' && @{$DNSBL->{IGNORE}}) { 777 list2NetAddr($DNSBL->{IGNORE},\@NAignore); 778 } 779 780# generate NetAddr objects for addresses to always reject 781 if ($DNSBL->{BLOCK} && ref $DNSBL->{BLOCK} eq 'ARRAY' && @{$DNSBL->{BLOCK}}) { 782 list2NetAddr($DNSBL->{BLOCK},\@NAblock); 783 } 784 785# fetch pointer to Geo::IP methods 786 if ($DNSBL->{BBC} && ref $DNSBL->{BBC} eq 'ARRAY' && @{$DNSBL->{BBC}} && eval { require Geo::IP::PurePerl }) { 787 $BBC = new Geo::IP::PurePerl; 788 } else { 789 $DNSBL->{BBC} = ''; 790 } 791 792# check for caching 793 if (exists $DNSBL->{MDcache}) { 794 $csize = $DNSBL->{MDcache}; 795 $csize = 10000 if $DNSBL->{MDcache} < 10000; 796 } 797 798# check for right hand side block list operation 799 if ($DNSBL->{RHBL}) { 800 $notRHBL = 0; 801 if (ref $DNSBL->{RHBL} && 802 ((exists $DNSBL->{RHBL}->{urbltlds} && ref($DNSBL->{RHBL}->{urbltlds}) eq 'ARRAY') || 803 (exists $DNSBL->{RHBL}->{urblwhite} && ref($DNSBL->{RHBL}->{urblwhite}) eq 'ARRAY') || 804 (exists $DNSBL->{RHBL}->{urblblack} && ref($DNSBL->{RHBL}->{urblblack}) eq 'ARRAY')) && 805 eval { 806 no warnings; 807 require URBL::Prepare; 808 } 809 ) { 810 $ubl = new URBL::Prepare; 811 if (exists $DNSBL->{RHBL}->{urlwhite} && ref($DNSBL->{RHBL}->{urlwhite}) eq 'ARRAY') { 812 $ubl->loadcache(@{$DNSBL->{RHBL}->{urlwhite}}); # cache whitelist file 813 } 814 if (exists $DNSBL->{RHBL}->{urltld3} && ref($DNSBL->{RHBL}->{urltld3}) eq 'ARRAY') { 815 $ubl->loadcache(@{$DNSBL->{RHBL}->{urltld3}}); # cache tld3 file 816 } 817 if (exists $DNSBL->{RHBL}->{urltld2} && ref($DNSBL->{RHBL}->{urltld2}) eq 'ARRAY') { 818 $ubl->loadcache(@{$DNSBL->{RHBL}->{urltld2}}); # cache tld2 file 819 } 820 $ubl->cachetlds($DNSBL->{RHBL}->{urbltlds}); 821 $ubl->cachewhite($DNSBL->{RHBL}->{urblwhite}); 822 $ubl->cacheblack($DNSBL->{RHBL}->{urblblack}); 823 } 824 } else { 825 $notRHBL = 1; 826 } 827#select Tmp; 828#$| = 1; 829#print Tmp "running $$\n"; 830#select STDOUT; 831 832 833# set up GENERIC PTR tests 834 my($iptr,$regexptr); 835 if ( exists $DNSBL->{GENERIC} && 836 ref $DNSBL->{GENERIC} eq 'HASH' && 837 ($regexptr = $DNSBL->{GENERIC}->{regexp}) && 838 ref $regexptr eq 'ARRAY' && 839 @$regexptr > 0 ) { 840#print Tmp "regexptr setup, @$regexptr\n"; 841 unless ( $DNSBL->{GENERIC}->{ignore} && 842 'ARRAY' eq ref ($iptr = $DNSBL->{GENERIC}->{ignore}) && 843 @$iptr > 0 ) { 844 undef $iptr; 845 } 846 } else { 847#print Tmp "regexptr FAILED\n"; 848 undef $regexptr; 849 } 850 851 my $filenoL = fileno($L); 852 my $filenoR = fileno($R); 853 854 $now = time; 855 $next = $now + $interval; 856 $newstat = 0; # new statistics flag 857 my $refresh = $now + $$Run; # update statistics "then" 858 859 local $SIG{USR1} = sub {$newstat = 2}; # force write of stats now 860 local $SIG{USR2} = sub { # kill and regenerate statfile 861 return unless $Sfile; 862 unlink $Sfile; 863 foreach(keys %$STATs) { 864 $STATs->{"$_"} = 0; 865 %AVGs = (); 866 %CNTs = (); 867 } 868 $StatStamp = statinit($Sfile,$STATs); 869 syslog($LogLevel,"received USR2, clear stats\n") 870 if $LogLevel; 871 $newstat = 2; # re-write on next second tick 872 }; 873 874 my $SOAptr = [ # set up bogus SOA 875 $BLzone, 876 &T_SOA, 877 &C_IN, 878 0, # ttl of SOA record 879 $BLzone, 880 'root.'. $BLzone, 881 $now, 882 86400, 883 43200, 884 172800, 885 3600, # cache negative TTL's for an hour 886 ]; 887 888 my ($get,$put,$parse) = new Net::DNS::ToolKit::RR; 889 890 my $numberoftries = 6; 891 892 my %deadDNSBL; 893 foreach(keys %$STATs) { 894 next unless $_ =~ /\./; # only real domains 895 $deadDNSBL{"$_"} = 1; # initialize dead DNSBL timers 896 } 897 898 do { 899 $rin = ''; 900 vec($rin,$filenoL,1) = 1; # always listening to local port 901 (vec($rin,$filenoR,1) = 1) # listen to remote only if traffic expected 902 if %remoteThreads; 903 $nfound = select($rout=$rin,undef,undef,1); # tick each second 904 if ($nfound > 0) { 905###################### IF PROCESS REQUEST ######################## 906 while (vec($rout,$filenoL,1)) { # process request 907 last unless ($l_Sin = recv($L,$msg,PACKETSZ,0)); # ignore receive errors 908 if (length($msg) < HFIXEDSZ) { # ignore if less then header size 909 return 'short header' if $DEBUG & $D_SHRTHD; 910 last; 911 } 912 ($off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode, 913 $qdcount,$ancount,$nscount,$arcount) 914 = gethead(\$msg); 915 if ($qr) { 916 return 'query response' if $DEBUG & $D_QRESP; 917 last; 918 } 919 $comment = 'no bl'; 920 setAUTH(0); # clear authority 921 setRA($rd); 922# if OPCODE 923 if ($eXT && exists $eXT->{OPCODE} && $eXT->{OPCODE}->($eXT,$get,$put,\$msg, 924 $off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,$qdcount,$ancount,$nscount,$arcount)) { 925 ; # message updated 926 $comment = 'mdextension opcode'; 927 } elsif ($opcode != QUERY) { 928 s_response(\$msg,NOTIMP,$id,1,0,0,0); 929 $comment = 'not implemented'; 930 } elsif ( 931 $qdcount != 1 || 932 $ancount || 933 $nscount || 934 $arcount 935 ) { 936 s_response(\$msg,FORMERR,$id,$qdcount,$ancount,$nscount,$arcount); 937 $comment = 'format error 1'; 938 } elsif ( 939 (($off,$name,$type,$class) = $get->Question(\$msg,$off)) && 940 ! $name) { # name must exist 941 s_response(\$msg,FORMERR,$id,1,0,0,0); 942 $comment = 'format error 2'; 943# if CLASS 944 } elsif (!($eXT && exists $eXT->{CLASS} && $eXT->{CLASS}->($eXT,$get,$put,$id,$opcode,\$name,\$type,\$class)) && 945 $class != C_IN) { # class must be C_IN 946 s_response(\$msg,REFUSED,$id,$qdcount,$ancount,$nscount,$arcount); 947 $comment = 'refused'; 948# if NAME 949 } elsif (($eXT && exists $eXT->{NAME} && $eXT->{NAME}->($eXT,$get,$put,$id,$opcode,\$name,\$type,\$class)) || 950 $name !~ /$BLzone$/i) { # question must be for this zone 951 s_response(\$msg,NXDOMAIN,$id,1,0,0,0); 952 $comment = 'not this zone'; 953 } else { 954# THIS IS OUR ZONE request, generate a thread to handle it 955 956 print STDERR $name,' ',TypeTxt->{$type},' ' if $DEBUG & $D_VERBOSE; 957 958# if TYPE 959 if ($eXT && exists $eXT->{TYPE} && (my $rv = $eXT->{TYPE}->($eXT,$get,$put,$id,$opcode,\$name,\$type,\$class))) { 960 $msg = $rv; 961 $comment = 'Extension type'; 962 } elsif ( $type == T_A || 963 $type == T_ANY || 964 $type == T_TXT) { 965 if (( $notRHBL && 966 $name =~ /^((\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3}))\.(.+)/ && 967 ($rip = $1) && 968 ($targetIP = "$5.$4.$3.$2") && 969 ($zone = $6) && 970 $BLzone eq lc $zone) || 971# check for valid RFC1034 domain name, but allow digits in the first character 972 (!$notRHBL && # check RHBL zones 973###### CHANGE this REGEXP to alter permissible domain name patterns 974 $name =~ /^([a-zA-Z0-9][a-zA-Z0-9\.\-]+[a-zA-Z0-9])\.$BLzone$/ && # valid domain name 975 ($rip = $1) && 976 ($targetIP = '' || 1) && 977 ($zone = $BLzone))) { 978 my $expires; 979# if CACHE 980 if ($eXT && exists $eXT->{CACHE} && (my $rv = $eXT->{CACHE}->($eXT,$get,$put,$id,$opcode,$rip,\$name,\$type,\$class,$ubl))) { 981 $msg = $rv; 982 } 983# if local white/black lists 984 elsif (!$notRHBL && $ubl && # right side checking and local white/black lists 985 do { 986 if ($ubl->urblwhite($rip)) { 987 not_found($put,$name,$type,$id,\$msg,$SOAptr); 988 $rv = 'whitelisted'; 989 } 990 elsif ($ubl->urblblack($rip)) { 991 ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1272,$BLzone,$myip,'blacklisted'); 992 $rv = 'blacklisted'; 993 } 994 } 995 ) { 996 $comment = $rv; 997 } 998 elsif ($rip eq '2.0.0.127') { # checkfor DNSBL test 999 ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1272,$BLzone,$myip,'DNSBL test response to 127.0.0.2'); 1000 $comment = 'just testing'; 1001 } 1002### NOTE, $now does not get updated very often if the host is busy processing in this routine, but at least every 5 minutes.... good enough 1003 elsif ( $csize && # cacheing enabled 1004 exists $cache{$rip} && # item exists in cache 1005 ($expires = $cache{$rip}->{expires}) > $now ) { # cache not expired 1006 $cache{$rip}->{used} = $now; # update last used time 1007 my $blist_0 = $cache{$rip}->{who}; 1008 my $txt = $cache{$rip}->{txt}; 1009 $txt = $txt ? $txt . $targetIP : ''; 1010 ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,$expires - $now,A1272,$BLzone,$myip,$txt); # send cached record 1011 $comment = 'cache record'; 1012 bump_stats($STATs,$blist_0); 1013 } 1014 elsif ($type == T_TXT) { # none of the rest of static stuff has TXT records 1015 not_found($put,$name,$type,$id,\$msg,$SOAptr); 1016 $comment = 'no TXT'; 1017 } 1018 elsif ($notRHBL && @NAignore && matchNetAddr($targetIP,\@NAignore)) { # check for IP's to always pass 1019 not_found($put,$name,$type,$id,\$msg,$SOAptr); # return unconditional NOT FOUND 1020 $STATs->{WhiteList} += 1; # bump WhiteList count 1021 $comment = 'IGNORE'; 1022 } 1023 elsif ($notRHBL && @NAblock && matchNetAddr($targetIP,\@NAblock)) { # check for IP's to always block 1024 ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1275,$BLzone,$myip); # answer 127.0.0.5 1025 $STATs->{BlackList} += 1; # bump BlackList count 1026 $comment = 'BLOCK'; 1027 } 1028 elsif ($notRHBL && $BBC && # check for IP's to block by country 1029 ($cc = $BBC->country_code_by_addr($targetIP)) && 1030 (grep($cc eq $_,@{$DNSBL->{BBC}}))) { 1031 ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1276,$BLzone,$myip); # answer 127.0.0.6 1032 $STATs->{$cc} += 1; # bump statistics count 1033 $newstat = 1 unless $newstat; # notify refresh that update may be needed 1034 $comment = "block $cc"; 1035 } 1036 else { 1037#test here for GENERIC 1038 @blist = (); 1039 foreach(sort { by_average($STATs,$a,$b) } keys %$STATs) { 1040 next unless $_ =~ /\./; # drop passed,white,black,bbc entries 1041 push @blist, $_; 1042 } 1043 push @blist, 'genericPTR' if $regexptr; 1044# add bread crumbs for Extensions if necessary 1045 $rid = undef; # trial remote ID 1046 if ($eXT && exists $eXT->{LOOKUP}) { 1047 $rid = uniqueID(); 1048 $rid = $eXT->{LOOKUP}->($eXT,$get,$put,$rid,$id,$opcode,\$name,\$type,\$class,\%remoteThreads); 1049 } 1050 $rid = setURBLdom($rip,$rid,$notRHBL,$ubl,$DNSBL->{$blist[0]},\%remoteThreads,0); # initialize urbl domain lookup name 1051 bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$rid,$id,$rip,$type,$zone,@blist); 1052 send($R,$msg,0,$R_Sin); # udp may not block 1053 print STDERR $blist[0] if $DEBUG & $D_VERBOSE; 1054 last; 1055 } 1056 } 1057 elsif ($BLzone eq lc $name && $type != T_TXT) { 1058 my $noff = newhead(\$msg, 1059 $id, 1060 BITS_QUERY | QR, 1061 1,1,1,0, 1062 ); 1063 ($noff,my @dnptrs) = $put->Question(\$msg,$noff, # 1 question 1064 $name,$type,C_IN); # type is T_A 1065 ($noff,@dnptrs) = $put->A(\$msg,$noff,\@dnptrs, # 1 answer 1066 $name,T_A,C_IN,86400,$myip); 1067 ($noff,@dnptrs) = $put->NS(\$msg,$noff,\@dnptrs, # 1 authority 1068 $name,T_NS,C_IN,86400,$BLzone); 1069 } 1070 else { 1071 not_found($put,$name,$type,$id,\$msg,$SOAptr); 1072 } 1073 } elsif ($type == T_NS && $BLzone eq lc $name) { # respond with myip address 1074 my $noff = newhead(\$msg, 1075 $id, 1076 BITS_QUERY | QR, 1077 1,1,0,1, 1078 ); 1079 ($noff,my @dnptrs) = $put->Question(\$msg,$noff, # 1 question 1080 $name,$type,C_IN); # type is T_NS 1081 ($noff,@dnptrs) = $put->NS(\$msg,$noff,\@dnptrs, # 1 answer 1082 $name,T_NS,C_IN,$86400,$BLzone); 1083 ($noff,@dnptrs) = $put->A(\$msg,$noff,\@dnptrs, # 1 additional glue 1084 $BLzone,T_A,C_IN,86400,$myip); 1085 } elsif ($type == T_NS || # answer common queries with a not found 1086 $type == T_MX || 1087 $type == T_SOA || 1088 $type == T_CNAME || 1089 $type == T_TXT) { 1090 not_found($put,$name,$type,$id,\$msg,$SOAptr); 1091 } elsif ($type == T_AXFR) { 1092 s_response(\$msg,REFUSED,$id,1,0,0,0); 1093 $comment = 'refused AXFR'; 1094 } else { 1095 s_response(\$msg,NOTIMP,$id,1,0,0,0); 1096 $comment = 'not implemented'; 1097 } 1098 } 1099 send($L,$msg,0,$l_Sin); # udp may not block on send 1100 print STDERR " $comment\n" if $DEBUG & $D_VERBOSE; 1101#print Tmp "$comment\n"; 1102 last; 1103 } 1104##################### IF RESPONSE ############################### 1105 while (vec($rout,$filenoR,1)) { # A response 1106 undef $msg; 1107 last unless recv($R,$msg,,PACKETSZ,0); # ignore receive errors 1108 if (length($msg) < HFIXEDSZ) { # ignore if less then header size 1109 return 'short header' if $DEBUG & $D_SHRTHD; 1110 last; 1111 } 1112 ($off,$rid,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode, 1113 $qdcount,$ancount,$nscount,$arcount) 1114 = gethead(\$msg); 1115#print Tmp "GOT $rid, rcode=$rcode\n"; 1116 unless ( $tc == 0 && 1117 $qr == 1 && 1118 $opcode == QUERY && 1119 ($rcode == NOERROR || $rcode == NXDOMAIN || $rcode == SERVFAIL) && 1120 $qdcount == 1 && 1121 exists $remoteThreads{$rid}) { # must not be my question! 1122 return 'not me 1' if $DEBUG & $D_NOTME; 1123 last; 1124 } 1125 ($l_Sin,$rip,$id,$type,$zone,@blist) = @{$remoteThreads{$rid}->{args}}; 1126 my $urbldom = exists $remoteThreads{$rid}->{urbl} ? $remoteThreads{$rid}->{urbl} : ''; 1127 ($off,$name,$t,$class) = $get->Question(\$msg,$off); 1128 my($answer,$attl,@generic); 1129 if ($ancount && $rcode == &NOERROR) { 1130 $name =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\.(.+)$/ || $name =~ /^([a-zA-Z0-9][a-zA-Z0-9\.\-]+[a-zA-Z0-9])\.($blist[0])$/; 1131 my $z = lc $2; 1132#print Tmp "RESPONSE U $urbldom, R $rip, One $1, N $name, Z $z\n"; 1133 $z = ($z eq lc $blist[0]) || ($z eq 'in-addr.arpa' && $blist[0] eq 'genericPTR') 1134 ? 1 : 0; 1135 unless ( $z && # not my question 1136 ((!$urbldom && $rip eq $1) || 1137 ($urbldom && $urbldom eq $1)) && # not my question 1138 ($t == T_A || $t == T_PTR) && # not my question 1139 $class == C_IN) { # not my question 1140 return 'not me 2' if $DEBUG & $D_NOTME; 1141 last; 1142 } 1143 undef $answer; 1144 1145 setAUTH($aa); # mirror out authority state 1146 setRA($rd); 1147 1148 ANSWER: 1149 foreach(0..$ancount -1) { 1150 ($off,$name,$t,$class,$ttl,$rdl,@rdata) = $get->next(\$msg,$off); 1151 next if $answer; # throw away unneeded answers 1152 if ($t == T_A) { 1153 if (exists $DNSBL->{"$blist[0]"}->{acceptany}) { 1154 $answer = A1272; 1155 $attl = $ttl; 1156 last ANSWER; 1157 } 1158 my $mask = (exists $DNSBL->{"$blist[0]"}->{acceptmask}) 1159 ? $DNSBL->{"$blist[0]"}->{acceptmask} : 0; 1160 while($answer = shift @rdata) { # see if answer is on accept list 1161 my $IP = inet_ntoa($answer); 1162 if ($mask & unpack("N",$answer) || grep($IP eq $_,keys %{$DNSBL->{"$blist[0]"}->{accept}})) { 1163 $answer = A1272; 1164 $attl = $ttl; # preserve TTL of this responder 1165 last ANSWER; 1166 } 1167 undef $answer; 1168 } # end of rdata 1169 } 1170 elsif ($t == T_PTR && $blist[0] eq 'genericPTR') { # duplicates in-addr.arpa lookup, inefficient, but does not happen often 1171#print Tmp "add $rdata[0]\n"; 1172 push @generic, $rdata[0]; 1173 } 1174 } # end of each ANSWER 1175 $ttl = $attl; # restore responder TTL 1176 } 1177 elsif ($t == T_PTR && ($rcode == NXDOMAIN || $rcode == SERVFAIL)) { # no reverse lookup 1178#print Tmp "PTR w/ NXDOMAIN or SERVFAIL\n"; 1179 $answer = A1274; 1180 $ttl = 3600; 1181 $nscount = $arcount = 0; 1182 } 1183 1184 if (@generic) { 1185 my @names; 1186 foreach my $g (@generic) { 1187 last if $iptr && grep($g =~ /$_/i, @$iptr); 1188 push @names, $g if $g && ! grep($g =~ /$_/i, @$regexptr); 1189 } 1190 $answer = A1277 unless @names; 1191 $ttl = 3600; 1192 } 1193 if ($answer) { # if valid answer 1194 my $txt = ''; 1195 if ( $csize && # caching enabled && answer is from a real DSNBL 1196 ($answer == A1272 || $answer == A1274 || $answer == A1277) ) { 1197 1198# ip address => { 1199# expires => time, now + TTL from response or 3600 minimum 1200# used => time, time cache item was last used 1201# who => $blist[0], which DNSBL caused caching 1202# txt => 'string', txt from our config file or empty 1203# }, 1204 $txt = $DNSBL->{$blist[0]}->{error} if exists $DNSBL->{$blist[0]}; 1205 my $trailer = $notRHBL ? revIP($rip) : ''; 1206 $txt = $txt ? $txt . $trailer : ''; 1207 $cache{$rip} = { 1208 expires => $now + $ttl, # use responding DNSBL remaining ttl 1209 used => $now, 1210 who => $blist[0], 1211 txt => $txt 1212 }; 1213 } 1214 bump_stats($STATs,$blist[0]); 1215# $STATs->{"$blist[0]"} += 1; # bump statistics count 1216# if (exists $CNTs{"$blist[0]"}) { 1217# $CNTs{"$blist[0]"} += 1; 1218# } else { 1219# $CNTs{"$blist[0]"} = 1; 1220# $AVGs{"$blist[0]"} = 1; 1221# } 1222# $newstat = 1 unless $newstat; # notify refresh that update may be needed 1223 1224 my($nmsg,$noff,@dnptrs) = ($FATans) # make proto answer 1225 ? _ansrbak($put,$id,$nscount + $arcount +1,$rip,$zone,$type,$ttl,$answer,$BLzone,$myip,$txt) 1226 : _ansrbak($put,$id,1,$rip,$zone,$type,$ttl,$answer,$BLzone,$myip,$txt); 1227## add the ns section from original reply into the authority section so we can see where it came from, it won't hurt anything 1228 if ($FATans) { 1229 foreach(0..$nscount -1) { 1230 ($off,$Oname,$Otype,$Oclass,$Ottl,$Ordlength,$Odata) 1231 = $get->next(\$msg,$off); 1232 ($noff,@dnptrs) = $put->NS(\$nmsg,$noff,\@dnptrs, 1233 $Oname,$Otype,$Oclass,$Ottl,$Odata); 1234 } 1235 1236# add the authority section from original reply so we can see where it came from 1237 foreach(0..$arcount -1) { 1238 ($off,$Oname,$Otype,$Oclass,$Ottl,$Ordlength,$Odata) 1239 = $get->next(\$msg,$off); 1240 if ($Otype == T_A) { 1241 ($noff,@dnptrs) = $put->A(\$nmsg,$noff,\@dnptrs, 1242 $Oname,$Otype,$Oclass,$Ottl,$Odata); 1243 } elsif ($Otype == T_AAAA) { 1244 ($noff,@dnptrs) = $put->AAAA(\$nmsg,$noff,\@dnptrs, 1245 $Oname,$Otype,$Oclass,$Ottl,$Odata); 1246 } else { 1247 next; # skip unknown authority types 1248 } 1249 } 1250 } # end FATans 1251# if ANSWER 1252 if ($eXT && exists $eXT->{ANSWER} && $eXT->{ANSWER}->($eXT,$get,$put,$rid,$ttl,\$nmsg,\%remoteThreads)) { 1253 ; # will update $nmsg 1254 } 1255 delete $remoteThreads{$rid}; 1256 $msg = $nmsg; 1257 $ROK = 0 if $DEBUG & $D_ANSTOP; 1258 } 1259# no answer 1260 elsif (do { 1261 print STDERR '+' if $DEBUG & $D_VERBOSE; 1262#print Tmp "While eliminate $rid $blist[0]\n"; 1263 my $rv = 0; 1264 while(!$rv) { 1265 shift @blist; 1266 unless (@blist) { 1267 $rv = 1; 1268 } else { 1269 last unless $deadDNSBL{"$blist[0]"} > $numberoftries; # ignore hosts that don't answer 1270 } 1271 } 1272 $rv; 1273 }) { # if no more hosts 1274# if NOTFOUND 1275 not_found($put,$rip .'.'. $zone,$type,$id,\$msg,$SOAptr) # send not found response 1276 unless $eXT && exists $eXT->{NOTFOUND} && $eXT->{NOTFOUND}->($eXT,$get,$put,$rid,$rip,\$type,\$zone,\$msg,\%remoteThreads); 1277 delete $remoteThreads{$rid}; 1278# endif 1279 $STATs->{Passed} += 1; 1280 $newstat = 1 unless $newstat; # notify refresh that update may be needed 1281 } else { 1282 $deadDNSBL{"$blist[0]"} = 1; # reset retry count 1283#print Tmp "NOTFOUND bl_lookup, R \n"; 1284 $rid = setURBLdom($rip,$rid,$notRHBL,$ubl,$DNSBL->{$blist[0]},\%remoteThreads,1); # initialize urbl domain lookup name 1285 bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$rid,$id,$rip,$type,$zone,@blist); 1286 print STDERR $blist[0] if $DEBUG & $D_VERBOSE; 1287 send($R,$msg,0,$R_Sin); # udp may not block 1288 last; 1289 } 1290 send($L,$msg,0,$l_Sin); 1291 1292 if ($DEBUG & $D_VERBOSE) { 1293 if ($answer) { 1294 print STDERR ' ',inet_ntoa($answer),"\n"; 1295 } else { 1296 print STDERR " no bl\n"; 1297 } 1298 } 1299 last; 1300 } 1301 } 1302##################### TIMEOUT, do busywork ####################### 1303 else { # must be timeout 1304 my $prpshadow = $prp; 1305 $now = time; # check various alarm status 1306 unless ($now < $next) { 1307 average($STATs); 1308 purge_cache() if $prp < 0; # initiate cache purge every 5 minutes or so 1309 } 1310 purge_cache() unless $prpshadow < 0; # run cache purge thread unless just initiated 1311 foreach $rid (keys %remoteThreads) { 1312 next unless $remoteThreads{$rid}->{expire} < $now; # expired?? 1313 1314 ($l_Sin,$rip,$id,$type,$zone,@blist) = @{$remoteThreads{$rid}->{args}}; 1315 1316 if (++$deadDNSBL{"$blist[0]"} > $numberoftries) { 1317 $deadDNSBL{"$blist[0]"} = 3600; # wait an hour to retry 1318 if ($LogLevel) { 1319 syslog($LogLevel, "timeout connecting to $blist[0]\n"); 1320 } 1321 } 1322 1323 if ($blist[0] eq 'in-addr.arpa') { # expired reverse DNS lookup ? 1324 delete $remoteThreads{$rid}; 1325 $deadDNSBL{"$blist[0]"} = 0; # reset timeout (this one never expires) 1326 my $txt = exists $DNSBL->{$blist[0]} 1327 ? $DNSBL->{$blist[0]}->{error} 1328 : ''; 1329 $cache{$rip} = { 1330 expires => $now + 3600, # always an hour 1331 used => $now, 1332 who => $blist[0], 1333 txt => $txt 1334 }; 1335 bump_stats($STATs,$blist[0]); 1336# $STATs->{"$blist[0]"} += 1; # bump statistics count 1337# if (exists $CNTs{"$blist[0]"}) { 1338# $CNTs{"$blist[0]"} += 1; 1339# } else { 1340# $CNTs{"$blist[0]"} = 1; 1341# $AVGs{"$blist[0]"} = 1; 1342# } 1343# $newstat = 1 unless $newstat; # notify refresh that update may be needed 1344 ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1274,$BLzone,$myip,$txt); 1345 send($L,$msg,0,$l_Sin); 1346 print STDERR " expired Rdns\n" if $DEBUG & $D_VERBOSE; 1347 } 1348 elsif (do { 1349 print STDERR '?' if $DEBUG & $D_VERBOSE; 1350 my $rv = 0; 1351 while(!$rv) { 1352 shift @blist; 1353 unless (@blist) { 1354 $rv = 1; 1355 } else { 1356 last unless $deadDNSBL{"$blist[0]"} > $numberoftries; # ignore hosts that don't answer 1357 } 1358 } 1359 $rv; 1360 }) { # if no more hosts 1361# if NOTFOUND 1362 not_found($put,$rip .'.'. $BLzone,$type,$id,\$msg,$SOAptr) # send not found response 1363 unless $eXT && exists $eXT->{NOTFOUND} && $eXT->{NOTFOUND}->($eXT,$get,$put,$rid,$rip,\$type,\$BLzone,\$msg,\%remoteThreads); 1364 delete $remoteThreads{$rid}; 1365# endif 1366 $STATs->{Passed} += 1; # count messages that pass thru this filter 1367 $newstat = 1 unless $newstat; # notify refresh that update may be needed 1368 send($L,$msg,0,$l_Sin); 1369 print STDERR " no bl\n" if $DEBUG & $D_VERBOSE; 1370 } else { 1371#print Tmp "second NOTFOUND\n"; 1372 bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$rid,$id,$rip,$type,$zone,@blist); 1373 send($R,$msg,0,$R_Sin); # udp may not block 1374 print STDERR $blist[0] if $DEBUG & $D_VERBOSE; 1375 } 1376 } 1377 foreach(keys %deadDNSBL) { # eventually retry dead DNSBL 1378 --$deadDNSBL{"$_"} if $deadDNSBL{"$_"} > $numberoftries; 1379 } 1380 if ($newstat > 1 || 1381 ($refresh < $now && $newstat)) { # update stats file 1382 write_stats($Sfile,$STATs,$StatStamp,$csize,$cused); 1383 $refresh = $now + $$Run; 1384 $newstat = 0; 1385 } 1386 return 'caught timer' if $DEBUG & $D_TIMONLY; 1387 } 1388 } while($$Run && $ROK); 1389 write_stats($Sfile,$STATs,$StatStamp,$csize,$cused) if $newstat; # always update on exit if needed 1390} 1391 1392# answer back prototype 1393# 1394# input: $put,$id,$arcount,$rip,$zone,$type,$ttl,$answer,$BLzone,$myip,$withtxt,$CD 1395# returns: $message,$off,@dnptrs 1396# 1397sub _ansrbak { 1398 my($put,$id,$arc,$rip,$zone,$type,$ttl,$ans,$BLzone,$myip,$withtxt,$CD) = @_; 1399 my $haveA = ($type == T_A || $type == T_ANY) ? 1 : 0; 1400 my $haveT = (($type == T_ANY || $type == T_TXT) && $withtxt) ? 1 : 0; 1401 $CD = $CD ? 0 : CD; 1402 my $nmsg; 1403 my $nans = $haveA + $haveT; 1404 my $noff = newhead(\$nmsg, 1405 $id, 1406 BITS_QUERY | QR, 1407 1,$nans,1,$arc, 1408 ); 1409 ($noff,my @dnptrs) = $put->Question(\$nmsg,$noff, # 1 question 1410 $rip .'.'. $zone,$type,C_IN); # type is T_A or T_ANY or T_TXT 1411 if ($haveA) { 1412 ($noff,@dnptrs) = $put->A(\$nmsg,$noff,\@dnptrs, # add 1 answer 1413 $rip .'.'. $zone,T_A,C_IN,$ttl,$ans); 1414 } 1415 if ($haveT) { 1416 ($noff,@dnptrs) = $put->TXT(\$nmsg,$noff,\@dnptrs, 1417 $rip .'.'. $zone,T_TXT,C_IN,$ttl,$withtxt); 1418 } 1419 ($noff,@dnptrs) = $put->NS(\$nmsg,$noff,\@dnptrs, # 1 authority 1420 $zone,T_NS,C_IN,86400,$BLzone); 1421 ($noff,@dnptrs) = $put->A(\$nmsg,$noff,\@dnptrs, # 1 additional glue 1422 $BLzone,T_A,C_IN,86400,$myip); # show MYIP 1423 return($nmsg,$noff,@dnptrs) 1424} 1425 1426=item * bl_lookup($put,$mp,$rtp,$sinaddr,$alarm,$rid,$id,$rip,$type,$zone,@blist); 1427 1428Generates a query message for the first DNSBL in the @blist array. Creates 1429a thread entry for the response and subsequent queries should the first one fail. 1430 1431 input: put, 1432 message pointer, 1433 remote thread pointer, 1434 sockinaddr, 1435 connection timeout, 1436 remote id or undef to create 1437 id of question, 1438 reverse IP address in text 1439 type of query received, (used in response) 1440 ORIGINAL zone (case preserved), 1441 array of remaining DNSBL's in sorted order 1442 returns: nothing, puts stuff in thread queue 1443 1444 extra: if URBL processing is required, 1445 $remoteThreads{$rid}->{urbl} 1446 is set to the domain to look up 1447 1448=cut 1449 1450# This function returns an integer between 1 -> 65535 in a pseudo-random 1451# repeatable order. Seeds with $$ by default, can be seeded with any integer; 1452# 1453 1454my $id = $$; 1455 1456sub uniqueID { 1457 $id = $_[0] ? ($_[0] % 65536) : $id; 1458 $id = 1 if $id < 1 || $id > 65534; 1459 $id++; 1460} 1461 1462sub bl_lookup { 1463 my($put,$mp,$rtp,$sinaddr,$alarm,$rid,$id,$rip,$type,$zone,@blist) = @_; 1464 $rid = uniqueID unless $rid; 1465 my $off = newhead($mp, 1466 $rid, 1467 BITS_QUERY | RD, 1468 1,0,0,0, 1469 ); 1470 my $blist = ($blist[0] eq 'genericPTR') 1471 ? 'in-addr.arpa' 1472 : $blist[0]; 1473 1474 my $Qtype = ($blist eq 'in-addr.arpa') 1475 ? &T_PTR 1476 : &T_A; 1477 1478# send conditioned URBL request if that is what is needed 1479 if ($rtp->{$rid}->{urbl}) { 1480 $put->Question($mp,$off,$rtp->{$rid}->{urbl}.'.'. $blist,$Qtype,C_IN); 1481 } else { 1482 $put->Question($mp,$off,$rip .'.'. $blist,$Qtype,C_IN); 1483 } 1484 $rtp->{$rid} = {} unless exists $rtp->{$rid}; 1485 $rtp->{$rid}->{args} = [$sinaddr,$rip,$id,$type,$zone,@blist]; 1486 $rtp->{$rid}->{expire} = time + $alarm; 1487#print Tmp "$blist => ",Dumper($rtp); 1488} 1489 1490=item * set_extension($pointer); 1491 1492This function sets a pointer to user defined extensions to 1493Net::DNSBL::MultiDaemon. 1494 1495Pointer is of the form: 1496 1497 $Extension ->{ 1498 OPCODE => value, 1499 CLASS => subref->($Extension,internal args), 1500 NAME => subref->($Extension,internal args), 1501 TYPE => subref->($Extension,internal args), 1502 LOOKUP => subref->($Extension,internal args), 1503 ANSWER => subref->($Extension,internal args), 1504 NOTFOUND => subref->($Extension,internal args) 1505 }; 1506 1507The pointer should be blessed into the package of the caller if the calling 1508package needs to store persistant variables for its own instance. The subref 1509will be called with the first argument of $Extension. 1510 1511Care should be taken to NOT instantiate a %remoteThreads in the CLASS, NAME, 1512TYPE section unless it is know that it will be found and expired/deleted. 1513 1514Read the code if you wish to add an extension 1515 1516=back 1517 1518=cut 1519 1520sub set_extension { 1521 $eXT = shift; 1522} 1523 1524=head1 DEPENDENCIES 1525 1526 Unix::Syslog 1527 Geo::IP::PurePerl [conditional for country codes] 1528 NetAddr::IP 1529 Net::DNS::Codes 1530 Net::DNS::ToolKit 1531 1532=head1 EXPORT_OK 1533 1534 run 1535 bl_lookup 1536 1537=head1 EXPORT_TAGS :debug 1538 1539 DEBUG is a set of semaphores for the 'run' function 1540 1541 $D_CLRRUN = 0x1; # clear run flag and force unconditional return 1542 $D_SHRTHD = 0x2; # return short header message 1543 $D_TIMONLY = 0x4; # exit at end of timer section 1544 $D_QRESP = 0x8; # return query response message 1545 $D_NOTME = 0x10; # return received response not for me 1546 $D_ANSTOP = 0x20; # clear run OK flag if ANSWER present 1547 $D_VERBOSE = 0x40; # verbose debug statements to STDERR 1548 1549=head1 AUTHOR 1550 1551Michael Robinton, michael@bizsystems.com 1552 1553=head1 COPYRIGHT 1554 1555Copyright 2003 - 2014, Michael Robinton & BizSystems 1556This program is free software; you can redistribute it and/or modify 1557it under the terms as Perl itself or the GNU General Public License 1558as published by the Free Software Foundation; either version 2 of 1559the License, or (at your option) any later version. 1560 1561This program is distributed in the hope that it will be useful, 1562but WITHOUT ANY WARRANTY; without even the implied warranty of 1563MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1564GNU General Public License for more details. 1565 1566You should have received a copy of the GNU General Public License 1567along with this program; if not, write to the Free Software 1568Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 1569 1570=head1 SEE ALSO 1571 1572L<URBL::Prepare>, L<Geo::IP::PurePerl>, L<Net::DNSBL::Utilities>, L<Net::DNS::Codes>, L<Net::DNS::ToolKit>, L<Mail::SpamCannibal> 1573 1574=cut 1575 15761; 1577