#!/usr/bin/perl -w -T

# supporting tests for: Bug 6362 - Change urirhssub mask syntax

use strict;
use warnings;
use re 'taint';
use lib '.'; use lib 't';

use SATest; sa_t_init("dnsbl_subtests");

use vars qw(%patterns %anti_patterns);
use Test::More tests => 46;

use Errno qw(EADDRINUSE EACCES);
use Net::DNS::Nameserver;
use Mail::SpamAssassin;

# Bug 5761 (no 127.0.0.1 in jail, use SPAMD_LOCALHOST if specified)
my $dns_server_localaddr = $ENV{'SPAMD_LOCALHOST'};
if (!$dns_server_localaddr) {
  $dns_server_localaddr = $have_inet4 ? '127.0.0.1' : '::1';
}

my $use_inet4 =
  !$have_inet6 ||
  ($have_inet4 && $dns_server_localaddr =~ /^\d+\.\d+\.\d+\.\d+\z/);

sub find_free_port($);  # prototype
my($dns_server_localport, $sock_udp, $sock_tcp) =
  find_free_port($dns_server_localaddr);

$dns_server_localport  or die "Failed to obtain a free port number";

printf("Using %s [%s]:%s for a spawned test DNS server\n",
       $use_inet4 ? 'inet' : 'inet6',
       $dns_server_localaddr, $dns_server_localport);

# test zone names (lowercase!)
my $z  = 'sa1-dbl-test.spamassassin.org';
my $z2 = 'sa2-dbl-test.spamassassin.org';

my $local_conf = <<"EOD";
  use_bayes 0
  use_razor2 0
  use_pyzor 0
# use_auto_whitelist 0
# use_dcc 0
  score NO_RELAYS 0
  score NO_RECEIVED 0
  score TVD_SPACE_RATIO 0

  rbl_timeout 5
  dns_available yes
  clear_dns_servers
  dns_server [$dns_server_localaddr]:$dns_server_localport

# zone 1
  urirhssub  X_URIBL_Y_2A   $z  A  127.0.1.2
  body       X_URIBL_Y_2A   eval:check_uridnsbl('X_URIBL_Y_2A')
  tflags     X_URIBL_Y_2A   domains_only

  urirhssub  X_URIBL_Y_2B   $z  A  127.0.1.2-127.0.1.2
  body       X_URIBL_Y_2B   eval:check_uridnsbl('X_URIBL_Y_2B')
  tflags     X_URIBL_Y_2B   domains_only

  urirhssub  X_URIBL_Y_2C   $z  A  127.0.1.2/0xffffffff
  body       X_URIBL_Y_2C   eval:check_uridnsbl('X_URIBL_Y_2C')
  tflags     X_URIBL_Y_2C   domains_only

  urirhssub  X_URIBL_Y_2D   $z  A  127.0.1.2/255.255.255.255
  body       X_URIBL_Y_2D   eval:check_uridnsbl('X_URIBL_Y_2D')
  tflags     X_URIBL_Y_2D   domains_only

  urirhssub  X_URIBL_Y_2E   $z  A  127.0.1.2/127.0.1.2
  body       X_URIBL_Y_2E   eval:check_uridnsbl('X_URIBL_Y_2E')
  tflags     X_URIBL_Y_2E   domains_only

  urirhssub  X_URIBL_Y_2F   $z  A  0/128.255.254.253
  body       X_URIBL_Y_2F   eval:check_uridnsbl('X_URIBL_Y_2F')
  tflags     X_URIBL_Y_2F   domains_only

  urirhssub  X_URIBL_Y_2G   $z  A  2
  body       X_URIBL_Y_2G   eval:check_uridnsbl('X_URIBL_Y_2G')
  tflags     X_URIBL_Y_2G   domains_only

  urirhssub  X_URIBL_N_2G   $z  A  5
  body       X_URIBL_N_2G   eval:check_uridnsbl('X_URIBL_N_2G')
  tflags     X_URIBL_N_2G   domains_only

  urirhssub  X_URIBL_Y_ANY  $z  A  127.0.1.1-127.0.1.254
  body       X_URIBL_Y_ANY  eval:check_uridnsbl('X_URIBL_Y_ANY')
  tflags     X_URIBL_Y_ANY  domains_only

  urirhssub  X_URIBL_Y_3    $z  A  127.0.1.3-127.0.1.19
  body       X_URIBL_Y_3    eval:check_uridnsbl('X_URIBL_Y_3')
  tflags     X_URIBL_Y_3    domains_only

  urirhssub  X_URIBL_N_3    $z  A  127.0.1.4-127.0.1.18
  body       X_URIBL_N_3    eval:check_uridnsbl('X_URIBL_Y_3')
  tflags     X_URIBL_N_3    domains_only

  urirhssub  X_URIBL_Y_FFA  $z  A  255.255.255.0
  body       X_URIBL_Y_FFA  eval:check_uridnsbl('X_URIBL_Y_FFA')
  tflags     X_URIBL_Y_FFA  domains_only

  urirhssub  X_URIBL_Y_FFB  $z  A  255.0.255.0/0xFF00FFff
  body       X_URIBL_Y_FFB  eval:check_uridnsbl('X_URIBL_Y_FFB')
  tflags     X_URIBL_Y_FFB  domains_only

  urirhssub  X_URIBL_Y_FFC  $z  A  0xFFffFF00/0xFFffFFff
  body       X_URIBL_Y_FFC  eval:check_uridnsbl('X_URIBL_Y_FFC')
  tflags     X_URIBL_Y_FFC  domains_only

  urirhssub  X_URIBL_Y_FFD  $z  A  0x80000000
  body       X_URIBL_Y_FFD  eval:check_uridnsbl('X_URIBL_Y_FFD')
  tflags     X_URIBL_Y_FFD  domains_only

  urirhssub  X_URIBL_N_0A   $z  A  127.0.0.0
  body       X_URIBL_N_0A   eval:check_uridnsbl('X_URIBL_N_0A')
  tflags     X_URIBL_N_0A   domains_only

  urirhssub  X_URIBL_N_0B   $z  A  127.0.1.0
  body       X_URIBL_N_0B   eval:check_uridnsbl('X_URIBL_N_0B')
  tflags     X_URIBL_N_0B   domains_only

  urirhssub  X_URIBL_N_255A $z  A  127.0.1.255
  body       X_URIBL_N_255A eval:check_uridnsbl('X_URIBL_N_255A')
  tflags     X_URIBL_N_255A domains_only

  urirhssub  X_URIBL_N_255B $z  A  0.0.0.255/0.0.0.255
  body       X_URIBL_N_255B eval:check_uridnsbl('X_URIBL_N_255B')
  tflags     X_URIBL_N_255B domains_only

# zone 2
  urirhssub  X_URIBL_Y_2AZ2 $z2  A  127.0.1.2
  body       X_URIBL_Y_2AZ2 eval:check_uridnsbl('X_URIBL_Y_2AZ2')

  urirhssub  X_URIBL_Y_255A $z2  A  127.0.1.255
  body       X_URIBL_Y_255A eval:check_uridnsbl('X_URIBL_Y_255A')

  urirhssub  X_URIBL_Y_255B $z2  A  0.0.0.255/0.0.0.255
  body       X_URIBL_Y_255B eval:check_uridnsbl('X_URIBL_Y_255B')
EOD

my(@testzone) = map { chomp; s/[ \t]+//; $_ } split(/^/, <<"EOD");
  $z               3600 IN SOA  ns.$z hostmaster.$z (1 10800 1800 2419200 3600)
  $z               3600 IN NS   ns.$z
  $z               3600 IN MX 0 .
  ns.$z            3600 IN A    127.0.0.1
  ns.$z            3600 IN AAAA ::1
  dbltest.com.$z   3600 IN A    127.0.1.2
  dbltest.com.$z   3600 IN TXT  "test answer on dbltest.com"
  dbltest03.com.$z 3600 IN A    127.0.1.3
  dbltest19.com.$z 3600 IN A    127.0.1.19
  dbltest20.com.$z 3600 IN A    127.0.1.20
  dbltest21.com.$z 3600 IN A    127.0.1.21
  dbltest39.com.$z 3600 IN A    127.0.1.39
  dbltest40.com.$z 3600 IN A    127.0.1.40
  dbltest50.com.$z 3600 IN A    127.0.1.50
  dbltest59.com.$z 3600 IN A    127.0.1.59
  dbltest99.com.$z 3600 IN A    127.0.1.99
  dbltestff.com.$z 3600 IN A    255.255.255.0
  dbltestER.com.$z 3600 IN A    127.0.1.255
  dbltestER.com.$z 3600 IN TXT  "No IP queries allowed"

  $z2              3600 IN SOA  ns.$z2 master.$z2 (1 10800 1800 2419200 3600)
  $z2              3600 IN NS   ns.$z2
  $z2              3600 IN MX 0 .
  ns.$z2           3600 IN A    127.0.0.1
  ns.$z2           3600 IN AAAA ::1
  dbltest.com.$z2  3600 IN A    127.0.1.2
EOD

# ---------------------------------------------------------------------------

sub reply_handler {
  my($qname, $qclass, $qtype, $peerhost,$query,$conn) = @_;
  my($rcode, @ans, @auth, @add);
  my $qclass_uc = uc $qclass;
  my $qtype_uc  = uc $qtype;
# print "Received query from $peerhost to ". $conn->{"sockhost"}. "\n";
# $query->print;
  $rcode = "NXDOMAIN";
  for my $rec_str (@testzone) {
    next if $rec_str =~ /^#/ || $rec_str =~ /^\s*$/;
    my($rrname,$rrttl,$rrclass,$rrtype,$rrdata) = split(' ',$rec_str,5);
    if ($qclass_uc eq uc($rrclass) && lc($rrname) eq lc($qname)) {
      $rcode = 'NOERROR';
      if ($qtype_uc eq uc($rrtype) || $qtype_uc eq 'ANY') {
        push(@ans, Net::DNS::RR->new(
                     join(' ', $qname, $rrttl, $qclass, $rrtype, $rrdata)));
      }
    }
  }
  # special DBL test case - numerical IP query handling
    # Bug 6983: Uninitialized value in lc in t/dnsbl_subtests for X_URIBL_Y_255A
    # Unicode case folding bug present in at least perl-5.8.[678], fixed 5.8.9
    # avoid case-insensitive regexp match, $z and $z2 are already in lowercase
  if ($qclass_uc eq 'IN' && lc $qname =~ /^[0-9.]+\.(?:\Q$z\E|\Q$z2\E)\z/s) {
    $rcode = 'NOERROR';
    if ($qtype_uc eq 'A' || $qtype_uc eq 'ANY') {
      push(@ans, Net::DNS::RR->new(join(' ',
                 $qname, '3600', $qclass, 'A', '127.0.1.255')));
    }
    if ($qtype_uc eq 'TXT' || $qtype_uc eq 'ANY') {
      push(@ans, Net::DNS::RR->new(join(' ',
                 $qname, '3600', $qclass, 'TXT', '"No IP queries allowed"')));
    }
  }
  return ($rcode, \@ans, \@auth, \@add);
}

sub dns_server($$) {
  my($local_addr, $local_port) = @_;
  my $ns = Net::DNS::Nameserver->new(
    LocalAddr => $local_addr, LocalPort => $local_port,
    ReplyHandler => \&reply_handler, Verbose => 0);
  $ns  or die "Cannot create a nameserver object";
  $ns->main_loop;
}

sub find_free_port($) {
  my($addr) = @_;
  my($port, $sock_udp, $sock_tcp);
  for (1..20) {  # choose a pair of free tcp & udp ports
    $port = 11001 + int(rand(65536-11001));
    my %args = (LocalAddr => $addr, LocalPort => $port);
    $sock_udp = $use_inet4 ? IO::Socket::INET->new(%args, Proto => 'udp')
                           : IO::Socket::INET6->new(%args, Proto => 'udp');
    $sock_udp || $! == EADDRINUSE || $! == EACCES
      or printf("Error creating UDP socket [%s]:%s: %s\n", $addr, $port, $!);
    $sock_tcp = $use_inet4 ? IO::Socket::INET->new(%args, Proto => 'tcp')
                           : IO::Socket::INET6->new(%args, Proto => 'tcp');
    $sock_tcp || $! == EADDRINUSE || $! == EACCES
      or printf("Error creating %s TCP socket [%s]:%s: %s\n",
                $use_inet4 ? 'inet' : 'inet6', $addr, $port, $!);
    last if $sock_tcp && $sock_udp;
  }
  undef $port if !$sock_tcp || !$sock_udp;
  return ($port, $sock_udp, $sock_tcp);
}

# ---------------------------------------------------------------------------

my $spamassassin_obj;

sub process_sample_urls(@) {
  my(@url_list) = @_;
  my($mail_obj, $per_msg_status, $spam_report);
  $spamassassin_obj->timer_reset;

  my $msg = <<'EOD';
From: "DNSBL Testing" <ab@example.org>
To: someone@example.org
Subject: test
Date: Mon, 8 Mar 2010 15:10:44 +0100
Message-Id: <test.123.test@example.org>

EOD
  $msg .= $_."\n" for @url_list;

  $mail_obj = $spamassassin_obj->parse($msg,0);
  if ($mail_obj) {
    local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.x bug, $1 can get tainted
    $per_msg_status = $spamassassin_obj->check($mail_obj);
  }
  if ($per_msg_status) {
    $spam_report = $per_msg_status->get_tag('REPORT');
    $per_msg_status->finish;
  }
  if ($mail_obj) {
    $mail_obj->finish;
  }
  $spam_report =~ s/\A(\s*\n)+//s;
# print "\t$spam_report\n";
  return $spam_report;
}

sub test_samples($$) {
  my($patt_antipatt_list,$url_list_ref) = @_;
  my $el = $patt_antipatt_list->[0];
  shift @$patt_antipatt_list  if @$patt_antipatt_list > 1;  # last autorepeats
  my($patt,$anti) = split(m{\s* / \s*}x, $el, 2);
  %patterns      = map { (" $_ ", $_) } split(' ',$patt);
  %anti_patterns = map { (" $_ ", $_) } split(' ',$anti);
  my $spam_report = process_sample_urls(@$url_list_ref);
  clear_pattern_counters();
  patterns_run_cb($spam_report);
  my $status = ok_all_patterns();
  printf("\nTest on %s failed:\n%s\n",
         join(', ',@$url_list_ref), $spam_report)  if !$status;
}


# there is a time gap between closing sockets and reusing them by a spawned
# DNS server - if we are very unlucky and the port is acquired by some other
# process during this short interval, our spawned DNS server will fail to start
#
if ($sock_udp) {
  $sock_udp->close()  or die "Error closing UDP socket: $!";
}
if ($sock_tcp) {
  $sock_tcp->close()  or die "Error closing TCP socket: $!";
}

# detach a DNS server process
my $pid = fork();
defined $pid or die "Cannot fork: $!";
if (!$pid) {  # child
  dns_server($dns_server_localaddr, $dns_server_localport);
  exit;
}

# parent
# print STDERR "Forked a DNS server process [$pid]\n";
sleep 1;

$spamassassin_obj = Mail::SpamAssassin->new({
  rules_filename      => $localrules,
  require_rules       => 1,
  site_rules_filename => $siterules,
  userprefs_filename  => $userrules,
  post_config_text    => $local_conf,
  dont_copy_prefs     => 1,
# debug               => 'dns,async,uridnsbl',
});
ok($spamassassin_obj);
$spamassassin_obj->compile_now;  # try to preload most modules

test_samples(
  [q{ X_URIBL_Y_2A X_URIBL_Y_2B X_URIBL_Y_2C X_URIBL_Y_2D X_URIBL_Y_2E
      X_URIBL_Y_2F X_URIBL_Y_2G X_URIBL_Y_ANY / X_URIBL_N_2E X_URIBL_N_2G
      X_URIBL_N_3 X_URIBL_N_0A X_URIBL_N_0B X_URIBL_N_255A X_URIBL_N_255B }],
  [qw( http://dbltest.com/ )]);

test_samples(
  [q{ X_URIBL_Y_2A X_URIBL_Y_2B X_URIBL_Y_2C X_URIBL_Y_2D X_URIBL_Y_2E
      X_URIBL_Y_2F X_URIBL_Y_2G X_URIBL_Y_ANY X_URIBL_Y_3 / X_URIBL_N_3
      X_URIBL_N_0A X_URIBL_N_0B X_URIBL_N_255A X_URIBL_N_255B }],
  [qw( http://dbltest.com/ http://dbltest03.com/ http://dbltest19.com/ )]);

test_samples(
  [q{ X_URIBL_Y_2A X_URIBL_Y_2B X_URIBL_Y_2C X_URIBL_Y_2D X_URIBL_Y_2E
      X_URIBL_Y_2F X_URIBL_Y_2G X_URIBL_Y_FFA X_URIBL_Y_FFB X_URIBL_Y_FFC
      X_URIBL_Y_255A X_URIBL_Y_255B / X_URIBL_N_0A X_URIBL_N_0B
      X_URIBL_N_255A X_URIBL_N_255B }],
  [qw( http://DBLtest.COM/ http://dbltestFF.CoM/ http://140.211.11.130/ )]);
# X_URIBL_Y_FFD no longer hits intentionally (not in the 127.0.0.0/8 range),
# see Bug 6803

if ($pid) {
  kill('TERM',$pid) or die "Cannot stop a DNS server [$pid]: $!";

# Bug 7000: Seems like a DNS server process can't be terminated. [...]
# Reason is "waitpid($pid,0)". If commented out, it does not hang.
# There are no extra processes after end of this test.
#
# perlfunc: waitpid - waiting for a particular pid with FLAGS of 0 is
# implemented everywhere
#
# perlport: (Win32) waitpid Can only be applied to process handles returned
# for processes spawned using "system(1, ...)" or pseudo processes created
# with "fork()".
#
# so ... waitpid($pid,0) should work on Windows, but it doesn't - nevermind:

  waitpid($pid,0) unless $RUNNING_ON_WINDOWS;

  undef $pid;
}

END {
  $spamassassin_obj->finish  if $spamassassin_obj;
  kill('KILL',$pid)  if $pid;  # ignoring status
}