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