#!/usr/bin/perl -I../lib

use strict;
use warnings;
use Test::More tests => 111;

use Mail::DKIM::Verifier;

my $homedir = ( -d "t" ) ? "t" : ".";

my $dkim = Mail::DKIM::Verifier->new();
ok( $dkim, "new() works" );

$dkim = Mail::DKIM::Verifier->new_object();
ok( $dkim, "new_object() works" );

my $sample_email = read_file("$homedir/test5.txt");
ok( $sample_email,               "able to read sample email" );
ok( $sample_email =~ /\015\012/, "sample has proper line endings" );

$dkim->PRINT($sample_email);
$dkim->CLOSE;

my $result = $dkim->result;
ok( $result, "result() works" );

SKIP:
{
    skip "older-prestandard DKIM signatures", 5;
    test_email( "good_ietf00_1.txt", "pass" );
    test_email( "good_ietf00_2.txt", "pass" );
    test_email( "good_ietf00_3.txt", "pass" );
    test_email( "good_ietf00_4.txt", "pass" );
    test_email( "good_ietf00_5.txt", "pass" );
}

test_email( "mine_ietf01_1.txt",  "pass" );
test_email( "mine_ietf01_2.txt",  "pass" );
test_email( "mine_ietf01_3.txt",  "pass" );
test_email( "mine_ietf01_4.txt",  "pass" );
test_email( "mine_ietf05_1.txt",  "pass" );
test_email( "good_ietf01_1.txt",  "pass" );
test_email( "good_ietf01_2.txt",  "pass" );
test_email( "good_rfc4871_3.txt", "pass" );    # tests extra tags in signature
test_email( "good_rfc4871_4.txt", "pass" );    # case-differing domain name
test_email( "good_1878523.txt",   "pass" );    # test issue #1878523
test_email( "good_83176.txt",     "pass" );    # test issue #83176
test_email( "multiple_1.txt",     "pass" );
test_email( "multiple_2.txt",     "pass" );
my @sigs = $dkim->signatures;
ok( $sigs[0]->result eq "invalid", "first signature is 'invalid'" );
ok( $sigs[1]->result eq "pass",    "second signature is 'pass'" );
ok( $sigs[2]->result eq "fail",    "third signature is 'fail'" );
test_email( "good_qp_1.txt", "pass" );         # tests i= quoted-printable value
test_email( "good_qp_2.txt", "pass" );         # tests i= quoted-printable value
test_email( "good_qp_3.txt", "pass" );         # tests i= quoted-printable value

test_email( "bad_ietf01_1.txt", "fail" );
ok( $dkim->result_detail =~ /body/, "determined body had been altered" );
test_email( "bad_ietf01_2.txt", "fail" );
ok( $dkim->result_detail =~ /message/, "determined message had been altered" );
test_email( "bad_ietf01_3.txt", "fail" );
ok( $dkim->result_detail =~ /RSA/, "determined RSA failure" );
test_email( "bad_1.txt", "fail" );             #openssl error
print "# " . $dkim->result_detail . "\n";
SKIP:
{
    skip "did not recognize OpenSSL error", 1
      unless ( $dkim->result_detail =~ /OpenSSL/i );
    like( $dkim->result_detail, qr/OpenSSL/i, "determined OpenSSL error" );
}
test_email( "bad_1878954.txt", "fail" );       # shouldn't die

# test older DomainKeys messages, from Gmail and Yahoo!
test_email( "good_dk_gmail.txt", "pass" );
test_email( "good_dk_yahoo.txt", "pass" );
test_email( "good_dk_1.txt",     "pass" );
test_email( "good_dk_2.txt",     "pass" );
test_email( "good_dk_3.txt", "pass" );  # key with g= tag (ident in From header)
test_email( "good_dk_4.txt", "pass" );  # key with g= tag (ident in Sender head)
test_email( "good_dk_5.txt", "pass" );  # key with empty g=
test_email( "good_dk_6.txt", "pass" );  # no h= tag
test_email( "good_dk_7.txt", "pass" );  # case-differing domain names
test_email( "dk_headers_1.txt", "pass" );
test_email( "dk_headers_2.txt", "pass" );
test_email( "bad_dk_1.txt",     "invalid" )
  ;                                     # sig. domain != From header (no Sender)
test_email( "bad_dk_2.txt", "invalid" );    # added Sender header, no h= tag
SKIP:
{
    skip "missing q= tag on DomainKey signature accepted", 1;
    test_email( "bad_dk_3.txt", "invalid" );    # no q= tag
}
test_email( "bad_dk_4.txt",      "invalid" );    # empty q= tag
test_email( "bad_dk_5.txt",      "invalid" );    # unrecognized q= tag
test_email( "dk_multiple_1.txt", "pass" );
my @dksigs = $dkim->signatures;
ok( @dksigs == 2,                 "found two signatures" );
ok( $dksigs[0]->result eq "pass", "first signature is 'pass'" );
ok( $dksigs[1]->result eq "pass", "second signature is 'pass'" );

# test empty/missing body - simple canonicalization
test_email( "no_body_1.txt", "pass" );
test_email( "no_body_2.txt", "pass" );
test_email( "no_body_3.txt", "pass" );

#
# test various problems with the signature itself
#
test_email( "ignore_1.txt", "invalid" );    # unsupported v= tag (v=5)
test_email( "ignore_2.txt", "invalid" );    # unsupported a= tag (a=rsa-md5)
test_email( "ignore_3.txt", "invalid" );    # unsupported a= tag (a=dsa-sha1)
test_email( "ignore_4.txt", "invalid" );    # unsupported c= tag (c=future)
test_email( "ignore_5.txt", "invalid" );    # unsupported q= tag (q=http)
test_email( "ignore_6.txt", "invalid" );    # unsupported q= tag (q=dns/special)
test_email( "ignore_7.txt", "invalid" );    # expired signature
test_email( "ignore_8.txt", "invalid" );    # bad i= value

#
# test variants on the public key
#
test_email( "goodkey_1.txt", "pass" );    # public key with s=email
test_email( "goodkey_2.txt", "pass" )
  ;    # public key with extra tags, h=, s=, etc.
test_email( "goodkey_3.txt", "pass" );    # public key with g=jl*g
test_email( "goodkey_4.txt", "pass" );    # public key with implied g

#
# test problems with the public key
#
test_email( "badkey_1.txt", "invalid" );    # public key NXDOMAIN
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_2.txt", "invalid" );    # public key REVOKED
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_3.txt", "invalid" );    # public key unsupported v= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_4.txt", "invalid" );    # public key syntax error
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_5.txt", "invalid" );    # public key unsupported k= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_6.txt", "invalid" );    # public key unsupported s= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_7.txt", "invalid" );    # public key unsupported h= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_8.txt", "invalid" );    # public key unmatched g= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_9.txt", "invalid" );    # public key empty g= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_10.txt", "invalid" );    # public key requires i == d
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_11.txt", "invalid" );    # public key unmatched h= tag
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_12.txt", "invalid" );    # public key g= != i= by case
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_13.txt", "invalid" )
  ;    # public key g= matches From but not i=
ok( $dkim->result_detail =~ /public key/, "detail mentions public key" );
test_email( "badkey_14.txt", "invalid" );    # dns error (timeout)
ok( $dkim->result_detail =~ /public key/,        "detail mentions public key" );
ok( $dkim->result_detail =~ /dns.*timed? ?out/i, "type of dns failure" );
test_email( "badkey_15.txt", "invalid" );    # dns error (SERVFAIL)
ok( $dkim->result_detail =~ /public key/,     "detail mentions public key" );
ok( $dkim->result_detail =~ /dns.*SERVFAIL/i, "type of dns failure" );

# test ed25519
test_email( "goodkey_ed25519.txt", "pass" );
test_email( "badkey1_ed25519.txt", "invalid" ); # key has invalid length
test_email( "badkey2_ed25519.txt", "fail" ); # header modified
test_email( "badkey3_ed25519.txt", "fail" ); # body modified
test_email( "badkey4_ed25519.txt", "invalid" ); # missing key
test_email( "badkey5_ed25519.txt", "invalid" ); # empty key

sub read_file {
    my $srcfile = shift;
    open my $fh, "<", $srcfile
      or die "Error: can't open $srcfile: $!\n";
    binmode $fh;
    local $/;
    my $content = <$fh>;
    close $fh;
    return $content;
}

sub test_email {
    my ( $file, $expected_result ) = @_;
    print "# verifying message '$file'\n";
    $dkim = Mail::DKIM::Verifier->new();
    my $path  = "$homedir/corpus/$file";
    my $email = read_file($path);
    $dkim->PRINT($email);
    $dkim->CLOSE;
    my $result = $dkim->result;
    print "#   result: " . $dkim->result_detail . "\n";
    ok( $result eq $expected_result, "'$file' should '$expected_result'" );
}

# override the DNS implementation, so that these tests do not
# rely on DNS servers I have no control over
my $CACHE;

sub Mail::DKIM::DNS::fake_query {
    my ( $domain, $type ) = @_;
    die "can't lookup $type record" if $type ne "TXT";

    unless ($CACHE) {
        open my $fh, "<", "$homedir/FAKE_DNS.dat"
          or die "Error: cannot read $homedir/FAKE_DNS.dat: $!\n";
        $CACHE = {};
        while (<$fh>) {
            chomp;
            next if /^\s*[#;]/ || /^\s*$/;
            my ( $k, $v ) = split /\s+/, $_, 2;
            $CACHE->{$k} =
                ( $v =~ /^~~(.*)~~$/ ) ? "$1"
              : $v eq "NXDOMAIN"       ? []
              :                          [ bless \$v, "FakeDNS::Record" ];
        }
        close $fh;
    }

    if ( not exists $CACHE->{$domain} ) {
        warn "did not cache that DNS entry: $domain\n";
        print STDERR ">>>\n";
        my @result = Mail::DKIM::DNS::orig_query( $domain, $type );
        if ( !@result ) {
            print STDERR "No results: $@\n";
        }
        else {
            foreach my $rr (@result) {

                # join with no intervening spaces, RFC 6376
                if ( $rr->can('txtdata') ) {

                    # must call txtdata() in a list context
                    printf STDERR ( "%s\n", join( "", $rr->txtdata ) );
                }
                else {
                    # char_str_list method is 'historical'
                    printf STDERR ( "%s\n", join( "", $rr->char_str_list ) );
                }
            }
        }
        print STDERR "<<<\n";
        die;
    }

    if ( ref $CACHE->{$domain} ) {
        return @{ $CACHE->{$domain} };
    }
    else {
        die "DNS error: $CACHE->{$domain}\n";
    }
}

BEGIN {
    unless ( $ENV{use_real_dns} ) {
        *Mail::DKIM::DNS::orig_query = *Mail::DKIM::DNS::query;
        *Mail::DKIM::DNS::query      = *Mail::DKIM::DNS::fake_query;
    }
}

package FakeDNS::Record;

sub type {
    return "TXT";
}

sub char_str_list {
    return ${ $_[0] };
}

sub txtdata {
    return ${ $_[0] };
}