1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
5# This software is Copyright (c) 1996-2021 Best Practical Solutions, LLC
6#                                          <sales@bestpractical.com>
7#
8# (Except where explicitly superseded by other copyright notices)
9#
10#
11# LICENSE:
12#
13# This work is made available to you under the terms of Version 2 of
14# the GNU General Public License. A copy of that license should have
15# been provided with this software, but in any event can be snarfed
16# from www.gnu.org.
17#
18# This work is distributed in the hope that it will be useful, but
19# WITHOUT ANY WARRANTY; without even the implied warranty of
20# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21# General Public License for more details.
22#
23# You should have received a copy of the GNU General Public License
24# along with this program; if not, write to the Free Software
25# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26# 02110-1301 or visit their web page on the internet at
27# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28#
29#
30# CONTRIBUTION SUBMISSION POLICY:
31#
32# (The following paragraph is not intended to limit the rights granted
33# to you to modify and distribute this software under the terms of
34# the GNU General Public License and is only of importance to you if
35# you choose to contribute your changes and enhancements to the
36# community by submitting them to Best Practical Solutions, LLC.)
37#
38# By intentionally submitting any modifications, corrections or
39# derivatives to this work, or any other work intended for use with
40# Request Tracker, to Best Practical Solutions, LLC, you confirm that
41# you are the copyright holder for those contributions and you grant
42# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43# royalty-free, perpetual, license to use, copy, create derivative
44# works based on those contributions, and sublicense and distribute
45# those contributions and any derivatives thereof.
46#
47# END BPS TAGGED BLOCK }}}
48
49package RT::Test::Crypt;
50use strict;
51use warnings;
52use Test::More;
53use RT::Crypt;
54use base qw(RT::Test);
55use File::Temp qw(tempdir);
56use IPC::Run3 'run3';
57use File::Copy;
58use 5.010;
59
60our @EXPORT =
61  qw(create_a_ticket update_ticket cleanup_headers set_queue_crypt_options
62          check_text_emails send_email_and_check_transaction
63          create_and_test_outgoing_emails
64          );
65
66our $UsingGnuPG = 0;
67sub import {
68    my $class = shift;
69    my %args  = @_;
70    my $t     = $class->builder;
71
72    if ($args{GnuPG}) {
73        $UsingGnuPG = 1;
74        RT::Test::plan( skip_all => 'ENV SKIP_GPG_TESTS is set to true.' )
75            if $ENV{'SKIP_GPG_TESTS'};
76        RT::Test::plan( skip_all => 'GnuPG required.' )
77            unless GnuPG::Interface->require;
78        RT::Test::plan( skip_all => 'gpg executable is required.' )
79            unless RT::Test->find_executable('gpg');
80    }
81
82    if ($args{SMIME}) {
83        RT::Test::plan( skip_all => 'openssl executable is required.' )
84            unless RT::Test->find_executable('openssl');
85    }
86    $class->SUPER::import(%args);
87    return $class->export_to_level(1)
88        if $^C;
89
90    RT::Test::diag "GnuPG --homedir " . RT->Config->Get('GnuPGOptions')->{'homedir'};
91
92    $class->set_rights(
93        Principal => 'Everyone',
94        Right => ['CreateTicket', 'ShowTicket', 'SeeQueue', 'ReplyToTicket', 'ModifyTicket'],
95    );
96
97    $class->export_to_level(1);
98}
99
100sub bootstrap_more_config {
101    my $self = shift;
102    my $handle = shift;
103    my $args = shift;
104
105    $self->SUPER::bootstrap_more_config($handle, $args, @_);
106
107    if ($args->{GnuPG}) {
108        my %gnupg_options = (
109            'no-permission-warning' => undef,
110            $args->{gnupg_options} ? %{ $args->{gnupg_options} } : (),
111            );
112        $gnupg_options{homedir} ||= new_homedir();
113
114        my $conf = File::Spec->catfile( $gnupg_options{homedir}, 'gpg.conf' );
115        if ( gnupg_version() >= 2 ) {
116            open my $fh, '>', $conf or die $!;
117            print $fh "pinentry-mode loopback\n";
118            close $fh;
119        }
120        else {
121            unlink $conf if -e $conf;
122        }
123
124        use Data::Dumper;
125        local $Data::Dumper::Terse = 1; # "{...}" instead of "$VAR1 = {...};"
126        my $dumped_gnupg_options = Dumper(\%gnupg_options);
127
128        print $handle qq{
129        Set(\%GnuPG, (
130    Enable                 => 1,
131    OutgoingMessagesFormat => 'RFC',
132            ));
133        Set(\%GnuPGOptions => \%{ $dumped_gnupg_options });
134        };
135    }
136
137    if ($args->{SMIME}) {
138        my $openssl = $self->find_executable('openssl');
139
140        my $keyring = $self->smime_keyring_path;
141        mkdir($keyring);
142
143        my $ca = $self->smime_key_path("demoCA", "cacert.pem");
144
145        if (!$args->{GnuPG}) {
146            print $handle qq{ Set(\%GnuPG, Enable => 0); };
147        }
148        print $handle qq{
149        Set(\%SMIME =>
150            Enable => 1,
151            Passphrase => {
152        'root\@example.com' => '123456',
153            'sender\@example.com' => '123456',
154        },
155            OpenSSL => q{$openssl},
156            Keyring => q{$keyring},
157            CAPath  => q{$ca},
158            );
159        };
160
161    }
162}
163
164sub smime_keyring_path {
165    return File::Spec->catfile( RT::Test->temp_directory, "smime" );
166}
167
168sub smime_key_path {
169    my $self = shift;
170    my $keys = RT::Test::find_relocatable_path(
171        qw(data smime keys),
172    );
173    return File::Spec->catfile( $keys => @_ ),
174}
175
176sub smime_mail_set_path {
177    my $self = shift;
178    return RT::Test::find_relocatable_path(
179        qw(data smime mails),
180    );
181}
182
183sub smime_import_key {
184    my $self = shift;
185    my $key  = shift;
186    my $user = shift;
187
188    my $path = RT::Test::find_relocatable_path( 'data', 'smime', 'keys' );
189    die "can't find the dir where smime keys are stored"
190        unless $path;
191
192    my $keyring = RT->Config->Get('SMIME')->{'Keyring'};
193    die "SMIME keyring '$keyring' doesn't exist"
194        unless $keyring && -e $keyring;
195
196    $key .= ".pem" unless $key =~ /\.(pem|crt|key)$/;
197
198    my $content = RT::Test->file_content( [ $path, $key ] );
199
200    if ( $user ) {
201        my ($status, $msg) = $user->SetSMIMECertificate( $content );
202        die "Couldn't set CF: $msg" unless $status;
203    } else {
204        my $keyring = RT->Config->Get('SMIME')->{'Keyring'};
205        die "SMIME keyring '$keyring' doesn't exist"
206            unless $keyring && -e $keyring;
207
208        open my $fh, '>:raw', File::Spec->catfile($keyring, $key)
209            or die "can't open file: $!";
210        print $fh $content;
211        close $fh;
212    }
213
214    return;
215}
216
217sub create_a_ticket {
218    my $queue = shift;
219    my $mail = shift;
220    my $m = shift;
221    my %args = (@_);
222
223    RT::Test->clean_caught_mails;
224
225    $m->goto_create_ticket( $queue );
226    $m->form_name('TicketCreate');
227    $m->field( Subject    => 'test' );
228    $m->field( Requestors => 'rt-test@example.com' );
229    $m->field( Content    => 'Some content' );
230
231    foreach ( qw(Sign Encrypt) ) {
232        if ( $args{ $_ } ) {
233            $m->tick( $_ => 1 );
234        } else {
235            $m->untick( $_ => 1 );
236        }
237    }
238
239    $m->submit;
240    is $m->status, 200, "request successful";
241
242    $m->content_lacks("unable to sign outgoing email messages");
243
244
245    my @mail = RT::Test->fetch_caught_mails;
246    check_text_emails(\%args, @mail );
247    categorize_emails($mail, \%args, @mail );
248}
249
250sub update_ticket {
251    my $tid = shift;
252    my $mail = shift;
253    my $m = shift;
254    my %args = (@_);
255
256    RT::Test->clean_caught_mails;
257
258    $m->get( $m->rt_base_url . "/Ticket/Update.html?Action=Respond&id=$tid" );
259    $m->form_number(3);
260    $m->field( UpdateContent => 'Some content' );
261
262    foreach ( qw(Sign Encrypt) ) {
263        if ( $args{ $_ } ) {
264            $m->tick( $_ => 1 );
265        } else {
266            $m->untick( $_ => 1 );
267        }
268    }
269
270    $m->click('SubmitTicket');
271    is $m->status, 200, "request successful";
272    $m->content_contains("Correspondence added", 'Correspondence added') or diag $m->content;
273
274
275    my @mail = RT::Test->fetch_caught_mails;
276    check_text_emails(\%args, @mail );
277    categorize_emails($mail, \%args, @mail );
278}
279
280sub categorize_emails {
281    my $mail = shift;
282    my $args = shift;
283    my @mail = @_;
284
285    if ( $args->{'Sign'} && $args->{'Encrypt'} ) {
286        push @{ $mail->{'signed_encrypted'} }, @mail;
287    }
288    elsif ( $args->{'Sign'} ) {
289        push @{ $mail->{'signed'} }, @mail;
290    }
291    elsif ( $args->{'Encrypt'} ) {
292        push @{ $mail->{'encrypted'} }, @mail;
293    }
294    else {
295        push @{ $mail->{'plain'} }, @mail;
296    }
297}
298
299sub check_text_emails {
300    my %args = %{ shift @_ };
301    my @mail = @_;
302
303    ok scalar @mail, "got some mail";
304    for my $mail (@mail) {
305        for my $type ('email', 'attachment') {
306            next if $type eq 'attachment' && !$args{'Attachment'};
307
308            my $content = $type eq 'email'
309                        ? "Some content"
310                        : $args{Attachment};
311
312            if ( $args{'Encrypt'} ) {
313                unlike $mail, qr/$content/, "outgoing $type is not in plaintext";
314                my $entity = RT::Test::parse_mail($mail);
315                my @res = RT::Crypt->VerifyDecrypt(Entity => $entity);
316                like $res[0]{'status'}, qr/DECRYPTION_OKAY/, "Decrypts OK";
317                like $entity->as_string, qr/$content/, "outgoing decrypts to contain $type content";
318            } else {
319                like $mail, qr/$content/, "outgoing $type was not encrypted";
320            }
321
322            next unless $type eq 'email';
323
324            if ( $args{'Sign'} && $args{'Encrypt'} ) {
325                like $mail, qr/BEGIN PGP MESSAGE/, 'outgoing email was signed';
326            } elsif ( $args{'Sign'} ) {
327                like $mail, qr/SIGNATURE/, 'outgoing email was signed';
328            } else {
329                unlike $mail, qr/SIGNATURE/, 'outgoing email was not signed';
330            }
331        }
332    }
333}
334
335sub cleanup_headers {
336    my $mail = shift;
337    # strip id from subject to create new ticket
338    $mail =~ s/^(Subject:)\s*\[.*?\s+#\d+\]\s*/$1 /m;
339    # strip several headers
340    foreach my $field ( qw(Message-ID RT-Originator RT-Ticket X-RT-Loop-Prevention) ) {
341        $mail =~ s/^$field:.*?\n(?! |\t)//gmsi;
342    }
343    return $mail;
344}
345
346sub set_queue_crypt_options {
347    my $queue = shift;
348    my %args = @_;
349    $queue->SetEncrypt($args{'Encrypt'});
350    $queue->SetSign($args{'Sign'});
351}
352
353sub send_email_and_check_transaction {
354    my $mail = shift;
355    my $type = shift;
356
357    my ( $status, $id ) = RT::Test->send_via_mailgate($mail);
358    is( $status >> 8, 0, "The mail gateway exited normally" );
359    ok( $id, "got id of a newly created ticket - $id" );
360
361    my $tick = RT::Ticket->new( RT->SystemUser );
362    $tick->Load($id);
363    ok( $tick->id, "loaded ticket #$id" );
364
365    my $txn = $tick->Transactions->First;
366    my ( $msg, @attachments ) = @{ $txn->Attachments->ItemsArrayRef };
367
368    if ( $attachments[0] ) {
369        like $attachments[0]->Content, qr/Some content/,
370          "RT's mail includes copy of ticket text";
371    }
372    else {
373        like $msg->Content, qr/Some content/,
374          "RT's mail includes copy of ticket text";
375    }
376
377    if ( $type eq 'plain' ) {
378        ok !$msg->GetHeader('X-RT-Privacy'), "RT's outgoing mail has no crypto";
379        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Not encrypted',
380          "RT's outgoing mail looks not encrypted";
381        ok !$msg->GetHeader('X-RT-Incoming-Signature'),
382          "RT's outgoing mail looks not signed";
383    }
384    elsif ( $type eq 'signed' ) {
385        is $msg->GetHeader('X-RT-Privacy'), 'GnuPG',
386          "RT's outgoing mail has crypto";
387        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Not encrypted',
388          "RT's outgoing mail looks not encrypted";
389        like $msg->GetHeader('X-RT-Incoming-Signature'),
390          qr/<rt-recipient\@example.com>/,
391          "RT's outgoing mail looks signed";
392    }
393    elsif ( $type eq 'encrypted' ) {
394        is $msg->GetHeader('X-RT-Privacy'), 'GnuPG',
395          "RT's outgoing mail has crypto";
396        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Success',
397          "RT's outgoing mail looks encrypted";
398        ok !$msg->GetHeader('X-RT-Incoming-Signature'),
399          "RT's outgoing mail looks not signed";
400
401    }
402    elsif ( $type eq 'signed_encrypted' ) {
403        is $msg->GetHeader('X-RT-Privacy'), 'GnuPG',
404          "RT's outgoing mail has crypto";
405        is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Success',
406          "RT's outgoing mail looks encrypted";
407        like $msg->GetHeader('X-RT-Incoming-Signature'),
408          qr/<rt-recipient\@example.com>/,
409          "RT's outgoing mail looks signed";
410    }
411    else {
412        die "unknown type: $type";
413    }
414}
415
416sub create_and_test_outgoing_emails {
417    my $queue = shift;
418    my $m     = shift;
419    my @variants =
420      ( {}, { Sign => 1 }, { Encrypt => 1 }, { Sign => 1, Encrypt => 1 }, );
421
422    # collect emails
423    my %mail;
424
425    # create a ticket for each combination
426    foreach my $ticket_set (@variants) {
427        create_a_ticket( $queue, \%mail, $m, %$ticket_set );
428    }
429
430    my $tid;
431    {
432        my $ticket = RT::Ticket->new( RT->SystemUser );
433        ($tid) = $ticket->Create(
434            Subject   => 'test',
435            Queue     => $queue->id,
436            Requestor => 'rt-test@example.com',
437        );
438        ok $tid, 'ticket created';
439    }
440
441    # again for each combination add a reply message
442    foreach my $ticket_set (@variants) {
443        update_ticket( $tid, \%mail, $m, %$ticket_set );
444    }
445
446# ------------------------------------------------------------------------------
447# now delete all keys from the keyring and put back secret/pub pair for rt-test@
448# and only public key for rt-recipient@ so we can verify signatures and decrypt
449# like we are on another side recieve emails
450# ------------------------------------------------------------------------------
451
452    unlink $_
453      foreach glob( RT->Config->Get('GnuPGOptions')->{'homedir'} . "/*" );
454    RT::Test->import_gnupg_key( 'rt-recipient@example.com', 'public' );
455    RT::Test->import_gnupg_key('rt-test@example.com');
456
457    $queue = RT::Test->load_or_create_queue(
458        Name              => 'Regression',
459        CorrespondAddress => 'rt-test@example.com',
460        CommentAddress    => 'rt-test@example.com',
461    );
462    ok $queue && $queue->id, 'changed props of the queue';
463
464    for my $type ( keys %mail ) {
465        for my $mail ( map cleanup_headers($_), @{ $mail{$type} } ) {
466            send_email_and_check_transaction( $mail, $type );
467        }
468    }
469}
470
471sub gnupg_version {
472    GnuPG::Interface->require or return;
473    require version;
474    state $gnupg_version = version->parse(GnuPG::Interface->new->version);
475}
476
477sub new_homedir {
478    my $source = shift;
479    my $dir = tempdir();
480
481    if ($source) {
482        opendir my $dh, $source or die $!;
483        for my $file ( grep {/\.gpg$/} readdir $dh ) {
484            copy( File::Spec->catfile( $source, $file ), File::Spec->catfile( $dir, $file ) ) or die $!;
485        }
486        closedir $dh;
487        if ( gnupg_version() >= 2 ) {
488            # Do the data migration
489            run3( [ 'gpg', '--homedir', $dir, '--list-secret-keys' ], \undef, \undef, \undef );
490        }
491    }
492
493    return $dir;
494}
495
496END {
497    if ($UsingGnuPG) {
498        if ( gnupg_version() >= 2 ) {
499            system( 'gpgconf', '--homedir', RT->Config->Get('GnuPGOptions')->{homedir}, '--quiet', '--kill', 'gpg-agent' )
500                && warn $!;
501        }
502    }
503}
504
5051;
506