view release on metacpan or  search on metacpan

MultiDaemon.pm  view on Meta::CPAN

	  $comment = 'format error 2';
# if CLASS
	} elsif (!($eXT && exists $eXT->{CLASS} && $eXT->{CLASS}->($eXT,$get,$put,$id,$opcode,\$name,\$type,\$class)) &&
		$class != C_IN) {				# class must be C_IN
	  s_response(\$msg,REFUSED,$id,$qdcount,$ancount,$nscount,$arcount);
	  $comment = 'refused';
# if NAME
	} elsif (($eXT && exists $eXT->{NAME} && $eXT->{NAME}->($eXT,$get,$put,$id,$opcode,\$name,\$type,\$class)) ||
		$name !~ /$BLzone$/i) {			# question must be for this zone
	  s_response(\$msg,NXDOMAIN,$id,1,0,0,0);
	  $comment = 'not this zone';
	} else {
# THIS IS OUR ZONE request, generate a thread to handle it

	  print STDERR $name,' ',TypeTxt->{$type},' ' if $DEBUG & $D_VERBOSE;

# if TYPE
	  if ($eXT && exists $eXT->{TYPE} && (my $rv = $eXT->{TYPE}->($eXT,$get,$put,$id,$opcode,\$name,\$type,\$class))) {
	    $msg = $rv;
	    $comment = 'Extension type';
	  } elsif ( $type == T_A ||
	    $type == T_ANY ||
	    $type == T_TXT) {
	    if (( $notRHBL &&
		  $name =~ /^((\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3}))\.(.+)/ &&
		  ($rip = $1) &&
		  ($targetIP = "$5.$4.$3.$2") &&
		  ($zone = $6) &&
		  $BLzone eq lc $zone) ||
# check for valid RFC1034 domain name, but allow digits in the first character
		(!$notRHBL &&								# check RHBL zones
###### CHANGE this REGEXP to alter permissible domain name patterns
		  $name =~ /^([a-zA-Z0-9][a-zA-Z0-9\.\-]+[a-zA-Z0-9])\.$BLzone$/ &&	# valid domain name
		  ($rip = $1) &&
		  ($targetIP = '' || 1) &&
		  ($zone = $BLzone))) {
	      my $expires;
# if CACHE
	      if ($eXT && exists $eXT->{CACHE} && (my $rv = $eXT->{CACHE}->($eXT,$get,$put,$id,$opcode,$rip,\$name,\$type,\$class,$ubl))) {
		$msg = $rv;
	      }
# if local white/black lists
	      elsif (!$notRHBL && $ubl && 		# right side checking and local white/black lists
		  do {
			if ($ubl->urblwhite($rip)) {
			  not_found($put,$name,$type,$id,\$msg,$SOAptr);
			  $rv = 'whitelisted';
			}
			elsif ($ubl->urblblack($rip)) {
			  ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1272,$BLzone,$myip,'blacklisted');
			  $rv = 'blacklisted';
			}
		  }
	      ) {
		  $comment = $rv;
	      }
	      elsif ($rip eq '2.0.0.127') {				# checkfor DNSBL test
		($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1272,$BLzone,$myip,'DNSBL test response to 127.0.0.2');
		$comment = 'just testing';
	      }
### 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
	      elsif (	$csize && 					# cacheing enabled
			exists $cache{$rip} &&				# item exists in cache
			($expires = $cache{$rip}->{expires}) > $now ) {	# cache not expired
		$cache{$rip}->{used} = $now;				# update last used time
		my $blist_0 = $cache{$rip}->{who};
		my $txt = $cache{$rip}->{txt};
		$txt = $txt ? $txt . $targetIP : '';
	        ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,$expires - $now,A1272,$BLzone,$myip,$txt);	# send cached record
		$comment = 'cache record';
		bump_stats($STATs,$blist_0);
	      }
	      elsif ($type == T_TXT) {					# none of the rest of static stuff has TXT records
		not_found($put,$name,$type,$id,\$msg,$SOAptr);
		$comment = 'no TXT';
	      }
	      elsif ($notRHBL && @NAignore && matchNetAddr($targetIP,\@NAignore)) {	# check for IP's to always pass
		not_found($put,$name,$type,$id,\$msg,$SOAptr);		# return unconditional NOT FOUND
		$STATs->{WhiteList} += 1;				# bump WhiteList count
		$comment = 'IGNORE';
	      }
	      elsif ($notRHBL && @NAblock && matchNetAddr($targetIP,\@NAblock)) {	# check for IP's to always block
		($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1275,$BLzone,$myip);	# answer 127.0.0.5
		$STATs->{BlackList} += 1;				# bump BlackList count
		$comment = 'BLOCK';
	      }
	      elsif ($notRHBL && $BBC &&				# check for IP's to block by country
		     ($cc = $BBC->country_code_by_addr($targetIP)) &&
		     (grep($cc eq $_,@{$DNSBL->{BBC}}))) {
		($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1276,$BLzone,$myip);	# answer 127.0.0.6
		$STATs->{$cc} += 1;					# bump statistics count
		$newstat = 1 unless $newstat;				# notify refresh that update may be needed
		$comment = "block $cc";
	      }
	      else {
#test here for GENERIC
		@blist = ();
		foreach(sort { by_average($STATs,$a,$b) } keys %$STATs) {
		  next unless $_ =~ /\./;				# drop passed,white,black,bbc entries
		  push @blist, $_;
		}
		push @blist, 'genericPTR' if $regexptr;
# add bread crumbs for Extensions if necessary
		$rid = undef;	# trial remote ID
		if ($eXT && exists $eXT->{LOOKUP}) {
		  $rid = uniqueID();
		  $rid = $eXT->{LOOKUP}->($eXT,$get,$put,$rid,$id,$opcode,\$name,\$type,\$class,\%remoteThreads);
		}
		$rid = setURBLdom($rip,$rid,$notRHBL,$ubl,$DNSBL->{$blist[0]},\%remoteThreads,0);	# initialize urbl domain lookup name
		bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$rid,$id,$rip,$type,$zone,@blist);
		send($R,$msg,0,$R_Sin);				# udp may not block
		print STDERR $blist[0] if $DEBUG & $D_VERBOSE;
		last;
	      }
            }
	    elsif ($BLzone eq lc $name && $type != T_TXT) {
	      my $noff = newhead(\$msg,
	      $id,
	      BITS_QUERY | QR,
	      1,1,1,0,
	      );

MultiDaemon.pm  view on Meta::CPAN

		    $Oname,$Otype,$Oclass,$Ottl,$Odata);
	    } elsif ($Otype == T_AAAA) {
		($noff,@dnptrs) = $put->AAAA(\$nmsg,$noff,\@dnptrs,
		    $Oname,$Otype,$Oclass,$Ottl,$Odata);
	    } else {
		next;		# skip unknown authority types
	    }
	  }
  } # end FATans
# if ANSWER
	  if ($eXT && exists $eXT->{ANSWER} && $eXT->{ANSWER}->($eXT,$get,$put,$rid,$ttl,\$nmsg,\%remoteThreads)) {
	    ; # will update $nmsg
	  }
	  delete $remoteThreads{$rid};
	  $msg = $nmsg;
	  $ROK = 0 if $DEBUG & $D_ANSTOP;
	}
# no answer
	elsif (do {
		print STDERR '+' if $DEBUG & $D_VERBOSE;
#print Tmp "While eliminate $rid $blist[0]\n";
		my $rv = 0;
		while(!$rv) {
		  shift @blist;
		  unless (@blist) {
		    $rv = 1;
		  } else {
		    last unless $deadDNSBL{"$blist[0]"} > $numberoftries; # ignore hosts that don't answer
		  }
		}
		$rv;
	      }) {	# if no more hosts
# if NOTFOUND
	  not_found($put,$rip .'.'. $zone,$type,$id,\$msg,$SOAptr)	# send not found response
		unless $eXT && exists $eXT->{NOTFOUND} && $eXT->{NOTFOUND}->($eXT,$get,$put,$rid,$rip,\$type,\$zone,\$msg,\%remoteThreads);
	  delete $remoteThreads{$rid};
# endif
	  $STATs->{Passed} += 1;
	  $newstat = 1 unless $newstat;					# notify refresh that update may be needed
	} else {
	  $deadDNSBL{"$blist[0]"} = 1;					# reset retry count
#print Tmp "NOTFOUND bl_lookup, R \n";
	  $rid = setURBLdom($rip,$rid,$notRHBL,$ubl,$DNSBL->{$blist[0]},\%remoteThreads,1);	# initialize urbl domain lookup name
	  bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$rid,$id,$rip,$type,$zone,@blist);
	  print STDERR $blist[0] if $DEBUG & $D_VERBOSE;
	  send($R,$msg,0,$R_Sin);					# udp may not block
	  last;
	}
	send($L,$msg,0,$l_Sin);

	if ($DEBUG & $D_VERBOSE) {
	  if ($answer) {
	    print STDERR ' ',inet_ntoa($answer),"\n";
	  } else {
	    print STDERR " no bl\n";
	  }
	}
	last;
      }
    }
##################### TIMEOUT, do busywork #######################
    else {							# must be timeout
      my $prpshadow = $prp;
      $now = time;						# check various alarm status
      unless ($now < $next) {
	average($STATs);
	purge_cache() if $prp < 0;		# initiate cache purge every 5 minutes or so
      }
      purge_cache() unless $prpshadow < 0;	# run cache purge thread unless just initiated
      foreach $rid (keys %remoteThreads) {
	next unless $remoteThreads{$rid}->{expire} < $now;	# expired??

	($l_Sin,$rip,$id,$type,$zone,@blist) = @{$remoteThreads{$rid}->{args}};

	if (++$deadDNSBL{"$blist[0]"} > $numberoftries) {
	  $deadDNSBL{"$blist[0]"} = 3600;			# wait an hour to retry
	  if ($LogLevel) {
	    syslog($LogLevel, "timeout connecting to $blist[0]\n");
	  }
	}

	if ($blist[0] eq 'in-addr.arpa') {			# expired reverse DNS lookup ?
	  delete $remoteThreads{$rid};
	  $deadDNSBL{"$blist[0]"} = 0;				# reset timeout (this one never expires)
	  my $txt = exists $DNSBL->{$blist[0]}
		? $DNSBL->{$blist[0]}->{error}
		: '';
	  $cache{$rip} = {
		expires => $now + 3600,				# always an hour
		used	=> $now,
		who	=> $blist[0],
		txt	=> $txt
	  };
	  bump_stats($STATs,$blist[0]);
#	  $STATs->{"$blist[0]"} += 1;				# bump statistics count
#	  if (exists $CNTs{"$blist[0]"}) {
#	    $CNTs{"$blist[0]"} += 1;
#	  } else {
#	    $CNTs{"$blist[0]"} = 1;
#	    $AVGs{"$blist[0]"} = 1;
#	  }
#	  $newstat = 1 unless $newstat;				# notify refresh that update may be needed
	  ($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1274,$BLzone,$myip,$txt);
	  send($L,$msg,0,$l_Sin);
	  print STDERR " expired Rdns\n" if $DEBUG & $D_VERBOSE;
	}
	elsif (do {
		print STDERR '?' if $DEBUG & $D_VERBOSE;
		my $rv = 0;
		while(!$rv) {
		  shift @blist;
		  unless (@blist) {
		    $rv = 1;
		  } else {
		    last unless $deadDNSBL{"$blist[0]"} > $numberoftries; # ignore hosts that don't answer
		  }
		}
		$rv;
	      }) {	# if no more hosts
# if NOTFOUND
	  not_found($put,$rip .'.'. $BLzone,$type,$id,\$msg,$SOAptr)	# send not found response