#!/usr/bin/perl
use strict;
use warnings;

my @Tests;
my $can_ip6;
BEGIN {
	my @tfile = @ARGV;
	@tfile = ( 'rfc4408-tests.pl','misc.pl' ) if !@tfile;
	for my $tfile (@tfile) {
		my $tests;
		for ( $tfile,"t/$tfile" ) {
			-f or next;
			$tests = do $_;
			die $@ if $@;
			last;
		}
		if ( ! $tests or !@$tests ) {
			print "1..1\nok # skip Perl file for test suite not found\n";
			exit;
		}
		push @Tests,@$tests;
	}
	my $sum = 0;
	$sum += 2*keys(%{ $_->{tests} }) for (@Tests);
	print "1..$sum\n";

	$can_ip6 = eval 'use Socket6;1';
}

use Mail::SPF::Iterator;
use Net::DNS;
use Data::Dumper;


$|=1;
my $DEBUG=1;
Mail::SPF::Iterator->import( Debug => $DEBUG );

for my $use_additionals ('with additionals','') {
	for my $test ( @Tests ) {
		my $desc= $test->{description};
		my $dns_setup = $test->{zonedata};
		my $subtests = $test->{tests};

		my $resolver = myResolver->new(
			records => $dns_setup,
			use_additionals => $use_additionals
		);
		for my $tname (sort keys %$subtests) {
			my $tdata = $subtests->{$tname};

			my %d = %$tdata;
			delete @d{qw/description comment/};
			my $explanation = delete $d{explanation};

			my $result = delete $d{result};
			$result = [ $result ] if ! ref $result;
			$_=lc for(@$result);

			my $spec = delete $d{spec};
			$spec = [ $spec ] if ! ref($spec);
			my $comment = "$desc | $tname (@$spec) (@$result) $use_additionals";

			if ( ! $can_ip6 and ( $d{host} =~m{::} or $tname =~m{ip6} )) {
				print "ok # skip Socket6.pm not installed\n";
				next;
			}

			# capture debug output of failed cases
			my $debug = '';
			eval {
				open( my $dbg, '>',\$debug );
				local *STDERR = $dbg;

				my $spf = eval {
					Mail::SPF::Iterator->new(
						delete $d{host},
						delete $d{mailfrom},
						delete $d{helo},
					);
				};
				die "no spf: $@\n".Dumper($tdata) if ! $spf;
				die "unhandled args :".Dumper(\%d) if %d;

				$explanation = $spf->explain_default
					if $explanation and $explanation eq 'DEFAULT';

				my ($status,@ans) = $spf->next;
				while ( ! $status ) {
					my @query = @ans;
					die "no queries" if ! @query;
					for my $q (@query) {
						#DEBUG( "next query >>> ".($q->question)[0]->string );
						my $answer = $resolver->send( $q );
						($status,@ans) = $spf->next(
							$answer || [ $q, $resolver->errorstring ]);
						DEBUG( "status=$status" ) if $status;
						last if $status or @ans;
					}
				}

				my $mh = $spf->mailheader;
				$mh =~m{^$status }i or die "bad mail header for status $status: $mh";
				die bless [ lc($status),@ans ],'SPFResult';
			};

			if ( ref($@) ne 'SPFResult' ) {
				print "not ok # $comment - error\n";
				( my $t = $@."\n".$debug ) =~s{^}{| }mg;
				print Dumper($tdata),$t;
				next;
			}

			my ($status,$info,$hash,$explain) = @{$@};
			if ( ! grep { $status eq $_ } @$result ) {
				print "not ok # $comment - got $status\n";
				$debug =~s{^}{| }mg;
				print Dumper($tdata),$debug.Dumper(
					{ info => $info, hash => $hash, explain => $explain });
				next;
			}

			if ( $explanation ) {
				if ( $explain ne $explanation ) {
					print "not ok # $comment - ".
						"exp should be '$explanation' was '$explain'\n";
					$debug =~s{^}{| }mg;
					print Dumper($tdata),$debug;
					next;
				}
			}

			if ( $status ne $result->[0] ) {
				if ( $tname =~m{^(mx|ptr)-limit$} ) {
					#### spec: "... The SPF result is effectively randomized."
					print "ok # $comment - got $status\n";
				} else {
					print "not ok # $comment - got $status\n";
					$debug =~s{^}{| }mg;
					print Dumper($tdata),$debug.Dumper(
						{ info => $info, hash => $hash, explain => $explain });
				}
				next;
			}


			print "ok # $comment\n";
		}
	}
}

############################################################################
# DEBUG
############################################################################

sub DEBUG {
	$DEBUG or return; # check against debug level
	my (undef,$file,$line) = caller;
	my $msg = shift;
	$file = '...'.substr( $file,-17 ) if length($file)>20;
	$msg = sprintf $msg,@_ if @_;
	print STDERR "DEBUG: $file:$line: $msg\n";
}

############################################################################
# myResolver
# implements Net::DNS::Resolver for tests, ideas stolen from
# Net::DNS::Resolver::Programmable
############################################################################

package myResolver;
use base 'Net::DNS::Resolver';
use Data::Dumper;

sub DEBUG { goto &::DEBUG }

sub new {
	my ($class,%options) = @_;
	my $self = $class->SUPER::new(%options);
	$self->{records} = $options{records};
	$self->{use_additionals} = $options{use_additionals};
	return $self;
}

sub send {
	my $self = shift;
	my $pkt = $self->make_query_packet(@_);
	my $q = ($pkt->question)[0];
	my $qname = lc($q->qname);
	my $qtype = $q->qtype;
	my $qclass = $q->qclass;

	$self->_reset_errorstring;

	DEBUG( "got query=".$q->string );

	# create answer packet
	my $packet = Net::DNS::Packet->new($qname, $qtype, $qclass);
	$packet->header->qr(1);
	$packet->header->aa(1);
	$packet->header->id($pkt->header->id);

	my (%ans,$timeout,@answer,@cname);
	while (1) {
		( my $key = $qname ) =~ s{\.$}{};
		# newer Net::DNS versions encode space as \\032, older do not :(
		$key =~s{\\(?:(\d\d\d)|(.))}{$2||chr($1)}esg; 
		my @match = grep { lc($key) eq lc($_) } keys %{ $self->{records}}
			or last;

		my $rrdata = $self->{records}{$match[0]};

		for my $data (@$rrdata) {
			if ( $data eq 'TIMEOUT' ) {
				# report as error
				$timeout = 1;
			} elsif ( ref($data) eq 'HASH' ) { ### { SPF => ... }
				# create and collect RR
				my @typ = keys %$data;
				@typ == 1 or die Dumper( $data ); # expect only 1 key
				push @{ $ans{$typ[0]}}, $data->{$typ[0]};
			}
		}


		$ans{TXT} ||= $ans{SPF};
		for (values %ans) {
			$_ = undef if $_ and @$_ == 1 and $_->[0] eq 'NONE';
		}

		if ( my $ans = $ans{$qtype} ) {
			push @answer, @$ans;
		} elsif ( !@answer and ( $ans = $ans{CNAME})) {
			@$ans == 1 or die;
			$qname = $ans->[0];
			push @cname, [ $match[0],$qname ];
			redo;
		}

		if ( $timeout and !@answer and !@cname) {
			$self->errorstring('TIMEOUT');
			return undef;
		}

		my @additional;
		for my $ans (@answer) {
			my %rr = ( type => $qtype, name => $qname );
			my $aname;
			if ( $qtype eq 'MX' ) {
				$aname = $rr{exchange} = $ans->[1];
				$rr{preference} = $ans->[0];
			} elsif ( $qtype eq 'A' || $qtype eq 'AAAA' ) {
				$rr{address} = $ans
			} elsif ( $qtype eq 'SPF' || $qtype eq 'TXT' ) {
				$rr{char_str_list} = ref($ans) ? $ans : [ $ans ];
			} elsif ( $qtype eq 'PTR' ) {
				$rr{ptrdname} = $ans;
			} elsif ( $qtype eq 'CNAME' ) {
				$aname = $rr{cname} = $ans;
			} else {
				die $qtype
			}

			#DEBUG( Dumper( \%rr ));
			# work around a Bug in Net::DNS 0.64, where it will interpret
			# cafe:babe::1 as cafe:babe:0:1:0:0:0:0 when given in hash 
			# to Net::DNS::RR->new
			if ( $rr{type} eq 'AAAA' ) {
				# replace with long form
				my @a = split( ':',$rr{address});
				if ( my $fill = 8 - @a ) {
					@a = map { $_ eq '' ? (0) x ($fill+1) : $_ } @a;
					$rr{address} = join(':',@a);
				}
			}
			$ans = Net::DNS::RR->new( %rr ) or die;
			DEBUG( "answer: ".$ans->string );

			if ( $self->{use_additionals} and $qtype eq 'MX' ) {
				# add A/AAAA records as additional data
				$aname =~s{\.$}{};
				for (@{ $self->{records}{$aname} || [] }) {
					next if ! ref;
					my @k = keys %$_;
					next if @k != 1 or ( $k[0] ne 'A' and $k[0] ne 'AAAA' );
					push @additional, Net::DNS::RR->new(
						name => $aname,
						type => $k[0],
						address => $_->{$k[0]}
					) or die;
					DEBUG( "additional: ".$additional[-1]->string );
				}
			}
		}

		for(@cname) {
			$packet->push(answer => Net::DNS::RR->new(
				type => 'CNAME', name => $_->[0], cname => $_->[1] ));
		}
		if ( @answer ) {
			$packet->push(answer => @answer);
			$packet->push(additional => @additional) if @additional;
		}
		DEBUG( $packet->string );
		$packet->header->rcode('NOERROR');
		return $packet;
	}

	# report that domain does not exist
	DEBUG( "send NXDOMAIN" );
	$packet->header->rcode('NXDOMAIN');
	return $packet;
}