1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2015 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
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
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.
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.
30 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
47 # END BPS TAGGED BLOCK }}}
57 RT::Crypt - encrypt/decrypt and sign/verify subsystem for RT
61 This module provides support for encryption and signing of outgoing
62 messages, as well as the decryption and verification of incoming emails
63 using various encryption standards. Currently, L<GnuPG|RT::Crypt::GnuPG>
64 and L<SMIME|RT::Crypt::SMIME> protocols are supported.
68 You can control the configuration of this subsystem from RT's configuration file.
69 Some options are available via the web interface, but to enable this functionality,
70 you MUST start in the configuration file.
72 For each protocol there is a hash with the same name in the configuration file.
73 This hash controls RT-specific options regarding the protocol. It allows you to
74 enable/disable each facility or change the format of messages; for example, GnuPG
75 uses the following config:
82 C<Enable> is the only key that is generic for all protocols. A protocol may have
83 additional options to fine-tune behaviour.
85 However, note that you B<must> add the
86 L<Auth::Crypt|RT::Interface::Email::Auth::Crypt> email filter to enable
87 the handling of incoming encrypted/signed messages. It should be added
88 in addition to the standard
89 L<Auth::MailFrom|RT::Interface::Email::Auth::Crypt> plugin.
93 This config option hash chooses which protocols are decrypted and
94 verified in incoming messages, which protocol is used for outgoing
95 emails, and RT's behaviour on errors during decrypting and verification.
97 RT will provide sane defaults for all of these options. By default, all
98 enabled encryption protocols are decrypted on incoming mail; if you wish
99 to limit this to a subset, you may, via:
103 Incoming => ['SMIME'],
107 RT can currently only use one protocol to encrypt and sign outgoing
108 email; this defaults to the first enabled protocol. You many specify it
117 You can allow users to encrypt data in the database by setting the
118 C<AllowEncryptDataInDB> key to a true value; by default, this is
119 disabled. Be aware that users must have rights to see and modify
120 tickets to use this feature.
122 =head2 Per-queue options
124 Using the web interface, it is possible to enable signing and/or
125 encrypting by default. As an administrative user of RT, navigate to the
126 'Admin' and 'Queues' menus, and select a queue. If at least one
127 encryption protocol is enabled, information concerning available keys
128 will be displayed, as well as options to enable signing and encryption.
130 =head2 Handling incoming messages
132 To enable handling of encrypted and signed message in the RT you must
133 enable the L<RT::Interface::Email::Auth::Crypt> mail plugin:
135 Set(@MailPlugins, 'Auth::MailFrom', 'Auth::Crypt', ...other filter...);
137 =head2 Error handling
139 There are several global templates created in the database by
140 default. RT uses these templates to send error messages to users or RT's
141 owner. These templates have an 'Error:' or 'Error to RT owner:' prefix
142 in the name. You can adjust the text of the messages using the web
145 Note that while C<$TicketObj>, C<$TransactionObj> and other variables
146 usually available in RT's templates are not available in these
147 templates, but each is passed alternate data structures can be used to
148 build better messages; see the default templates and descriptions below.
150 You can disable any particular notification by simply deleting the
151 content of a template. Deleting the templates entirely is not
152 suggested, as RT will log error messages when attempting to send mail
155 =head3 Problems with public keys
157 The 'Error: public key' template is used to inform the user that RT had
158 problems with their public key, and thus will not be able to send
159 encrypted content. There are several reasons why RT might fail to use a
160 key; by default, the actual reason is not sent to the user, but sent to
161 the RT owner using the 'Error to RT owner: public key' template.
163 Possible reasons include "Not Found", "Ambiguous specification", "Wrong
164 key usage", "Key revoked", "Key expired", "No CRL known", "CRL too old",
165 "Policy mismatch", "Not a secret key", "Key not trusted" or "No specific
168 In the 'Error: public key' template there are a few additional variables
173 =item $Message - user friendly error message
175 =item $Reason - short reason as listed above
177 =item $Recipient - recipient's identification
179 =item $AddressObj - L<Email::Address> object containing recipient's email address
183 As a message may have several invalid recipients, to avoid sending many
184 emails to the RT owner, the system sends one message to the owner,
185 grouped by recipient. In the 'Error to RT owner: public key' template a
186 C<@BadRecipients> array is available where each element is a hash
187 reference that describes one recipient using the same fields as
191 { Message => '...', Reason => '...', Recipient => '...', ...},
192 { Message => '...', Reason => '...', Recipient => '...', ...},
196 =head3 Private key doesn't exist
198 The 'Error: no private key' template is used to inform the user that
199 they sent an encrypted email to RT, but RT does not have the private key
202 In this template L<MIME::Entity> object C<$Message> is available, which
203 is the originally received message.
207 The 'Error: bad encrypted data' template is used to inform the user that
208 a message they sent had invalid data, and could not be handled. There
209 are several possible reasons for this error, but most of them are data
210 corruption or absence of expected information.
212 In this template, the C<@Messages> array is available, and will contain
213 a list of error messages.
219 Returns the complete set of encryption protocols that RT implements; not
220 all may be supported by this installation.
224 our @PROTOCOLS = ('GnuPG', 'SMIME');
225 our %PROTOCOLS = map { lc $_ => $_ } @PROTOCOLS;
231 =head2 EnabledProtocols
233 Returns the set of enabled and available encryption protocols.
237 sub EnabledProtocols {
239 return grep RT->Config->Get($_)->{'Enable'}, $self->Protocols;
242 =head2 UseForOutgoing
244 Returns the configured outgoing encryption protocol; see
250 return RT->Config->Get('Crypt')->{'Outgoing'};
253 =head2 EnabledOnIncoming
255 Returns the list of encryption protocols that should be used for
256 decryption and verification of incoming email; see L<RT_Config/Crypt>.
257 This list is irrelevant unless L<RT::Interface::Email::Auth::Crypt> is
258 enabled in L<RT_Config/@MailPlugins>.
262 sub EnabledOnIncoming {
263 return @{ scalar RT->Config->Get('Crypt')->{'Incoming'} };
266 =head2 LoadImplementation CLASS
268 Given the name of an encryption implementation (e.g. "GnuPG"), loads the
269 L<RT::Crypt> class associated with it; return the classname on success,
270 and undef on failure.
274 sub LoadImplementation {
276 my $proto = $PROTOCOLS{ lc $_[1] } or die "Unknown protocol '$_[1]'";
277 my $class = 'RT::Crypt::'. $proto;
278 return $cache{ $class } if exists $cache{ $class };
280 if ($class->require) {
281 return $cache{ $class } = $class;
283 RT->Logger->warn( "Could not load $class: $@" );
284 return $cache{ $class } = undef;
288 =head2 SimpleImplementationCall Protocol => NAME, [...]
290 Examines the caller of this method, and dispatches to the method of the
291 same name on the correct L<RT::Crypt::Role> class based on the provided
296 sub SimpleImplementationCall {
299 my $protocol = delete $args{'Protocol'} || $self->UseForOutgoing;
301 my $method = (caller(1))[3];
304 my %res = $self->LoadImplementation( $protocol )->$method( %args );
305 $res{'Protocol'} = $protocol if keys %res;
309 =head2 FindProtectedParts Entity => MIME::Entity
311 Looks for encrypted or signed parts of the given C<Entity>, using all
312 L</EnabledOnIncoming> encryption protocols. For each node in the MIME
313 hierarchy, L<RT::Crypt::Role/CheckIfProtected> for that L<MIME::Entity>
314 is called on each L</EnabledOnIncoming> protocol. Any multipart nodes
315 not claimed by those protocols are recursed into.
317 Finally, L<RT::Crypt::Role/FindScatteredParts> is called on the top-most
318 entity for each L</EnabledOnIncoming> protocol.
320 Returns a list of hash references; each hash reference is guaranteed to
321 contain a C<Protocol> key describing the protocol of the found part, and
322 a C<Type> which is either C<encrypted> or C<signed>. The remaining keys
323 are protocol-dependent; the hashref will be provided to
328 sub FindProtectedParts {
337 my $entity = $args{'Entity'};
338 return () if $args{'Skip'}{ $entity };
340 $args{'TopEntity'} ||= $entity;
342 my @protocols = $self->EnabledOnIncoming;
344 foreach my $protocol ( @protocols ) {
345 my $class = $self->LoadImplementation( $protocol );
346 my %info = $class->CheckIfProtected(
347 TopEntity => $args{'TopEntity'},
350 next unless keys %info;
352 $args{'Skip'}{ $entity } = 1;
353 $info{'Protocol'} = $protocol;
357 if ( $entity->effective_type =~ /^multipart\/(?:signed|encrypted)/ ) {
358 # if no module claimed that it supports these types then
359 # we don't dive in and check sub-parts
360 $args{'Skip'}{ $entity } = 1;
366 # not protected itself, look inside
367 push @res, $self->FindProtectedParts(
368 %args, Entity => $_, Scattered => 0,
369 ) foreach grep !$args{'Skip'}{$_}, $entity->parts;
371 if ( $args{'Scattered'} ) {
373 my $filter; $filter = sub {
374 $parent{$_[0]} = $_[1];
375 unless ( $_[0]->is_multipart ) {
376 return () if $args{'Skip'}{$_[0]};
379 return map $filter->($_, $_[0]), grep !$args{'Skip'}{$_}, $_[0]->parts;
381 my @parts = $filter->($entity);
382 return @res unless @parts;
384 foreach my $protocol ( @protocols ) {
385 my $class = $self->LoadImplementation( $protocol );
386 my @list = $class->FindScatteredParts(
387 Entity => $args{'TopEntity'},
390 Skip => $args{'Skip'}
394 $_->{'Protocol'} = $protocol foreach @list;
396 @parts = grep !$args{'Skip'}{$_}, @parts;
403 =head2 SignEncrypt Entity => ENTITY, [Sign => 1], [Encrypt => 1],
404 [Recipients => ARRAYREF], [Signer => NAME], [Protocol => NAME],
405 [Passphrase => VALUE]
407 Takes a L<MIME::Entity> object, and signs and/or encrypts it using the
408 given C<Protocol>. If not set, C<Recipients> for encryption will be set
409 by examining the C<To>, C<Cc>, and C<Bcc> headers of the MIME entity.
410 If not set, C<Signer> defaults to the C<From> of the MIME entity.
412 C<Passphrase>, if not provided, will be retrieved using
413 L<RT::Crypt::Role/GetPassphrase>.
415 Returns a hash with at least the following keys:
421 True if there was an error encrypting or signing.
425 An un-localized error message desribing the problem.
435 my $entity = $args{'Entity'};
436 if ( $args{'Sign'} && !defined $args{'Signer'} ) {
438 $self->UseKeyForSigning
440 my ($addr) = map {Email::Address->parse( Encode::decode( "UTF-8", $_ ) )}
441 $entity->head->get( 'From' );
442 $addr ? $addr->address : undef
445 if ( $args{'Encrypt'} && !$args{'Recipients'} ) {
447 $args{'Recipients'} = [
448 grep $_ && !$seen{ $_ }++, map $_->address,
449 map Email::Address->parse( Encode::decode("UTF-8", $_ ) ),
450 map $entity->head->get( $_ ),
454 return $self->SimpleImplementationCall( %args );
457 =head2 SignEncryptContent Content => STRINGREF, [Sign => 1], [Encrypt => 1],
458 [Recipients => ARRAYREF], [Signer => NAME], [Protocol => NAME],
459 [Passphrase => VALUE]
461 Signs and/or encrypts a string, which is passed by reference.
462 C<Recipients> defaults to C</UseKeyForSigning>, and C<Recipients>
463 defaults to the global L<RT::Config/CorrespondAddress>. All other
464 arguments and return values are identical to L</SignEncrypt>.
468 sub SignEncryptContent {
472 if ( $args{'Sign'} && !defined $args{'Signer'} ) {
473 $args{'Signer'} = $self->UseKeyForSigning;
475 if ( $args{'Encrypt'} && !$args{'Recipients'} ) {
476 $args{'Recipients'} = [ RT->Config->Get('CorrespondAddress') ];
479 return $self->SimpleImplementationCall( %args );
482 =head2 DrySign Signer => KEY
484 Signs a small message with the key, to make sure the key exists and we
485 have a useable passphrase. The Signer argument MUST be a key identifier
486 of the signer: either email address, key id or finger print.
488 Returns a true value if all went well.
495 my $mime = MIME::Entity->build(
496 Type => "text/plain",
497 From => 'nobody@localhost',
498 To => 'nobody@localhost',
499 Subject => "dry sign",
503 my %res = $self->SignEncrypt(
510 return $res{exit_code} == 0;
513 =head2 VerifyDecrypt Entity => ENTITY [, Passphrase => undef ]
515 Locates all protected parts of the L<MIME::Entity> object C<ENTITY>, as
516 found by L</FindProtectedParts>, and calls
517 L<RT::Crypt::Role/VerifyDecrypt> from the appropriate L<RT::Crypt::Role>
520 C<Passphrase>, if not provided, will be retrieved using
521 L<RT::Crypt::Role/GetPassphrase>.
523 Returns a list of the hash references returned from
524 L<RT::Crypt::Role/VerifyDecrypt>.
538 my @protected = $self->FindProtectedParts( Entity => $args{'Entity'} );
539 foreach my $protected ( @protected ) {
540 my %res = $self->SimpleImplementationCall(
541 %args, Protocol => $protected->{'Protocol'}, Info => $protected
544 # Let the header be modified so continuations are handled
545 my $modify = $res{status_on}->head->modify;
546 $res{status_on}->head->modify(1);
547 $res{status_on}->head->add(
548 "X-RT-" . $protected->{'Protocol'} . "-Status" => $res{'status'}
550 $res{status_on}->head->modify($modify);
555 push @res, $self->VerifyDecrypt( %args )
556 if $args{Recursive} and @res and not grep {$_->{'exit_code'}} @res;
561 =head2 DecryptContent Protocol => NAME, Content => STRINGREF, [Passphrase => undef]
563 Decrypts the content in the string reference in-place. All other
564 arguments and return values are identical to L</VerifyDecrypt>.
569 return shift->SimpleImplementationCall( @_ );
572 =head2 ParseStatus Protocol => NAME, Status => STRING
574 Takes a C<String> describing the status of verification/decryption,
575 usually as stored in a MIME header. Parses it and returns array of hash
576 references, one for each operation. Each hashref contains at least
583 The classification of the process whose status is being reported upon.
584 Valid values include C<Sign>, C<Encrypt>, C<Decrypt>, C<Verify>,
585 C<PassphraseCheck>, C<RecipientsCheck> and C<Data>.
589 Whether the operation was successful; contains C<DONE> on success.
590 Other possible values include C<ERROR>, C<BAD>, or C<MISSING>.
594 An un-localized user friendly message.
607 return $self->LoadImplementation( $args{'Protocol'} )->ParseStatus( $args{'Status'} );
610 =head2 UseKeyForSigning [KEY]
612 Returns or sets the identifier of the key that should be used for
613 signing. Returns the current value when called without arguments; sets
614 the new value when called with one argument and unsets if it's undef.
616 This cache is cleared at the end of every request.
620 sub UseKeyForSigning {
629 =head2 UseKeyForEncryption [KEY [, VALUE]]
631 Gets or sets keys to use for encryption. When passed no arguments,
632 clears the cache. When passed just a key, returns the encryption key
633 previously stored for that key. When passed two (or more) keys, stores
636 This cache is reset at the end of every request.
640 sub UseKeyForEncryption {
647 $key{ lc($_) } = delete $key{ $_ } foreach grep lc ne $_, keys %key;
649 return $key{ $_[0] };
654 =head2 GetKeysForEncryption Recipient => EMAIL, Protocol => NAME
656 Returns the list of keys which are suitable for encrypting mail to the
657 given C<Recipient>. Generally this is equivalent to L</GetKeysInfo>
658 with a C<Type> of <private>, but encryption protocols may further limit
659 which keys can be used for encryption, as opposed to signing.
663 sub CheckRecipients {
665 my @recipients = (@_);
667 my ($status, @issues) = (1, ());
669 my $trust = sub { 1 };
670 if ( $self->UseForOutgoing eq 'SMIME' ) {
671 $trust = sub { $_[0]->{'TrustLevel'} > 0 or RT->Config->Get('SMIME')->{AcceptUntrustedCAs} };
672 } elsif ( $self->UseForOutgoing eq 'GnuPG' ) {
673 $trust = sub { $_[0]->{'TrustLevel'} > 0 };
677 foreach my $address ( grep !$seen{ lc $_ }++, map $_->address, @recipients ) {
678 my %res = $self->GetKeysForEncryption( Recipient => $address );
679 if ( $res{'info'} && @{ $res{'info'} } == 1 and $trust->($res{'info'}[0]) ) {
680 # One key, which is trusted, or we can sign with an
681 # untrusted key (aka SMIME with AcceptUntrustedCAs)
684 my $user = RT::User->new( RT->SystemUser );
685 $user->LoadByEmail( $address );
686 # it's possible that we have no User record with the email
687 $user = undef unless $user->id;
689 if ( my $fpr = RT::Crypt->UseKeyForEncryption( $address ) ) {
690 if ( $res{'info'} && @{ $res{'info'} } ) {
692 grep lc $_->{'Fingerprint'} eq lc $fpr,
699 EmailAddress => $address,
700 $user? (User => $user) : (),
703 $issue{'Message'} = "Selected key either is not trusted or doesn't exist anymore."; #loc
704 push @issues, \%issue;
709 $prefered_key = $user->PreferredKey if $user;
710 #XXX: prefered key is not yet implemented...
715 EmailAddress => $address,
716 $user? (User => $user) : (),
720 unless ( $res{'info'} && @{ $res{'info'} } ) {
722 $issue{'Message'} = "There is no key suitable for encryption."; #loc
724 elsif ( @{ $res{'info'} } == 1 && !$res{'info'}[0]{'TrustLevel'} ) {
726 $issue{'Message'} = "There is one suitable key, but trust level is not set."; #loc
730 $issue{'Message'} = "There are several keys suitable for encryption."; #loc
732 push @issues, \%issue;
734 return ($status, @issues);
737 sub GetKeysForEncryption {
739 my %args = @_%2? (Recipient => @_) : (Protocol => undef, Recipient => undef, @_ );
740 return $self->SimpleImplementationCall( %args );
743 =head2 GetKeysForSigning Signer => EMAIL, Protocol => NAME
745 Returns the list of keys which are suitable for signing mail from the
746 given C<Signer>. Generally this is equivalent to L</GetKeysInfo>
747 with a C<Type> of <private>, but encryption protocols may further limit
748 which keys can be used for signing, as opposed to encryption.
752 sub GetKeysForSigning {
754 my %args = @_%2? (Signer => @_) : (Protocol => undef, Signer => undef, @_);
755 return $self->SimpleImplementationCall( %args );
758 =head2 GetPublicKeyInfo Protocol => NAME, KEY => EMAIL
760 As per L</GetKeyInfo>, but the C<Type> is forced to C<public>.
764 sub GetPublicKeyInfo {
765 return (shift)->GetKeyInfo( @_, Type => 'public' );
768 =head2 GetPrivateKeyInfo Protocol => NAME, KEY => EMAIL
770 As per L</GetKeyInfo>, but the C<Type> is forced to C<private>.
774 sub GetPrivateKeyInfo {
775 return (shift)->GetKeyInfo( @_, Type => 'private' );
778 =head2 GetKeyInfo Protocol => NAME, Type => ('public'|'private'), KEY => EMAIL
780 As per L</GetKeysInfo>, but only the first matching key is returned in
781 the C<info> value of the result.
787 my %res = $self->GetKeysInfo( @_ );
788 $res{'info'} = $res{'info'}->[0];
792 =head2 GetKeysInfo Protocol => NAME, Type => ('public'|'private'), Key => EMAIL
794 Looks up information about the public or private keys (as determined by
795 C<Type>) for the email address C<Key>. As each protocol has its own key
796 store, C<Protocol> is also required. If no C<Key> is provided and a
797 true value for C<Force> is given, returns all keys.
799 The return value is a hash containing C<exit_code> and C<message> in the
800 case of failure, or C<info>, which is an array reference of key
801 information. Each key is represented as a hash reference; the keys are
802 protocol-dependent, but will at least contain:
808 The name of the protocol of this key
812 An L<RT::Date> of the date the key was created; undef if unset.
816 An L<RT::Date> of the date the key expires; undef if the key does not expire.
820 A fingerprint unique to this key
824 A formatted string representation of the key
828 An array reference of associated user data, each of which is a hashref
829 containing at least a C<String> value, which is a C<< Alice Example
830 <alice@example.com> >> style email address. Each may also contain
831 C<Created> and C<Expire> keys, which are L<RT::Date> objects.
839 my %args = @_%2 ? (Key => @_) : ( Protocol => undef, Key => undef, @_ );
840 return $self->SimpleImplementationCall( %args );