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