The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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;

my @SKIP_TESTS = qw {

    # Mail::DKIM does not handle Authentication-Results header merges
    ar_merged1 ar_merged2

};

sub new {
    my ( $class ) = @_;
    my $self = {};
    bless $self, $class;
    return $self;
}

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

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

sub RunAllScenarios {
    my ( $self ) = @_;
    foreach my $Scenario ( @{ $self->{ 'tests' } } ) {
        $self->RunScenario( $Scenario );
    }
    return;
}

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{};

    my @chompkey = split( "\n", $private_key );
    shift @chompkey;
    pop @chompkey;
    $private_key = join( q{}, @chompkey );

    my $ZoneFile = q{};
    foreach my $Record ( sort keys %$txt_records ) {
        my $Txt = $txt_records->{ $Record };
        $ZoneFile .= $Record . '. 3600 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 ( grep { $test eq $_ } @SKIP_TESTS ) {
            diag( "Skipped test for $description - $test" );
            next TEST;
        } 

        my $testhash = $tests->{ $test };

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

        $message =~ s/[\n\r]*$//;
        $message =~ s/\015?\012/\015\012/g;

        if ( $cv eq q{} ) {
            $cv = 'fail';
            diag( "Null test cv for $description - $test" );
        }

        my $arc_result;

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

                if ( $self->{ 'operation' } ne 'sign' ) {
                    is( lc $mycv, lc $cv, "$description - $test ARC Result" );
                    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 if $self->{ 'operation' } ne 'sign';

        # 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' };
        my $t          = $testhash->{ 't' };

        my $arc = Mail::DKIM::ARC::Signer->new(
          'Algorithm' => 'rsa-sha256',
          'Domain' => $domain,
          'Selector' => $sel,
          'Key' => Mail::DKIM::PrivateKey->load( 'Data' => $private_key ),
          'Chain' => $arc_result,
          '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( srt( $arcsign_as ),  srt( 'ARC-Seal: '                   . $as ),  "$description - $test ARC-Seal" );
        is( srt( $arcsign_ams ), srt( 'ARC-Message-Signature: '      . $ams ), "$description - $test ARC-Message-Signature" );
        is( srt( $arcsign_aar ), srt( 'ARC-Authentication-Results: ' . $aar ), "$description - $test ARC-Authentication-Results" );

    }
    return;
}

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;
    my $sorted = join( '; ', sort @values );
    return "$key: $sorted";
}

1;