summaryrefslogtreecommitdiff
path: root/rt/lib/RT/Crypt.pm
blob: a5ae1f1786c99382d18a23f65ef57f825e26a116 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
# BEGIN BPS TAGGED BLOCK {{{
#
# COPYRIGHT:
#
# This software is Copyright (c) 1996-2018 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 }}}

use strict;
use warnings;

package RT::Crypt;
use 5.010;

=head1 NAME

RT::Crypt - encrypt/decrypt and sign/verify subsystem for RT

=head1 DESCRIPTION

This module provides support for encryption and signing of outgoing
messages, as well as the decryption and verification of incoming emails
using various encryption standards. Currently, L<GnuPG|RT::Crypt::GnuPG>
and L<SMIME|RT::Crypt::SMIME> protocols are supported.

=head1 CONFIGURATION

You can control the configuration of this subsystem from RT's configuration file.
Some options are available via the web interface, but to enable this functionality,
you MUST start in the configuration file.

For each protocol there is a hash with the same name in the configuration file.
This hash controls RT-specific options regarding the protocol. It allows you to
enable/disable each facility or change the format of messages; for example, GnuPG
uses the following config:

    Set( %GnuPG,
        Enable => 1,
        ... other options ...
    );

C<Enable> is the only key that is generic for all protocols. A protocol may have
additional options to fine-tune behaviour.

However, note that you B<must> add the
L<Auth::Crypt|RT::Interface::Email::Auth::Crypt> email filter to enable
the handling of incoming encrypted/signed messages.  It should be added
in addition to the standard
L<Auth::MailFrom|RT::Interface::Email::Auth::Crypt> plugin.

=head2 %Crypt

This config option hash chooses which protocols are decrypted and
verified in incoming messages, which protocol is used for outgoing
emails, and RT's behaviour on errors during decrypting and verification.

RT will provide sane defaults for all of these options.  By default, all
enabled encryption protocols are decrypted on incoming mail; if you wish
to limit this to a subset, you may, via:

    Set( %Crypt,
        ...
        Incoming => ['SMIME'],
        ...
    );

RT can currently only use one protocol to encrypt and sign outgoing
email; this defaults to the first enabled protocol.  You many specify it
explicitly via:

    Set( %Crypt,
        ...
        Outgoing => 'GnuPG',
        ...
    );

You can allow users to encrypt data in the database by setting the
C<AllowEncryptDataInDB> key to a true value; by default, this is
disabled.  Be aware that users must have rights to see and modify
tickets to use this feature.

=head2 Per-queue options

Using the web interface, it is possible to enable signing and/or
encrypting by default. As an administrative user of RT, navigate to the
'Admin' and 'Queues' menus, and select a queue.  If at least one
encryption protocol is enabled, information concerning available keys
will be displayed, as well as options to enable signing and encryption.

=head2 Handling incoming messages

To enable handling of encrypted and signed message in the RT you must
enable the L<RT::Interface::Email::Auth::Crypt> mail plugin:

    Set(@MailPlugins, 'Auth::MailFrom', 'Auth::Crypt', ...other filter...);

=head2 Error handling

There are several global templates created in the database by
default. RT uses these templates to send error messages to users or RT's
owner. These templates have an 'Error:' or 'Error to RT owner:' prefix
in the name. You can adjust the text of the messages using the web
interface.

Note that while C<$TicketObj>, C<$TransactionObj> and other variables
usually available in RT's templates are not available in these
templates, but each is passed alternate data structures can be used to
build better messages; see the default templates and descriptions below.

You can disable any particular notification by simply deleting the
content of a template.  Deleting the templates entirely is not
suggested, as RT will log error messages when attempting to send mail
usign them.

=head3 Problems with public keys

The 'Error: public key' template is used to inform the user that RT had
problems with their public key, and thus will not be able to send
encrypted content. There are several reasons why RT might fail to use a
key; by default, the actual reason is not sent to the user, but sent to
the RT owner using the 'Error to RT owner: public key' template.

Possible reasons include "Not Found", "Ambiguous specification", "Wrong
key usage", "Key revoked", "Key expired", "No CRL known", "CRL too old",
"Policy mismatch", "Not a secret key", "Key not trusted" or "No specific
reason given".

In the 'Error: public key' template there are a few additional variables
available:

=over 4

=item $Message - user friendly error message

=item $Reason - short reason as listed above

=item $Recipient - recipient's identification

=item $AddressObj - L<Email::Address> object containing recipient's email address

=back

As a message may have several invalid recipients, to avoid sending many
emails to the RT owner, the system sends one message to the owner,
grouped by recipient. In the 'Error to RT owner: public key' template a
C<@BadRecipients> array is available where each element is a hash
reference that describes one recipient using the same fields as
described above:

    @BadRecipients = (
        { Message => '...', Reason => '...', Recipient => '...', ...},
        { Message => '...', Reason => '...', Recipient => '...', ...},
        ...
    )

=head3 Private key doesn't exist

The 'Error: no private key' template is used to inform the user that
they sent an encrypted email to RT, but RT does not have the private key
to decrypt it.

In this template L<MIME::Entity> object C<$Message> is available, which
is the originally received message.

=head3 Invalid data

The 'Error: bad encrypted data' template is used to inform the user that
a message they sent had invalid data, and could not be handled.  There
are several possible reasons for this error, but most of them are data
corruption or absence of expected information.

In this template, the C<@Messages> array is available, and will contain
a list of error messages.

=head1 METHODS

=head2 Protocols

Returns the complete set of encryption protocols that RT implements; not
all may be supported by this installation.

=cut

our @PROTOCOLS = ('GnuPG', 'SMIME');
our %PROTOCOLS = map { lc $_ => $_ } @PROTOCOLS;

sub Protocols {
    return @PROTOCOLS;
}

=head2 EnabledProtocols

Returns the set of enabled and available encryption protocols.

=cut

sub EnabledProtocols {
    my $self = shift;
    return grep RT->Config->Get($_)->{'Enable'}, $self->Protocols;
}

=head2 UseForOutgoing

Returns the configured outgoing encryption protocol; see
L<RT_Config/Crypt>.

=cut

sub UseForOutgoing {
    return RT->Config->Get('Crypt')->{'Outgoing'};
}

=head2 EnabledOnIncoming

Returns the list of encryption protocols that should be used for
decryption and verification of incoming email; see L<RT_Config/Crypt>.
This list is irrelevant unless L<RT::Interface::Email::Auth::Crypt> is
enabled in L<RT_Config/@MailPlugins>.

=cut

sub EnabledOnIncoming {
    return @{ scalar RT->Config->Get('Crypt')->{'Incoming'} };
}

=head2 LoadImplementation CLASS

Given the name of an encryption implementation (e.g. "GnuPG"), loads the
L<RT::Crypt> class associated with it; return the classname on success,
and undef on failure.

=cut

sub LoadImplementation {
    state %cache;
    my $proto = $PROTOCOLS{ lc $_[1] } or die "Unknown protocol '$_[1]'";
    my $class = 'RT::Crypt::'. $proto;
    return $cache{ $class } if exists $cache{ $class };

    if ($class->require) {
        return $cache{ $class } = $class;
    } else {
        RT->Logger->warn( "Could not load $class: $@" );
        return $cache{ $class } = undef;
    }
}

=head2 SimpleImplementationCall Protocol => NAME, [...]

Examines the caller of this method, and dispatches to the method of the
same name on the correct L<RT::Crypt::Role> class based on the provided
C<Protocol>.

=cut

sub SimpleImplementationCall {
    my $self = shift;
    my %args = (@_);
    my $protocol = delete $args{'Protocol'} || $self->UseForOutgoing;

    my $method = (caller(1))[3];
    $method =~ s/.*:://;

    my %res = $self->LoadImplementation( $protocol )->$method( %args );
    $res{'Protocol'} = $protocol if keys %res;
    return %res;
}

=head2 FindProtectedParts Entity => MIME::Entity

Looks for encrypted or signed parts of the given C<Entity>, using all
L</EnabledOnIncoming> encryption protocols.  For each node in the MIME
hierarchy, L<RT::Crypt::Role/CheckIfProtected> for that L<MIME::Entity>
is called on each L</EnabledOnIncoming> protocol.  Any multipart nodes
not claimed by those protocols are recursed into.

Finally, L<RT::Crypt::Role/FindScatteredParts> is called on the top-most
entity for each L</EnabledOnIncoming> protocol.

Returns a list of hash references; each hash reference is guaranteed to
contain a C<Protocol> key describing the protocol of the found part, and
a C<Type> which is either C<encrypted> or C<signed>.  The remaining keys
are protocol-dependent; the hashref will be provided to
L</VerifyDecrypt>.

=cut

sub FindProtectedParts {
    my $self = shift;
    my %args = (
        Entity => undef,
        Skip => {},
        Scattered => 1,
        @_
    );

    my $entity = $args{'Entity'};
    return () if $args{'Skip'}{ $entity };

    $args{'TopEntity'} ||= $entity;

    my @protocols = $self->EnabledOnIncoming;

    foreach my $protocol ( @protocols ) {
        my $class = $self->LoadImplementation( $protocol );
        my %info = $class->CheckIfProtected(
            TopEntity => $args{'TopEntity'},
            Entity    => $entity,
        );
        next unless keys %info;

        $args{'Skip'}{ $entity } = 1;
        $info{'Protocol'} = $protocol;
        return \%info;
    }

    if ( $entity->effective_type =~ /^multipart\/(?:signed|encrypted)/ ) {
        # if no module claimed that it supports these types then
        # we don't dive in and check sub-parts
        $args{'Skip'}{ $entity } = 1;
        return ();
    }

    my @res;

    # not protected itself, look inside
    push @res, $self->FindProtectedParts(
        %args, Entity => $_, Scattered => 0,
    ) foreach grep !$args{'Skip'}{$_}, $entity->parts;

    if ( $args{'Scattered'} ) {
        my %parent;
        my $filter; $filter = sub {
            $parent{$_[0]} = $_[1];
            unless ( $_[0]->is_multipart ) {
                return () if $args{'Skip'}{$_[0]};
                return $_[0];
            }
            return map $filter->($_, $_[0]), grep !$args{'Skip'}{$_}, $_[0]->parts;
        };
        my @parts = $filter->($entity);
        return @res unless @parts;

        foreach my $protocol ( @protocols ) {
            my $class = $self->LoadImplementation( $protocol );
            my @list = $class->FindScatteredParts(
                Entity  => $args{'TopEntity'},
                Parts   => \@parts,
                Parents => \%parent,
                Skip    => $args{'Skip'}
            );
            next unless @list;

            $_->{'Protocol'} = $protocol foreach @list;
            push @res, @list;
            @parts = grep !$args{'Skip'}{$_}, @parts;
        }
    }

    return @res;
}

=head2 SignEncrypt Entity => ENTITY, [Sign => 1], [Encrypt => 1],
[Recipients => ARRAYREF], [Signer => NAME], [Protocol => NAME],
[Passphrase => VALUE]

Takes a L<MIME::Entity> object, and signs and/or encrypts it using the
given C<Protocol>.  If not set, C<Recipients> for encryption will be set
by examining the C<To>, C<Cc>, and C<Bcc> headers of the MIME entity.
If not set, C<Signer> defaults to the C<From> of the MIME entity.

C<Passphrase>, if not provided, will be retrieved using
L<RT::Crypt::Role/GetPassphrase>.

Returns a hash with at least the following keys:

=over

=item exit_code

True if there was an error encrypting or signing.

=item message

An un-localized error message desribing the problem.

=back

=cut

sub SignEncrypt {
    my $self = shift;
    my %args = (
        Sign => 1,
        Encrypt => 1,
        @_,
    );

    my $entity = $args{'Entity'};
    if ( $args{'Sign'} && !defined $args{'Signer'} ) {
        $args{'Signer'} =
            $self->UseKeyForSigning
            || do {
                my ($addr) = map {Email::Address->parse( Encode::decode( "UTF-8", $_ ) )}
                    $entity->head->get( 'From' );
                $addr ? $addr->address : undef
            };
    }
    if ( $args{'Encrypt'} && !$args{'Recipients'} ) {
        my %seen;
        $args{'Recipients'} = [
            grep $_ && !$seen{ $_ }++, map $_->address,
            map Email::Address->parse( Encode::decode("UTF-8", $_ ) ),
            map $entity->head->get( $_ ),
            qw(To Cc Bcc)
        ];
    }
    return $self->SimpleImplementationCall( %args );
}

=head2 SignEncryptContent Content => STRINGREF, [Sign => 1], [Encrypt => 1],
[Recipients => ARRAYREF], [Signer => NAME], [Protocol => NAME],
[Passphrase => VALUE]

Signs and/or encrypts a string, which is passed by reference.
C<Recipients> defaults to C</UseKeyForSigning>, and C<Recipients>
defaults to the global L<RT::Config/CorrespondAddress>.  All other
arguments and return values are identical to L</SignEncrypt>.

=cut

sub SignEncryptContent {
    my $self = shift;
    my %args = (@_);

    if ( $args{'Sign'} && !defined $args{'Signer'} ) {
        $args{'Signer'} = $self->UseKeyForSigning;
    }
    if ( $args{'Encrypt'} && !$args{'Recipients'} ) {
        $args{'Recipients'} = [ RT->Config->Get('CorrespondAddress') ];
    }

    return $self->SimpleImplementationCall( %args );
}

=head2 DrySign Signer => KEY

Signs a small message with the key, to make sure the key exists and we
have a useable passphrase. The Signer argument MUST be a key identifier
of the signer: either email address, key id or finger print.

Returns a true value if all went well.

=cut

sub DrySign {
    my $self = shift;

    my $mime = MIME::Entity->build(
        Type    => "text/plain",
        From    => 'nobody@localhost',
        To      => 'nobody@localhost',
        Subject => "dry sign",
        Data    => ['t'],
    );

    my %res = $self->SignEncrypt(
        @_,
        Sign    => 1,
        Encrypt => 0,
        Entity  => $mime,
    );

    return $res{exit_code} == 0;
}

=head2 VerifyDecrypt Entity => ENTITY [, Passphrase => undef ]

Locates all protected parts of the L<MIME::Entity> object C<ENTITY>, as
found by L</FindProtectedParts>, and calls
L<RT::Crypt::Role/VerifyDecrypt> from the appropriate L<RT::Crypt::Role>
class on each.

C<Passphrase>, if not provided, will be retrieved using
L<RT::Crypt::Role/GetPassphrase>.

Returns a list of the hash references returned from
L<RT::Crypt::Role/VerifyDecrypt>.

=cut

sub VerifyDecrypt {
    my $self = shift;
    my %args = (
        Entity    => undef,
        Recursive => 1,
        @_
    );

    my @res;

    my @protected = $self->FindProtectedParts( Entity => $args{'Entity'} );
    foreach my $protected ( @protected ) {
        my %res = $self->SimpleImplementationCall(
            %args, Protocol => $protected->{'Protocol'}, Info => $protected
        );

        # Let the header be modified so continuations are handled
        my $modify = $res{status_on}->head->modify;
        $res{status_on}->head->modify(1);
        $res{status_on}->head->add(
            "X-RT-" . $protected->{'Protocol'} . "-Status" => Encode::encode( "UTF-8", $res{'status'} )
        );
        $res{status_on}->head->modify($modify);

        push @res, \%res;
    }

    push @res, $self->VerifyDecrypt( %args )
        if $args{Recursive} and @res and not grep {$_->{'exit_code'}} @res;

    return @res;
}

=head2 DecryptContent Protocol => NAME, Content => STRINGREF, [Passphrase => undef]

Decrypts the content in the string reference in-place.  All other
arguments and return values are identical to L</VerifyDecrypt>.

=cut

sub DecryptContent {
    return shift->SimpleImplementationCall( @_ );
}

=head2 ParseStatus Protocol => NAME, Status => STRING

Takes a C<String> describing the status of verification/decryption,
usually as stored in a MIME header.  Parses it and returns array of hash
references, one for each operation.  Each hashref contains at least
three keys:

=over

=item Operation

The classification of the process whose status is being reported upon.
Valid values include C<Sign>, C<Encrypt>, C<Decrypt>, C<Verify>,
C<PassphraseCheck>, C<RecipientsCheck> and C<Data>.

=item Status

Whether the operation was successful; contains C<DONE> on success.
Other possible values include C<ERROR>, C<BAD>, or C<MISSING>.

=item Message

An un-localized user friendly message.

=back

=cut

sub ParseStatus {
    my $self = shift;
    my %args = (
        Protocol => undef,
        Status   => '',
        @_
    );
    return $self->LoadImplementation( $args{'Protocol'} )->ParseStatus( $args{'Status'} );
}

=head2 UseKeyForSigning [KEY]

Returns or sets the identifier of the key that should be used for
signing.  Returns the current value when called without arguments; sets
the new value when called with one argument and unsets if it's undef.

This cache is cleared at the end of every request.

=cut

sub UseKeyForSigning {
    my $self = shift;
    state $key;
    if ( @_ ) {
        $key = $_[0];
    }
    return $key;
}

=head2 UseKeyForEncryption [KEY [, VALUE]]

Gets or sets keys to use for encryption.  When passed no arguments,
clears the cache.  When passed just a key, returns the encryption key
previously stored for that key.  When passed two (or more) keys, stores
them associatively.

This cache is reset at the end of every request.

=cut

sub UseKeyForEncryption {
    my $self = shift;
    state %key;
    unless ( @_ ) {
        %key = ();
    } elsif ( @_ > 1 ) {
        %key = (%key, @_);
        $key{ lc($_) } = delete $key{ $_ } foreach grep lc ne $_, keys %key;
    } else {
        return $key{ $_[0] };
    }
    return ();
}

=head2 GetKeysForEncryption Recipient => EMAIL, Protocol => NAME

Returns the list of keys which are suitable for encrypting mail to the
given C<Recipient>.  Generally this is equivalent to L</GetKeysInfo>
with a C<Type> of <private>, but encryption protocols may further limit
which keys can be used for encryption, as opposed to signing.

=cut

sub CheckRecipients {
    my $self = shift;
    my @recipients = (@_);

    my ($status, @issues) = (1, ());

    my $trust = sub { 1 };
    if ( $self->UseForOutgoing eq 'SMIME' ) {
        $trust = sub { $_[0]->{'TrustLevel'} > 0 or RT->Config->Get('SMIME')->{AcceptUntrustedCAs} };
    } elsif ( $self->UseForOutgoing eq 'GnuPG' ) {
        $trust = sub { $_[0]->{'TrustLevel'} > 0 };
    }

    my %seen;
    foreach my $address ( grep !$seen{ lc $_ }++, map $_->address, @recipients ) {
        my %res = $self->GetKeysForEncryption( Recipient => $address );
        if ( $res{'info'} && @{ $res{'info'} } == 1 and $trust->($res{'info'}[0]) ) {
            # One key, which is trusted, or we can sign with an
            # untrusted key (aka SMIME with AcceptUntrustedCAs)
            next;
        }
        my $user = RT::User->new( RT->SystemUser );
        $user->LoadByEmail( $address );
        # it's possible that we have no User record with the email
        $user = undef unless $user->id;

        if ( my $fpr = RT::Crypt->UseKeyForEncryption( $address ) ) {
            if ( $res{'info'} && @{ $res{'info'} } ) {
                next if
                    grep lc $_->{'Fingerprint'} eq lc $fpr,
                    grep $trust->($_),
                    @{ $res{'info'} };
            }

            $status = 0;
            my %issue = (
                EmailAddress => $address,
                $user? (User => $user) : (),
                Keys => undef,
            );
            $issue{'Message'} = "Selected key either is not trusted or doesn't exist anymore."; #loc
            push @issues, \%issue;
            next;
        }

        my $prefered_key;
        $prefered_key = $user->PreferredKey if $user;
        #XXX: prefered key is not yet implemented...

        # classify errors
        $status = 0;
        my %issue = (
            EmailAddress => $address,
            $user? (User => $user) : (),
            Keys => undef,
        );

        unless ( $res{'info'} && @{ $res{'info'} } ) {
            # no key
            $issue{'Message'} = "There is no key suitable for encryption."; #loc
        }
        elsif ( @{ $res{'info'} } == 1 && !$res{'info'}[0]{'TrustLevel'} ) {
            # trust is not set
            $issue{'Message'} = "There is one suitable key, but trust level is not set."; #loc
        }
        else {
            # multiple keys
            $issue{'Message'} = "There are several keys suitable for encryption."; #loc
        }
        push @issues, \%issue;
    }
    return ($status, @issues);
}

sub GetKeysForEncryption {
    my $self = shift;
    my %args = @_%2? (Recipient => @_) : (Protocol => undef, Recipient => undef, @_ );
    return $self->SimpleImplementationCall( %args );
}

=head2 GetKeysForSigning Signer => EMAIL, Protocol => NAME

Returns the list of keys which are suitable for signing mail from the
given C<Signer>.  Generally this is equivalent to L</GetKeysInfo>
with a C<Type> of <private>, but encryption protocols may further limit
which keys can be used for signing, as opposed to encryption.

=cut

sub GetKeysForSigning {
    my $self = shift;
    my %args = @_%2? (Signer => @_) : (Protocol => undef, Signer => undef, @_);
    return $self->SimpleImplementationCall( %args );
}

=head2 GetPublicKeyInfo Protocol => NAME, KEY => EMAIL

As per L</GetKeyInfo>, but the C<Type> is forced to C<public>.

=cut

sub GetPublicKeyInfo {
    return (shift)->GetKeyInfo( @_, Type => 'public' );
}

=head2 GetPrivateKeyInfo Protocol => NAME, KEY => EMAIL

As per L</GetKeyInfo>, but the C<Type> is forced to C<private>.

=cut

sub GetPrivateKeyInfo {
    return (shift)->GetKeyInfo( @_, Type => 'private' );
}

=head2 GetKeyInfo Protocol => NAME, Type => ('public'|'private'), KEY => EMAIL

As per L</GetKeysInfo>, but only the first matching key is returned in
the C<info> value of the result.

=cut

sub GetKeyInfo {
    my $self = shift;
    my %res = $self->GetKeysInfo( @_ );
    $res{'info'} = $res{'info'}->[0];
    return %res;
}

=head2 GetKeysInfo Protocol => NAME, Type => ('public'|'private'), Key => EMAIL

Looks up information about the public or private keys (as determined by
C<Type>) for the email address C<Key>.  As each protocol has its own key
store, C<Protocol> is also required.  If no C<Key> is provided and a
true value for C<Force> is given, returns all keys.

The return value is a hash containing C<exit_code> and C<message> in the
case of failure, or C<info>, which is an array reference of key
information.  Each key is represented as a hash reference; the keys are
protocol-dependent, but will at least contain:

=over

=item Protocol

The name of the protocol of this key

=item Created

An L<RT::Date> of the date the key was created; undef if unset.

=item Expire

An L<RT::Date> of the date the key expires; undef if the key does not expire.

=item Fingerprint

A fingerprint unique to this key

=item Formatted

A formatted string representation of the key

=item User

An array reference of associated user data, each of which is a hashref
containing at least a C<String> value, which is a C<< Alice Example
<alice@example.com> >> style email address.  Each may also contain
C<Created> and C<Expire> keys, which are L<RT::Date> objects.

=back

=cut

sub GetKeysInfo {
    my $self = shift;
    my %args = @_%2 ? (Key => @_) : ( Protocol => undef, Key => undef, @_ );
    return $self->SimpleImplementationCall( %args );
}

1;