#!/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,$pkt) = @_;
    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;
}