# BEGIN BPS TAGGED BLOCK {{{
#
# COPYRIGHT:
#
# This software is Copyright (c) 1996-2024 Best Practical Solutions, LLC
#                                          <sales@bestpractical.com>
#
# (Except where explicitly superseded by other copyright notices)
#
#
# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
# from www.gnu.org.
#
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 or visit their web page on the internet at
# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
#
#
# CONTRIBUTION SUBMISSION POLICY:
#
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of
# the GNU General Public License and is only of importance to you if
# you choose to contribute your changes and enhancements to the
# community by submitting them to Best Practical Solutions, LLC.)
#
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with
# Request Tracker, to Best Practical Solutions, LLC, you confirm that
# you are the copyright holder for those contributions and you grant
# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
# royalty-free, perpetual, license to use, copy, create derivative
# works based on those contributions, and sublicense and distribute
# those contributions and any derivatives thereof.
#
# END BPS TAGGED BLOCK }}}

package RT::Test::Crypt;
use strict;
use warnings;
use Test::More;
use RT::Crypt;
use base qw(RT::Test);
use File::Temp qw(tempdir);
use IPC::Run3 'run3';
use File::Copy;
use RT::Util 'safe_run_child';
use 5.010;

our @EXPORT =
  qw(create_a_ticket update_ticket cleanup_headers set_queue_crypt_options 
          check_text_emails send_email_and_check_transaction
          create_and_test_outgoing_emails
          );

our $UsingGnuPG = 0;
sub import {
    my $class = shift;
    my %args  = @_;
    my $t     = $class->builder;

    if ($args{GnuPG}) {
        $UsingGnuPG = 1;
        RT::Test::plan( skip_all => 'ENV SKIP_GPG_TESTS is set to true.' )
            if $ENV{'SKIP_GPG_TESTS'};
        RT::Test::plan( skip_all => 'GnuPG required.' )
            unless RT::StaticUtil::RequireModule("GnuPG::Interface");
        RT::Test::plan( skip_all => 'gpg executable is required.' )
            unless RT::Test->find_executable('gpg');
    }

    if ($args{SMIME}) {
        RT::Test::plan( skip_all => 'openssl executable is required.' )
            unless RT::Test->find_executable('openssl');
    }
    $class->SUPER::import(%args);
    return $class->export_to_level(1)
        if $^C;

    RT::Test::diag "GnuPG --homedir " . RT->Config->Get('GnuPGOptions')->{'homedir'};

    $class->set_rights(
        Principal => 'Everyone',
        Right => ['CreateTicket', 'ShowTicket', 'SeeQueue', 'ReplyToTicket', 'ModifyTicket'],
    );

    $class->export_to_level(1);
}

sub bootstrap_more_config {
    my $self = shift;
    my $handle = shift;
    my $args = shift;

    $self->SUPER::bootstrap_more_config($handle, $args, @_);

    if ($args->{GnuPG}) {
        my %gnupg_options = (
            'no-permission-warning' => undef,
            $args->{gnupg_options} ? %{ $args->{gnupg_options} } : (),
            );
        $gnupg_options{homedir} ||= new_homedir();

        my $conf = File::Spec->catfile( $gnupg_options{homedir}, 'gpg.conf' );
        if ( gnupg_version() >= 2 ) {
            open my $fh, '>', $conf or die $!;
            print $fh "pinentry-mode loopback\n";
            close $fh;
        }
        else {
            unlink $conf if -e $conf;
        }

        use Data::Dumper;
        local $Data::Dumper::Terse = 1; # "{...}" instead of "$VAR1 = {...};"
        my $dumped_gnupg_options = Dumper(\%gnupg_options);

        print $handle qq{
        Set(\%GnuPG, (
    Enable                 => 1,
    OutgoingMessagesFormat => 'RFC',
            ));
        Set(\%GnuPGOptions => \%{ $dumped_gnupg_options });
        };
    }

    if ($args->{SMIME}) {
        my $openssl = $self->find_executable('openssl');

        my $keyring = $self->smime_keyring_path;
        mkdir($keyring);

        my $ca = $self->smime_key_path("demoCA", "cacert.pem");

        if (!$args->{GnuPG}) {
            print $handle qq{ Set(\%GnuPG, Enable => 0); };
        }

        my $out;
        safe_run_child {
            run3( [ $openssl, 'version' ], \undef, \$out, \undef, )
        };

        my @providers;
        if ( $out =~ /^OpenSSL 3/ ) {
            @providers = ( 'default', 'legacy' );
        }

        print $handle qq{
        Set(\%SMIME =>
            Enable => 1,
            Passphrase => {
        'root\@example.com' => '123456',
            'sender\@example.com' => '123456',
        },
            OpenSSL => q{$openssl},
            Keyring => q{$keyring},
            CAPath  => q{$ca},
            Providers => [qw(@providers)],
            );
        };

    }
}

sub smime_keyring_path {
    return File::Spec->catfile( RT::Test->temp_directory, "smime" );
}

sub smime_key_path {
    my $self = shift;
    my $keys = RT::Test::find_relocatable_path(
        qw(data smime keys),
    );
    return File::Spec->catfile( $keys => @_ ),
}

sub smime_mail_set_path {
    my $self = shift;
    return RT::Test::find_relocatable_path(
        qw(data smime mails),
    );
}

sub smime_import_key {
    my $self = shift;
    my $key  = shift;
    my $user = shift;

    my $path = RT::Test::find_relocatable_path( 'data', 'smime', 'keys' );
    die "can't find the dir where smime keys are stored"
        unless $path;

    my $keyring = RT->Config->Get('SMIME')->{'Keyring'};
    die "SMIME keyring '$keyring' doesn't exist"
        unless $keyring && -e $keyring;

    $key .= ".pem" unless $key =~ /\.(pem|crt|key)$/;

    my $content = RT::Test->file_content( [ $path, $key ] );

    if ( $user ) {
        my ($status, $msg) = $user->SetSMIMECertificate( $content );
        die "Couldn't set CF: $msg" unless $status;
    } else {
        my $keyring = RT->Config->Get('SMIME')->{'Keyring'};
        die "SMIME keyring '$keyring' doesn't exist"
            unless $keyring && -e $keyring;

        open my $fh, '>:raw', File::Spec->catfile($keyring, $key)
            or die "can't open file: $!";
        print $fh $content;
        close $fh;
    }

    return;
}

sub create_a_ticket {
    my $queue = shift;
    my $mail = shift;
    my $m = shift;
    my %args = (@_);

    RT::Test->clean_caught_mails;

    $m->goto_create_ticket( $queue );
    $m->form_name('TicketCreate');
    $m->field( Subject    => 'test' );
    $m->field( Requestors => 'rt-test@example.com' );
    $m->field( Content    => 'Some content' );

    foreach ( qw(Sign Encrypt) ) {
        if ( $args{ $_ } ) {
            $m->tick( $_ => 1 );
        } else {
            $m->untick( $_ => 1 );
        }
    }

    $m->click('SubmitTicket');
    is $m->status, 200, "request successful";

    $m->content_lacks("unable to sign outgoing email messages");


    my @mail = RT::Test->fetch_caught_mails;
    check_text_emails(\%args, @mail );
    categorize_emails($mail, \%args, @mail );
}

sub update_ticket {
    my $tid = shift;
    my $mail = shift;
    my $m = shift;
    my %args = (@_);

    RT::Test->clean_caught_mails;

    $m->get( $m->rt_base_url . "/Ticket/Update.html?Action=Respond&id=$tid" );
    $m->form_number(3);
    $m->field( UpdateContent => 'Some content' );

    foreach ( qw(Sign Encrypt) ) {
        if ( $args{ $_ } ) {
            $m->tick( $_ => 1 );
        } else {
            $m->untick( $_ => 1 );
        }
    }

    $m->click('SubmitTicket');
    is $m->status, 200, "request successful";
    $m->content_contains("Correspondence added", 'Correspondence added') or diag $m->content;


    my @mail = RT::Test->fetch_caught_mails;
    check_text_emails(\%args, @mail );
    categorize_emails($mail, \%args, @mail );
}

sub categorize_emails {
    my $mail = shift;
    my $args = shift;
    my @mail = @_;

    if ( $args->{'Sign'} && $args->{'Encrypt'} ) {
        push @{ $mail->{'signed_encrypted'} }, @mail;
    }
    elsif ( $args->{'Sign'} ) {
        push @{ $mail->{'signed'} }, @mail;
    }
    elsif ( $args->{'Encrypt'} ) {
        push @{ $mail->{'encrypted'} }, @mail;
    }
    else {
        push @{ $mail->{'plain'} }, @mail;
    }
}

sub check_text_emails {
    my %args = %{ shift @_ };
    my @mail = @_;

    ok scalar @mail, "got some mail";
    for my $mail (@mail) {
        for my $type ('email', 'attachment') {
            next if $type eq 'attachment' && !$args{'Attachment'};

            my $content = $type eq 'email'
                        ? "Some content"
                        : $args{Attachment};

            if ( $args{'Encrypt'} ) {
                unlike $mail, qr/$content/, "outgoing $type is not in plaintext";
                my $entity = RT::Test::parse_mail($mail);
                my @res = RT::Crypt->VerifyDecrypt(Entity => $entity);
                like $res[0]{'status'}, qr/DECRYPTION_OKAY/, "Decrypts OK";
                like $entity->as_string, qr/$content/, "outgoing decrypts to contain $type content";
            } else {
                like $mail, qr/$content/, "outgoing $type was not encrypted";
            }

            next unless $type eq 'email';

            if ( $args{'Sign'} && $args{'Encrypt'} ) {
                like $mail, qr/BEGIN PGP MESSAGE/, 'outgoing email was signed';
            } elsif ( $args{'Sign'} ) {
                like $mail, qr/SIGNATURE/, 'outgoing email was signed';
            } else {
                unlike $mail, qr/SIGNATURE/, 'outgoing email was not signed';
            }
        }
    }
}

sub cleanup_headers {
    my $mail = shift;
    # strip id from subject to create new ticket
    $mail =~ s/^(Subject:)\s*\[.*?\s+#\d+\]\s*/$1 /m;
    # strip several headers
    foreach my $field ( qw(Message-ID RT-Originator RT-Ticket X-RT-Loop-Prevention) ) {
        $mail =~ s/^$field:.*?\n(?! |\t)//gmsi;
    }
    return $mail;
}

sub set_queue_crypt_options {
    my $queue = shift;
    my %args = @_;
    $queue->SetEncrypt($args{'Encrypt'});
    $queue->SetSign($args{'Sign'});
}

sub send_email_and_check_transaction {
    my $mail = shift;
    my $type = shift;

    my ( $status, $id ) = RT::Test->send_via_mailgate($mail);
    is( $status >> 8, 0, "The mail gateway exited normally" );
    ok( $id, "got id of a newly created ticket - $id" );

    my $tick = RT::Ticket->new( RT->SystemUser );
    $tick->Load($id);
    ok( $tick->id, "loaded ticket #$id" );

    my $txn = $tick->Transactions->First;
    my ( $msg, @attachments ) = @{ $txn->Attachments->ItemsArrayRef };

    if ( $attachments[0] ) {
        like $attachments[0]->Content, qr/Some content/,
          "RT's mail includes copy of ticket text";
    }
    else {
        like $msg->Content, qr/Some content/,
          "RT's mail includes copy of ticket text";
    }

    if ( $type eq 'plain' ) {
        ok !$msg->GetHeader('X-RT-Privacy'), "RT's outgoing mail has no crypto";
        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Not encrypted',
          "RT's outgoing mail looks not encrypted";
        ok !$msg->GetHeader('X-RT-Incoming-Signature'),
          "RT's outgoing mail looks not signed";
    }
    elsif ( $type eq 'signed' ) {
        is $msg->GetHeader('X-RT-Privacy'), 'GnuPG',
          "RT's outgoing mail has crypto";
        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Not encrypted',
          "RT's outgoing mail looks not encrypted";
        like $msg->GetHeader('X-RT-Incoming-Signature'),
          qr/<rt-recipient\@example.com>/,
          "RT's outgoing mail looks signed";
    }
    elsif ( $type eq 'encrypted' ) {
        is $msg->GetHeader('X-RT-Privacy'), 'GnuPG',
          "RT's outgoing mail has crypto";
        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Success',
          "RT's outgoing mail looks encrypted";
        ok !$msg->GetHeader('X-RT-Incoming-Signature'),
          "RT's outgoing mail looks not signed";

    }
    elsif ( $type eq 'signed_encrypted' ) {
        is $msg->GetHeader('X-RT-Privacy'), 'GnuPG',
          "RT's outgoing mail has crypto";
        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Success',
          "RT's outgoing mail looks encrypted";
        like $msg->GetHeader('X-RT-Incoming-Signature'),
          qr/<rt-recipient\@example.com>/,
          "RT's outgoing mail looks signed";
    }
    else {
        die "unknown type: $type";
    }
}

sub create_and_test_outgoing_emails {
    my $queue = shift;
    my $m     = shift;
    my @variants =
      ( {}, { Sign => 1 }, { Encrypt => 1 }, { Sign => 1, Encrypt => 1 }, );

    # collect emails
    my %mail;

    # create a ticket for each combination
    foreach my $ticket_set (@variants) {
        create_a_ticket( $queue, \%mail, $m, %$ticket_set );
    }

    my $tid;
    {
        my $ticket = RT::Ticket->new( RT->SystemUser );
        ($tid) = $ticket->Create(
            Subject   => 'test',
            Queue     => $queue->id,
            Requestor => 'rt-test@example.com',
        );
        ok $tid, 'ticket created';
    }

    # again for each combination add a reply message
    foreach my $ticket_set (@variants) {
        update_ticket( $tid, \%mail, $m, %$ticket_set );
    }

# ------------------------------------------------------------------------------
# now delete all keys from the keyring and put back secret/pub pair for rt-test@
# and only public key for rt-recipient@ so we can verify signatures and decrypt
# like we are on another side recieve emails
# ------------------------------------------------------------------------------

    unlink $_
      foreach glob( RT->Config->Get('GnuPGOptions')->{'homedir'} . "/*" );
    RT::Test->import_gnupg_key( 'rt-recipient@example.com', 'public' );
    RT::Test->import_gnupg_key('rt-test@example.com');

    $queue = RT::Test->load_or_create_queue(
        Name              => 'Regression',
        CorrespondAddress => 'rt-test@example.com',
        CommentAddress    => 'rt-test@example.com',
    );
    ok $queue && $queue->id, 'changed props of the queue';

    for my $type ( keys %mail ) {
        for my $mail ( map cleanup_headers($_), @{ $mail{$type} } ) {
            send_email_and_check_transaction( $mail, $type );
        }
    }
}

sub gnupg_version {
    RT::StaticUtil::RequireModule("GnuPG::Interface") or return;
    require version;
    state $gnupg_version = version->parse(GnuPG::Interface->new->version);
}

sub new_homedir {
    my $source = shift;
    my $dir = tempdir();

    if ($source) {
        opendir my $dh, $source or die $!;
        for my $file ( grep {/\.gpg$/} readdir $dh ) {
            copy( File::Spec->catfile( $source, $file ), File::Spec->catfile( $dir, $file ) ) or die $!;
        }
        closedir $dh;
        if ( gnupg_version() >= 2 ) {
            # Do the data migration
            run3( [ 'gpg', '--homedir', $dir, '--list-secret-keys' ], \undef, \undef, \undef );
        }
    }

    return $dir;
}

END {
    if ($UsingGnuPG) {
        if ( gnupg_version() >= 2 ) {
            system( 'gpgconf', '--homedir', RT->Config->Get('GnuPGOptions')->{homedir}, '--quiet', '--kill', 'gpg-agent' )
                && warn $!;
        }
    }
}

1;