package ArcTestSuite;

use strict;
use warnings;
use Data::Dumper;

use YAML::XS;

use Net::DNS::Resolver::Mock;

use Mail::DKIM;
#$Mail::DKIM::SORTTAGS = 1;

use Mail::DKIM::ARC::Signer;
use Mail::DKIM::ARC::Verifier;

use Test::More;

=head1 NAME

ArcTestSuite - extract and run tests from the ARC YAML test suite

=head1 CONSTRUCTOR

=head2 new() - create a new test runner

my $Tests = ArcTestSuite->new(Strict => 1/0);

=cut

   sub new {
    my ( $class, %args ) = @_;
    my $self = {};
    bless $self, $class;
    $self->{Strict} = $args{"Strict"} // 1;
    return $self;
}

=head1 METHODS

=head2 LoadFile() - load a YAML file of tests

  $Tests->LoadFile( $yamlfile );

  Load the tests from a YAML file

=cut

sub LoadFile {
    my ( $self, $file ) = @_;
    my @data = YAML::XS::LoadFile( $file );
    $self->{ 'tests' } = \@data;
    return;
}

=head2 SetOperation() - prepare to sign or validate

$Tests->SetOperation( 'sign'|'validate' );

Tell it whether these are signing or validateing tests

=cut

sub SetOperation {
    my ( $self, $operation ) = @_;
    die "Invalid operation $operation" unless $operation =~ m{^(validate|sign)$};
    $self->{ 'operation' } = $operation;
    return;
}

=head2 DumpTests

$Tests->DumpTests("dir/%s")

Dump each test message to a file as the test is run.
The argument is a printf pattern for the filename with %s as
the test name.

=cut

sub DumpTests {
    my ( $self, $testpat ) = @_;
    $self->{ 'testpat' } = $testpat;
    return;
}

my $nskip = 0;

=head2 RunAllScenarios() - run all test scenarios

$Test->RunAllScenarios($nskip)

Iterate over all scenarios in the YAML and run the tests.
The optional argument is how many tests to skip before actual
testing.

=cut

sub RunAllScenarios {
    my ( $self, $nsx ) = @_;

    $nskip = $nsx if $nsx > 0;
    foreach my $Scenario ( @{ $self->{ 'tests' } } ) {
        $self->RunScenario( $Scenario );
    }
    return;
}

=head2 RunScenario() - run all test scenarios

$Test->RunScenario($scenario)

Iterate over all the tests in the scenario and run them.

=cut

sub RunScenario {
    my ( $self, $scenario ) = @_;

    my $description = $scenario->{ 'description' };
    my $tests       = $scenario->{ 'tests' };
    my $txt_records = $scenario->{ 'txt-records' } || q{};
    my $comment     = $scenario->{ 'comment' };
    my $domain      = $scenario->{ 'domain '};
    my $sel         = $scenario->{ 'sel' };
    my $private_key = $scenario->{ 'privatekey' } || q{};

    diag("--- $description ---");

    # remove key BEGIN / END
    if($private_key) {
        my @chompkey = split( "\n", $private_key );
        $private_key = join( q{}, @chompkey[1..($#chompkey-1)] );
    }

    my $ZoneFile = q{};
    foreach my $Record ( sort keys %$txt_records ) {
        my $Txt = $txt_records->{ $Record };
        $ZoneFile .= $Record . '. 60 TXT';
        foreach my $TxtLine ( split "\n", $Txt ) {
            $ZoneFile .= ' "' . $TxtLine . '"';
        }
        $ZoneFile .= "\n";
    }
    my $FakeResolver = Net::DNS::Resolver::Mock->new();
    $FakeResolver->zonefile_parse( $ZoneFile );

    TEST:
    foreach my $test ( sort keys %$tests ) {

        if($nskip > 0) {
            diag("skip $description - $test");
            $nskip--;
            next;
        }
        my $testhash = $tests->{ $test };

        # keys relevant to validate and signing tests
        my $comment     = $testhash->{ 'comment' };
        my $cv          = $testhash->{ 'cv' };
        my $description = $testhash->{ 'description' };
        my $message     = $testhash->{ 'message' };
        my $spec        = $testhash->{ 'spec' };

        # dump test to a file
        if($self->{ 'testpat' }) {
            local *TOUT;
            my $tfn = $test;
            $tfn =~ s:[ /]:_:g;

            open TOUT, ">" . sprintf($self->{ 'testpat' }, $tfn)
                 or die "cannot write file for $description";
            print TOUT $message;
            close TOUT;
        }

        # HACK - skip sha1 tests
        if($test =~ /sha1/) {
            #diag("Skip SHA-1 test $test");
            next;
        }

        $message =~ s/\015?\012/\015\012/g;

        if ($self->{ 'operation' } eq 'validate' and (!defined $cv or $cv eq q{}) ) {
            $cv = 'fail';
            #diag( "Null test cv treated as fail for $description - $test" );
        }

        my $arc_result;

        if($self->{ 'operation' } eq 'validate') {
            if (!defined $cv or $cv eq q{}) {
                $cv = 'fail';
                diag( "Null test cv treated as fail for $description - $test" );
            }

            eval {
              my $arc = new Mail::DKIM::ARC::Verifier(Strict => $self->{"Strict"});
              Mail::DKIM::DNS::resolver( $FakeResolver );
              $arc->PRINT( $message );
              $arc->CLOSE();
              $arc_result = $arc->result();
              my $arc_result_detail = $arc->result_detail();
              my $mycv = lc $arc_result eq 'pass' ? 'Pass' :
                         lc $arc_result eq 'none' ? 'None' : 'Fail';

              is( lc $mycv, lc $cv, "$description - $test ARC Result $mycv want $cv" );
              if ( lc $mycv ne lc $cv ) {
                  diag( "Got: $arc_result ( $arc_result_detail )" );
              }        
            };
            if ( my $error = $@ ) {
                is( 0, 1, "$description- $test - died with $error" );
            }
            next;
        }

        # keys relevant to signing tests only
        my $aar        = $testhash->{ 'AAR' };
        my $ams        = $testhash->{ 'AMS' };
        my $as         = $testhash->{ 'AS' };
        my $sigheaders = $testhash->{ 'sig-headers' };
        my $srvid      = $testhash->{ 'srv-id' } || $domain;
        my $t          = $testhash->{ 't' };

        my $arc = Mail::DKIM::ARC::Signer->new(
          'Algorithm' => 'rsa-sha256',
          'Domain' => $domain,
          'SrvId' => $srvid,
          'Selector' => $sel,
          'Key' => Mail::DKIM::PrivateKey->load( 'Data' => $private_key ),
          'Chain' => 'ar',                # use the result from A-R, since message might have changed since verified
          'Headers' => $sigheaders,
          'Timestamp' => $t,
        );
        $arc->{ 'NoDefaultHeaders' } = 1;
        $Mail::DKIM::SORTTAGS = 1;
        Mail::DKIM::DNS::resolver( $FakeResolver );
        $arc->PRINT( $message );
        $arc->CLOSE();
        my $arcsign_result = $arc->as_string();
        my $arcsign_as     = $arc->{ '_AS' };
        my $arcsign_ams    = $arc->{ '_AMS' };
        my $arcsign_aar    = $arc->{ '_AAR' };

        is( sqish( $arcsign_as ),  sqish( 'ARC-Seal: '                   . $as ),  "$description - $test ARC-Seal" );
        is( sqish( $arcsign_ams ), sqish( 'ARC-Message-Signature: '      . $ams ), "$description - $test ARC-Message-Signature" );
        is( sqsh(  $arcsign_aar),  sqsh(  'ARC-Authentication-Results: ' . $aar) , "$description - $test ARC-Authentication-Results" );

    }
    return;
}

# sort tags
sub srt {
    my ( $header ) = @_;
    my ( $key, $value ) = split( ': ', $header, 2 );
    $value =~ s/^\s+//gm;
    $value =~s/\n//g;
    my @values = split( /;\s*/, $value );
    #    @values = map { local $_ = $_ ; s/^\s+|\s+$//g ; $_ } @values;
    @values = map { s/^\s+|\s+$//g } @values;
    my $sorted = join( '; ', sort @values );
    return "$key: $sorted";
}

# squash all white space
sub sqish {
    my ( $header ) = @_;
    return "" unless $header;                # completely empty
    my ( $key, $value ) = split( ': ', $header, 2 );
    return "" unless $value;                # empty value

    $value =~ s/[ \t\r\n]+//gs;                # remove all white space
    $value =~ s/\s*;\s*/; /g;                # squash put in one space around semicolons
    #print "SQUISH $key: $value\n";
    return "$key: $value";
}

# squash white space between fields
sub sqsh {
    my ( $header ) = @_;
    return "" unless $header;                # completely empty
    my ( $key, $value ) = split( ': ', $header, 2 );
    return "" unless $value;                # empty value

    $value =~ s/^\s+|[ \t\r\n]+$//gs;        # remove leading and trailing white space
    $value =~ s/\n/ /g;                        # flatten into one line
    $value =~ s/\s*;\s*/; /g;                # squash white space around semicolons
    #print "SQUASH $key: $value\n";
    return "$key: $value";
}

1;
__END__

=head1 AUTHORS

Marc Bradshaw, E<lt>marc@marcbradshaw.netE<gt>,
Bron Gondwana, E<lt>brong@fastmailteam.comE<gt>,
John Levine, E<lt>john.levine@standcore.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2017 by FastMail Pty Ltd
Copyright 2017 by Standcore LLC

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

=cut
