Master to 4.2.8
[usit-rt.git] / lib / RT / Crypt / GnuPG.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2014 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
49 use strict;
50 use warnings;
51 use 5.010;
52
53 package RT::Crypt::GnuPG;
54
55 use Role::Basic 'with';
56 with 'RT::Crypt::Role';
57
58 use IO::Handle;
59 use File::Which qw();
60 use RT::Crypt::GnuPG::CRLFHandle;
61 use GnuPG::Interface;
62 use RT::EmailParser ();
63 use RT::Util 'safe_run_child', 'mime_recommended_filename';
64
65 =head1 NAME
66
67 RT::Crypt::GnuPG - GNU Privacy Guard encryption/decryption/verification/signing
68
69 =head1 DESCRIPTION
70
71 This module provides support for encryption and signing of outgoing
72 messages using GnuPG, as well as the decryption and verification of
73 incoming email.
74
75 =head1 CONFIGURATION
76
77 There are two reveant configuration options, both of which are hashes:
78 C<GnuPG> and C<GnuPGOptions>. The first one controls RT specific
79 options; it enables you to enable/disable the GPG protocol or change the
80 format of messages. The second one is a hash with options which are
81 passed to the C<gnupg> utility. You can use it to define a keyserver,
82 enable auto-retrieval of keys, or set almost any option which C<gnupg>
83 supports on your system.
84
85 =head2 %GnuPG
86
87 =head3 Enabling GnuPG
88
89 Set to true value to enable this subsystem:
90
91     Set( %GnuPG,
92         Enable => 1,
93         ... other options ...
94     );
95
96 However, note that you B<must> add the 'Auth::Crypt' email filter to enable
97 the handling of incoming encrypted/signed messages.
98
99 =head3 Format of outgoing messages
100
101 The format of outgoing messages can be controlled using the
102 C<OutgoingMessagesFormat> option in the RT config:
103
104     Set( %GnuPG,
105         ... other options ...
106         OutgoingMessagesFormat => 'RFC',
107         ... other options ...
108     );
109
110 or
111
112     Set( %GnuPG,
113         ... other options ...
114         OutgoingMessagesFormat => 'Inline',
115         ... other options ...
116     );
117
118 The two formats for GPG mail are as follows:
119
120 =over
121
122 =item RFC
123
124 This format, the default, is also known as GPG/MIME, and is described in
125 RFC3156 and RFC1847.  The technique described in these RFCs is well
126 supported by many mail user agents (MUA); however, some older MUAs only
127 support inline signatures and encryption.
128
129 =item Inline
130
131 This format doesn't take advantage of MIME, but some mail clients do not
132 support GPG/MIME.  In general, this format is discouraged because modern
133 mail clients typically do not support it well.
134
135 Text parts are signed using clear-text signatures. For each attachment,
136 the signature is attached separately as a file with a '.sig' extension
137 added to the filename.  Encryption of text parts is implemented using
138 inline format, while other parts are replaced with attachments with the
139 filename extension '.pgp'.
140
141 =back
142
143 =head3 Passphrases
144
145 Passphrases for keys may be set by passing C<Passphrase>.  It may be set
146 to a scalar (to use for all keys), an anonymous function, or a hash (to
147 look up by address).  If the hash is used, the '' key is used as a
148 default.
149
150 =head2 %GnuPGOptions
151
152 Use this hash to set additional options of the 'gnupg' program.  The
153 only options which are diallowed are options which alter the output
154 format or attempt to run commands; thiss includes C<--sign>,
155 C<--list-options>, etc.
156
157 Some GnuPG options take arguments, while others take none. (Such as
158 C<--use-agent>).  For options without specific value use C<undef> as
159 hash value.  To disable these options, you may comment them out or
160 delete them from the hash:
161
162     Set(%GnuPGOptions,
163         'option-with-value' => 'value',
164         'enabled-option-without-value' => undef,
165         # 'commented-option' => 'value or undef',
166     );
167
168 B<NOTE> that options may contain the '-' character and such options
169 B<MUST> be quoted, otherwise you will see the quite cryptic error C<gpg:
170 Invalid option "--0">.
171
172 Common options include:
173
174 =over
175
176 =item --homedir
177
178 The GnuPG home directory where the keyrings are stored; by default it is
179 set to F</opt/rt4/var/data/gpg>.
180
181 You can manage this data with the 'gpg' commandline utility using the
182 GNUPGHOME environment variable or C<--homedir> option.  Other utilities may
183 be used as well.
184
185 In a standard installation, access to this directory should be granted
186 to the web server user which is running RT's web interface; however, if
187 you are running cronjobs or other utilities that access RT directly via
188 API, and may generate encrypted/signed notifications, then the users you
189 execute these scripts under must have access too.
190
191 Be aware that granting access to the directory to many users makes the
192 keys less secure -- and some features, such as auto-import of keys, may
193 not be available if directory permissions are too permissive.  To enable
194 these features and suppress warnings about permissions on the directory,
195 add the C<--no-permission-warning> option to C<GnuPGOptions>.
196
197 =item --digest-algo
198
199 This option is required when the C<RFC> format for outgoing messages is
200 used.  RT defaults to 'SHA1' by default, but you may wish to override
201 it.  C<gnupng --version> will list the algorithms supported by your
202 C<gnupg> installation under 'hash functions'; these generally include
203 MD5, SHA1, RIPEMD160, and SHA256.
204
205 =item --use-agent
206
207 This option lets you use GPG Agent to cache the passphrase of secret
208 keys. See
209 L<http://www.gnupg.org/documentation/manuals/gnupg/Invoking-GPG_002dAGENT.html>
210 for information about GPG Agent.
211
212 =item --passphrase
213
214 This option lets you set the passphrase of RT's key directly. This
215 option is special in that it is not passed directly to GPG; rather, it
216 is put into a file that GPG then reads (which is more secure). The
217 downside is that anyone who has read access to your RT_SiteConfig.pm
218 file can see the passphrase -- thus we recommend the --use-agent option
219 whenever possible.
220
221 =item other
222
223 Read C<man gpg> to get list of all options this program supports.
224
225 =back
226
227 =head2 Per-queue options
228
229 Using the web interface it's possible to enable signing and/or encrypting by
230 default. As an administrative user of RT, open 'Admin' then 'Queues',
231 and select a queue. On the page you can see information about the queue's keys 
232 at the bottom and two checkboxes to choose default actions.
233
234 As well, encryption is enabled for autoreplies and other notifications when
235 an encypted message enters system via mailgate interface even if queue's
236 option is disabled.
237
238 =head2 Handling incoming messages
239
240 To enable handling of encrypted and signed message in the RT you should add
241 'Auth::Crypt' mail plugin.
242
243     Set(@MailPlugins, 'Auth::MailFrom', 'Auth::Crypt', ...other filter...);
244
245 See also `perldoc lib/RT/Interface/Email/Auth/Crypt.pm`.
246
247 =head2 Encrypting to untrusted keys
248
249 Due to limitations of GnuPG, it's impossible to encrypt to an untrusted key,
250 unless 'always trust' mode is enabled.
251
252 =head1 FOR DEVELOPERS
253
254 =head2 Documentation and references
255
256 =over
257
258 =item RFC1847
259
260 Security Multiparts for MIME: Multipart/Signed and Multipart/Encrypted.
261 Describes generic MIME security framework, "mulitpart/signed" and
262 "multipart/encrypted" MIME types.
263
264
265 =item RFC3156
266
267 MIME Security with Pretty Good Privacy (PGP), updates RFC2015.
268
269 =back
270
271 =cut
272
273 # gnupg options supported by GnuPG::Interface
274 # other otions should be handled via extra_args argument
275 my %supported_opt = map { $_ => 1 } qw(
276        always_trust
277        armor
278        batch
279        comment
280        compress_algo
281        default_key
282        encrypt_to
283        extra_args
284        force_v3_sigs
285        homedir
286        logger_fd
287        no_greeting
288        no_options
289        no_verbose
290        openpgp
291        options
292        passphrase_fd
293        quiet
294        recipients
295        rfc1991
296        status_fd
297        textmode
298        verbose
299 );
300
301 our $RE_FILE_EXTENSIONS = qr/pgp|asc/i;
302
303 # DEV WARNING: always pass all STD* handles to GnuPG interface even if we don't
304 # need them, just pass 'IO::Handle->new()' and then close it after safe_run_child.
305 # we don't want to leak anything into FCGI/Apache/MP handles, this break things.
306 # So code should look like:
307 #        my $handles = GnuPG::Handles->new(
308 #            stdin  => ($handle{'stdin'}  = IO::Handle->new()),
309 #            stdout => ($handle{'stdout'} = IO::Handle->new()),
310 #            stderr => ($handle{'stderr'}  = IO::Handle->new()),
311 #            ...
312 #        );
313
314 sub CallGnuPG {
315     my $self = shift;
316     my %args = (
317         Options     => undef,
318         Signer      => undef,
319         Recipients  => [],
320         Passphrase  => undef,
321
322         Command     => undef,
323         CommandArgs => [],
324
325         Content     => undef,
326         Handles     => {},
327         Direct      => undef,
328         Output      => undef,
329         @_
330     );
331
332     my %handle = %{$args{Handles}};
333     my ($handles, $handle_list) = _make_gpg_handles( %handle );
334     $handles->options( $_ )->{'direct'} = 1
335         for @{$args{Direct} || [keys %handle] };
336     %handle = %$handle_list;
337
338     my $content = $args{Content};
339     my $command = $args{Command};
340
341     my %GnuPGOptions = RT->Config->Get('GnuPGOptions');
342     my %opt = (
343         'digest-algo' => 'SHA1',
344         %GnuPGOptions,
345         %{ $args{Options} || {} },
346     );
347     my $gnupg = GnuPG::Interface->new;
348     $gnupg->call( $self->GnuPGPath );
349     $gnupg->options->hash_init(
350         _PrepareGnuPGOptions( %opt ),
351     );
352     $gnupg->options->armor( 1 );
353     $gnupg->options->meta_interactive( 0 );
354     $gnupg->options->default_key( $args{Signer} )
355         if defined $args{Signer};
356
357     my %seen;
358     $gnupg->options->push_recipients( $_ ) for
359         map { RT::Crypt->UseKeyForEncryption($_) || $_ }
360         grep { !$seen{ $_ }++ }
361             @{ $args{Recipients} || [] };
362
363     $args{Passphrase} = $GnuPGOptions{passphrase}
364         unless defined $args{'Passphrase'};
365     $args{Passphrase} = $self->GetPassphrase( Address => $args{Signer} )
366         unless defined $args{'Passphrase'};
367     $gnupg->passphrase( $args{'Passphrase'} )
368         if defined $args{Passphrase};
369
370     eval {
371         local $SIG{'CHLD'} = 'DEFAULT';
372         my $pid = safe_run_child {
373             if ($command =~ /^--/) {
374                 $gnupg->wrap_call(
375                     handles      => $handles,
376                     commands     => [$command],
377                     command_args => $args{CommandArgs},
378                 );
379             } else {
380                 $gnupg->$command(
381                     handles      => $handles,
382                     command_args => $args{CommandArgs},
383                 );
384             }
385         };
386         {
387             local $SIG{'PIPE'} = 'IGNORE';
388             if (Scalar::Util::blessed($content) and $content->can("print")) {
389                 $content->print( $handle{'stdin'} );
390             } elsif (ref($content) eq "SCALAR") {
391                 $handle{'stdin'}->print( ${ $content } );
392             } elsif (defined $content) {
393                 $handle{'stdin'}->print( $content );
394             }
395             close $handle{'stdin'} or die "Can't close gnupg input handle: $!";
396             $args{Callback}->(%handle) if $args{Callback};
397         }
398         waitpid $pid, 0;
399     };
400     my $err = $@;
401     if ($args{Output}) {
402         push @{$args{Output}}, readline $handle{stdout};
403         if (not close $handle{stdout}) {
404             $err ||= "Can't close gnupg output handle: $!";
405         }
406     }
407
408     my %res;
409     $res{'exit_code'} = $?;
410
411     foreach ( qw(stderr logger status) ) {
412         $res{$_} = do { local $/ = undef; readline $handle{$_} };
413         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
414         if (not close $handle{$_}) {
415             $err ||= "Can't close gnupg $_ handle: $!";
416         }
417     }
418     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
419     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
420     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
421     if ( $err || $res{'exit_code'} ) {
422         $res{'message'} = $err? $err : "gpg exited with error code ". ($res{'exit_code'} >> 8);
423     }
424
425     return %res;
426 }
427
428 sub SignEncrypt {
429     my $self = shift;
430
431     my $format = lc RT->Config->Get('GnuPG')->{'OutgoingMessagesFormat'} || 'RFC';
432     if ( $format eq 'inline' ) {
433         return $self->SignEncryptInline( @_ );
434     } else {
435         return $self->SignEncryptRFC3156( @_ );
436     }
437 }
438
439 sub SignEncryptRFC3156 {
440     my $self = shift;
441     my %args = (
442         Entity => undef,
443
444         Sign => 1,
445         Signer => undef,
446         Passphrase => undef,
447
448         Encrypt => 1,
449         Recipients => undef,
450
451         @_
452     );
453
454     my $entity = $args{'Entity'};
455     my %res;
456     if ( $args{'Sign'} && !$args{'Encrypt'} ) {
457         # required by RFC3156(Ch. 5) and RFC1847(Ch. 2.1)
458         foreach ( grep !$_->is_multipart, $entity->parts_DFS ) {
459             my $tenc = $_->head->mime_encoding;
460             unless ( $tenc =~ m/^(?:7bit|quoted-printable|base64)$/i ) {
461                 $_->head->mime_attr( 'Content-Transfer-Encoding'
462                     => $_->effective_type =~ m{^text/}? 'quoted-printable': 'base64'
463                 );
464             }
465         }
466         $entity->make_multipart( 'mixed', Force => 1 );
467
468         my @signature;
469         # We use RT::Crypt::GnuPG::CRLFHandle to canonicalize the
470         # MIME::Entity output to use \r\n instead of \n for its newlines
471         %res = $self->CallGnuPG(
472             Signer     => $args{'Signer'},
473             Command    => "detach_sign",
474             Handles    => { stdin => RT::Crypt::GnuPG::CRLFHandle->new },
475             Direct     => [],
476             Passphrase => $args{'Passphrase'},
477             Content    => $entity->parts(0),
478             Output     => \@signature,
479         );
480         return %res if $res{message};
481
482         # setup RFC1847(Ch.2.1) requirements
483         my $protocol = 'application/pgp-signature';
484         my $algo = RT->Config->Get('GnuPGOptions')->{'digest-algo'} || 'SHA1';
485         $entity->head->mime_attr( 'Content-Type' => 'multipart/signed' );
486         $entity->head->mime_attr( 'Content-Type.protocol' => $protocol );
487         $entity->head->mime_attr( 'Content-Type.micalg'   => 'pgp-'. lc $algo );
488         $entity->attach(
489             Type        => $protocol,
490             Disposition => 'inline',
491             Data        => \@signature,
492             Encoding    => '7bit',
493         );
494     }
495     if ( $args{'Encrypt'} ) {
496         my @recipients = map $_->address,
497             map Email::Address->parse( Encode::decode( "UTF-8", $_ ) ),
498             map $entity->head->get( $_ ),
499             qw(To Cc Bcc);
500
501         my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
502         binmode $tmp_fh, ':raw';
503
504         $entity->make_multipart( 'mixed', Force => 1 );
505         %res = $self->CallGnuPG(
506             Signer     => $args{'Signer'},
507             Recipients => \@recipients,
508             Command    => ( $args{'Sign'} ? "sign_and_encrypt" : "encrypt" ),
509             Handles    => { stdout => $tmp_fh },
510             Passphrase => $args{'Passphrase'},
511             Content    => $entity->parts(0),
512         );
513         return %res if $res{message};
514
515         my $protocol = 'application/pgp-encrypted';
516         $entity->parts([]);
517         $entity->head->mime_attr( 'Content-Type' => 'multipart/encrypted' );
518         $entity->head->mime_attr( 'Content-Type.protocol' => $protocol );
519         $entity->attach(
520             Type        => $protocol,
521             Disposition => 'inline',
522             Data        => ['Version: 1',''],
523             Encoding    => '7bit',
524         );
525         $entity->attach(
526             Type        => 'application/octet-stream',
527             Disposition => 'inline',
528             Path        => $tmp_fn,
529             Filename    => '',
530             Encoding    => '7bit',
531         );
532         $entity->parts(-1)->bodyhandle->{'_dirty_hack_to_save_a_ref_tmp_fh'} = $tmp_fh;
533     }
534     return %res;
535 }
536
537 sub SignEncryptInline {
538     my $self = shift;
539     my %args = ( @_ );
540
541     my $entity = $args{'Entity'};
542
543     my %res;
544     $entity->make_singlepart;
545     if ( $entity->is_multipart ) {
546         foreach ( $entity->parts ) {
547             %res = $self->SignEncryptInline( @_, Entity => $_ );
548             return %res if $res{'exit_code'};
549         }
550         return %res;
551     }
552
553     return $self->_SignEncryptTextInline( @_ )
554         if $entity->effective_type =~ /^text\//i;
555
556     return $self->_SignEncryptAttachmentInline( @_ );
557 }
558
559 sub _SignEncryptTextInline {
560     my $self = shift;
561     my %args = (
562         Entity => undef,
563
564         Sign => 1,
565         Signer => undef,
566         Passphrase => undef,
567
568         Encrypt => 1,
569         Recipients => undef,
570
571         @_
572     );
573     return unless $args{'Sign'} || $args{'Encrypt'};
574
575     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
576     binmode $tmp_fh, ':raw';
577
578     my $entity = $args{'Entity'};
579     my %res = $self->CallGnuPG(
580         Signer     => $args{'Signer'},
581         Recipients => $args{'Recipients'},
582         Command    => ( $args{'Sign'} && $args{'Encrypt'}
583                       ? 'sign_and_encrypt'
584                       : ( $args{'Sign'}
585                         ? 'clearsign'
586                         : 'encrypt' ) ),
587         Handles    => { stdout => $tmp_fh },
588         Passphrase => $args{'Passphrase'},
589         Content    => $entity->bodyhandle,
590     );
591     return %res if $res{message};
592
593     $entity->bodyhandle( MIME::Body::File->new( $tmp_fn) );
594     $entity->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
595
596     return %res;
597 }
598
599 sub _SignEncryptAttachmentInline {
600     my $self = shift;
601     my %args = (
602         Entity => undef,
603
604         Sign => 1,
605         Signer => undef,
606         Passphrase => undef,
607
608         Encrypt => 1,
609         Recipients => undef,
610
611         @_
612     );
613     return unless $args{'Sign'} || $args{'Encrypt'};
614
615
616     my $entity = $args{'Entity'};
617
618     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
619     binmode $tmp_fh, ':raw';
620
621     my %res = $self->CallGnuPG(
622         Signer     => $args{'Signer'},
623         Recipients => $args{'Recipients'},
624         Command    => ( $args{'Sign'} && $args{'Encrypt'}
625                       ? 'sign_and_encrypt'
626                       : ( $args{'Sign'}
627                         ? 'detach_sign'
628                         : 'encrypt' ) ),
629         Handles    => { stdout => $tmp_fh },
630         Passphrase => $args{'Passphrase'},
631         Content    => $entity->bodyhandle,
632     );
633     return %res if $res{message};
634
635     my $filename = mime_recommended_filename( $entity ) || 'no_name';
636     if ( $args{'Sign'} && !$args{'Encrypt'} ) {
637         $entity->make_multipart;
638         $entity->attach(
639             Type     => 'application/octet-stream',
640             Path     => $tmp_fn,
641             Filename => "$filename.sig",
642             Disposition => 'attachment',
643         );
644     } else {
645         $entity->bodyhandle(MIME::Body::File->new( $tmp_fn) );
646         $entity->effective_type('application/octet-stream');
647         $entity->head->mime_attr( $_ => "$filename.pgp" )
648             foreach (qw(Content-Type.name Content-Disposition.filename));
649
650     }
651     $entity->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
652
653     return %res;
654 }
655
656 sub SignEncryptContent {
657     my $self = shift;
658     my %args = (
659         Content => undef,
660
661         Sign => 1,
662         Signer => undef,
663         Passphrase => undef,
664
665         Encrypt => 1,
666         Recipients => undef,
667
668         @_
669     );
670     return unless $args{'Sign'} || $args{'Encrypt'};
671
672     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
673     binmode $tmp_fh, ':raw';
674
675     my %res = $self->CallGnuPG(
676         Signer     => $args{'Signer'},
677         Recipients => $args{'Recipients'},
678         Command    => ( $args{'Sign'} && $args{'Encrypt'}
679                       ? 'sign_and_encrypt'
680                       : ( $args{'Sign'}
681                         ? 'clearsign'
682                         : 'encrypt' ) ),
683         Handles    => { stdout => $tmp_fh },
684         Passphrase => $args{'Passphrase'},
685         Content    => $args{'Content'},
686     );
687     return %res if $res{message};
688
689     ${ $args{'Content'} } = '';
690     seek $tmp_fh, 0, 0;
691     while (1) {
692         my $status = read $tmp_fh, my $buf, 4*1024;
693         unless ( defined $status ) {
694             $RT::Logger->crit( "couldn't read message: $!" );
695         } elsif ( !$status ) {
696             last;
697         }
698         ${ $args{'Content'} } .= $buf;
699     }
700
701     return %res;
702 }
703
704 sub CheckIfProtected {
705     my $self = shift;
706     my %args = ( Entity => undef, @_ );
707
708     my $entity = $args{'Entity'};
709
710     # we check inline PGP block later in another sub
711     return () unless $entity->is_multipart;
712
713     # RFC3156, multipart/{signed,encrypted}
714     my $type = $entity->effective_type;
715     return () unless $type =~ /^multipart\/(?:encrypted|signed)$/;
716
717     unless ( $entity->parts == 2 ) {
718         $RT::Logger->error( "Encrypted or signed entity must has two subparts. Skipped" );
719         return ();
720     }
721
722     my $protocol = $entity->head->mime_attr( 'Content-Type.protocol' );
723     unless ( $protocol ) {
724         # if protocol is not set then we can check second part for PGP message
725         $RT::Logger->error( "Entity is '$type', but has no protocol defined. Checking for PGP part" );
726         my $protected = $self->_CheckIfProtectedInline( $entity->parts(1), 1 );
727         return () unless $protected;
728
729         if ( $protected eq 'signature' ) {
730             $RT::Logger->debug("Found part signed according to RFC3156");
731             return (
732                 Type      => 'signed',
733                 Format    => 'RFC3156',
734                 Top       => $entity,
735                 Data      => $entity->parts(0),
736                 Signature => $entity->parts(1),
737             );
738         } else {
739             $RT::Logger->debug("Found part encrypted according to RFC3156");
740             return (
741                 Type   => 'encrypted',
742                 Format => 'RFC3156',
743                 Top    => $entity,
744                 Data   => $entity->parts(1),
745                 Info   => $entity->parts(0),
746             );
747         }
748     }
749     elsif ( $type eq 'multipart/encrypted' ) {
750         unless ( $protocol eq 'application/pgp-encrypted' ) {
751             $RT::Logger->info( "Skipping protocol '$protocol', only 'application/pgp-encrypted' is supported" );
752             return ();
753         }
754         $RT::Logger->debug("Found part encrypted according to RFC3156");
755         return (
756             Type   => 'encrypted',
757             Format => 'RFC3156',
758             Top    => $entity,
759             Data   => $entity->parts(1),
760             Info   => $entity->parts(0),
761         );
762     } else {
763         unless ( $protocol eq 'application/pgp-signature' ) {
764             $RT::Logger->info( "Skipping protocol '$protocol', only 'application/pgp-signature' is supported" );
765             return ();
766         }
767         $RT::Logger->debug("Found part signed according to RFC3156");
768         return (
769             Type      => 'signed',
770             Format    => 'RFC3156',
771             Top       => $entity,
772             Data      => $entity->parts(0),
773             Signature => $entity->parts(1),
774         );
775     }
776     return ();
777 }
778
779
780 sub FindScatteredParts {
781     my $self = shift;
782     my %args = ( Parts => [], Skip => {}, @_ );
783
784     my @res;
785
786     my @parts = @{ $args{'Parts'} };
787
788     # attachments signed with signature in another part
789     {
790         my @file_indices;
791         for (my $i = 0; $i < @parts; $i++ ) {
792             my $part = $parts[ $i ];
793
794             # we can not associate a signature within an attachment
795             # without file names
796             my $fname = $part->head->recommended_filename;
797             next unless $fname;
798
799             my $type = $part->effective_type;
800
801             if ( $type eq 'application/pgp-signature' ) {
802                 push @file_indices, $i;
803             }
804             elsif ( $type eq 'application/octet-stream' && $fname =~ /\.sig$/i ) {
805                 push @file_indices, $i;
806             }
807         }
808
809         foreach my $i ( @file_indices ) {
810             my $sig_part = $parts[ $i ];
811             my $sig_name = $sig_part->head->recommended_filename;
812             my ($file_name) = $sig_name =~ /^(.*?)(?:\.sig)?$/;
813
814             my ($data_part_idx) =
815                 grep $file_name eq ($parts[$_]->head->recommended_filename||''),
816                 grep $sig_part  ne  $parts[$_],
817                     0 .. @parts - 1;
818             unless ( defined $data_part_idx ) {
819                 $RT::Logger->error("Found $sig_name attachment, but didn't find $file_name");
820                 next;
821             }
822
823             my $data_part_in = $parts[ $data_part_idx ];
824
825             $RT::Logger->debug("Found signature (in '$sig_name') of attachment '$file_name'");
826
827             $args{'Skip'}{$data_part_in} = 1;
828             $args{'Skip'}{$sig_part} = 1;
829             push @res, {
830                 Type      => 'signed',
831                 Format    => 'Attachment',
832                 Top       => $args{'Parents'}{$sig_part},
833                 Data      => $data_part_in,
834                 Signature => $sig_part,
835             };
836         }
837     }
838
839     # attachments with inline encryption
840     foreach my $part ( @parts ) {
841         next if $args{'Skip'}{$part};
842
843         my $fname = $part->head->recommended_filename || '';
844         next unless $fname =~ /\.${RE_FILE_EXTENSIONS}$/;
845
846         $RT::Logger->debug("Found encrypted attachment '$fname'");
847
848         $args{'Skip'}{$part} = 1;
849         push @res, {
850             Type    => 'encrypted',
851             Format  => 'Attachment',
852             Data    => $part,
853         };
854     }
855
856     # inline PGP block
857     foreach my $part ( @parts ) {
858         next if $args{'Skip'}{$part};
859
860         my $type = $self->_CheckIfProtectedInline( $part );
861         next unless $type;
862
863         my $file = ($part->head->recommended_filename||'') =~ /\.${RE_FILE_EXTENSIONS}$/;
864
865         $args{'Skip'}{$part} = 1;
866         push @res, {
867             Type      => $type,
868             Format    => !$file || $type eq 'signed'? 'Inline' : 'Attachment',
869             Data      => $part,
870         };
871     }
872
873     return @res;
874 }
875
876 sub _CheckIfProtectedInline {
877     my $self = shift;
878     my $entity = shift;
879     my $check_for_signature = shift || 0;
880
881     my $io = $entity->open('r');
882     unless ( $io ) {
883         $RT::Logger->warning( "Entity of type ". $entity->effective_type ." has no body" );
884         return '';
885     }
886
887     # Deal with "partitioned" PGP mail, which (contrary to common
888     # sense) unnecessarily applies a base64 transfer encoding to PGP
889     # mail (whose content is already base64-encoded).
890     if ( $entity->bodyhandle->is_encoded and $entity->head->mime_encoding ) {
891         my $decoder = MIME::Decoder->new( $entity->head->mime_encoding );
892         if ($decoder) {
893             local $@;
894             eval {
895                 my $buf = '';
896                 open my $fh, '>', \$buf
897                     or die "Couldn't open scalar for writing: $!";
898                 binmode $fh, ":raw";
899                 $decoder->decode($io, $fh);
900                 close $fh or die "Couldn't close scalar: $!";
901
902                 open $fh, '<', \$buf
903                     or die "Couldn't re-open scalar for reading: $!";
904                 binmode $fh, ":raw";
905                 $io = $fh;
906                 1;
907             } or do {
908                 $RT::Logger->error("Couldn't decode body: $@");
909             }
910         }
911     }
912
913     while ( defined($_ = $io->getline) ) {
914         if ( /^-----BEGIN PGP (SIGNED )?MESSAGE-----/ ) {
915             return $1? 'signed': 'encrypted';
916         }
917         elsif ( $check_for_signature && !/^-----BEGIN PGP SIGNATURE-----/ ) {
918             return 'signature';
919         }
920     }
921     $io->close;
922     return '';
923 }
924
925 sub VerifyDecrypt {
926     my $self = shift;
927     my %args = (
928         Info      => undef,
929         @_
930     );
931
932     my %res;
933
934     my $item = $args{'Info'};
935     my $status_on;
936     if ( $item->{'Type'} eq 'signed' ) {
937         if ( $item->{'Format'} eq 'RFC3156' ) {
938             %res = $self->VerifyRFC3156( %$item );
939             $status_on = $item->{'Top'};
940         } elsif ( $item->{'Format'} eq 'Inline' ) {
941             %res = $self->VerifyInline( %$item );
942             $status_on = $item->{'Data'};
943         } elsif ( $item->{'Format'} eq 'Attachment' ) {
944             %res = $self->VerifyAttachment( %$item );
945             $status_on = $item->{'Data'};
946         } else {
947             die "Unknown format '".$item->{'Format'} . "' of GnuPG signed part";
948         }
949     } elsif ( $item->{'Type'} eq 'encrypted' ) {
950         if ( $item->{'Format'} eq 'RFC3156' ) {
951             %res = $self->DecryptRFC3156( %$item );
952             $status_on = $item->{'Top'};
953         } elsif ( $item->{'Format'} eq 'Inline' ) {
954             %res = $self->DecryptInline( %$item );
955             $status_on = $item->{'Data'};
956         } elsif ( $item->{'Format'} eq 'Attachment' ) {
957             %res = $self->DecryptAttachment( %$item );
958             $status_on = $item->{'Data'};
959         } else {
960             die "Unknown format '".$item->{'Format'} . "' of GnuPG encrypted part";
961         }
962     } else {
963         die "Unknown type '".$item->{'Type'} . "' of protected item";
964     }
965
966     return (%res, status_on => $status_on);
967 }
968
969 sub VerifyInline { return (shift)->DecryptInline( @_ ) }
970
971 sub VerifyAttachment {
972     my $self = shift;
973     my %args = ( Data => undef, Signature => undef, @_ );
974
975     foreach ( $args{'Data'}, $args{'Signature'} ) {
976         next unless $_->bodyhandle->is_encoded;
977
978         require RT::EmailParser;
979         RT::EmailParser->_DecodeBody($_);
980     }
981
982     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
983     binmode $tmp_fh, ':raw';
984     $args{'Data'}->bodyhandle->print( $tmp_fh );
985     $tmp_fh->flush;
986
987     my %res = $self->CallGnuPG(
988         Command     => "verify",
989         CommandArgs => [ '-', $tmp_fn ],
990         Passphrase  => $args{'Passphrase'},
991         Content     => $args{'Signature'}->bodyhandle,
992     );
993
994     $args{'Top'}->parts( [
995         grep "$_" ne $args{'Signature'}, $args{'Top'}->parts
996     ] );
997     $args{'Top'}->make_singlepart;
998
999     return %res;
1000 }
1001
1002 sub VerifyRFC3156 {
1003     my $self = shift;
1004     my %args = ( Data => undef, Signature => undef, @_ );
1005
1006     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1007     binmode $tmp_fh, ':raw:eol(CRLF?)';
1008     $args{'Data'}->print( $tmp_fh );
1009     $tmp_fh->flush;
1010
1011     my %res = $self->CallGnuPG(
1012         Command     => "verify",
1013         CommandArgs => [ '-', $tmp_fn ],
1014         Passphrase  => $args{'Passphrase'},
1015         Content     => $args{'Signature'}->bodyhandle,
1016     );
1017
1018     $args{'Top'}->parts( [ $args{'Data'} ] );
1019     $args{'Top'}->make_singlepart;
1020
1021     return %res;
1022 }
1023
1024 sub DecryptRFC3156 {
1025     my $self = shift;
1026     my %args = (
1027         Data => undef,
1028         Info => undef,
1029         Top => undef,
1030         Passphrase => undef,
1031         @_
1032     );
1033
1034     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1035         require RT::EmailParser;
1036         RT::EmailParser->_DecodeBody($args{'Data'});
1037     }
1038
1039     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1040     binmode $tmp_fh, ':raw';
1041
1042     my %res = $self->CallGnuPG(
1043         Command     => "decrypt",
1044         Handles     => { stdout => $tmp_fh },
1045         Passphrase  => $args{'Passphrase'},
1046         Content     => $args{'Data'}->bodyhandle,
1047     );
1048
1049     # if the decryption is fine but the signature is bad, then without this
1050     # status check we lose the decrypted text
1051     # XXX: add argument to the function to control this check
1052     delete $res{'message'} if $res{'status'} =~ /DECRYPTION_OKAY/;
1053
1054     return %res if $res{message};
1055
1056     seek $tmp_fh, 0, 0;
1057     my $parser = RT::EmailParser->new();
1058     my $decrypted = $parser->ParseMIMEEntityFromFileHandle( $tmp_fh, 0 );
1059     $decrypted->{'__store_link_to_object_to_avoid_early_cleanup'} = $parser;
1060
1061     $args{'Top'}->parts( [$decrypted] );
1062     $args{'Top'}->make_singlepart;
1063
1064     return %res;
1065 }
1066
1067 sub DecryptInline {
1068     my $self = shift;
1069     my %args = (
1070         Data => undef,
1071         Passphrase => undef,
1072         @_
1073     );
1074
1075     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1076         require RT::EmailParser;
1077         RT::EmailParser->_DecodeBody($args{'Data'});
1078     }
1079
1080     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1081     binmode $tmp_fh, ':raw';
1082
1083     my $io = $args{'Data'}->open('r');
1084     unless ( $io ) {
1085         die "Entity has no body, never should happen";
1086     }
1087
1088     my %res;
1089
1090     my ($had_literal, $in_block) = ('', 0);
1091     my ($block_fh, $block_fn) = File::Temp::tempfile( UNLINK => 1 );
1092     binmode $block_fh, ':raw';
1093
1094     while ( defined(my $str = $io->getline) ) {
1095         if ( $in_block && $str =~ /^-----END PGP (?:MESSAGE|SIGNATURE)-----/ ) {
1096             print $block_fh $str;
1097             $in_block--;
1098             next if $in_block > 0;
1099
1100             seek $block_fh, 0, 0;
1101
1102             my ($res_fh, $res_fn);
1103             ($res_fh, $res_fn, %res) = $self->_DecryptInlineBlock(
1104                 %args,
1105                 BlockHandle => $block_fh,
1106             );
1107             return %res unless $res_fh;
1108
1109             print $tmp_fh "-----BEGIN OF PGP PROTECTED PART-----\n" if $had_literal;
1110             while (my $buf = <$res_fh> ) {
1111                 print $tmp_fh $buf;
1112             }
1113             print $tmp_fh "-----END OF PART-----\n" if $had_literal;
1114
1115             ($block_fh, $block_fn) = File::Temp::tempfile( UNLINK => 1 );
1116             binmode $block_fh, ':raw';
1117             $in_block = 0;
1118         }
1119         elsif ( $str =~ /^-----BEGIN PGP (SIGNED )?MESSAGE-----/ ) {
1120             $in_block++;
1121             print $block_fh $str;
1122         }
1123         elsif ( $in_block ) {
1124             print $block_fh $str;
1125         }
1126         else {
1127             print $tmp_fh $str;
1128             $had_literal = 1 if /\S/s;
1129         }
1130     }
1131     $io->close;
1132
1133     if ( $in_block ) {
1134         # we're still in a block, this not bad not good. let's try to
1135         # decrypt what we have, it can be just missing -----END PGP...
1136         seek $block_fh, 0, 0;
1137
1138         my ($res_fh, $res_fn);
1139         ($res_fh, $res_fn, %res) = $self->_DecryptInlineBlock(
1140             %args,
1141             BlockHandle => $block_fh,
1142         );
1143         return %res unless $res_fh;
1144
1145         print $tmp_fh "-----BEGIN OF PGP PROTECTED PART-----\n" if $had_literal;
1146         while (my $buf = <$res_fh> ) {
1147             print $tmp_fh $buf;
1148         }
1149         print $tmp_fh "-----END OF PART-----\n" if $had_literal;
1150     }
1151
1152     seek $tmp_fh, 0, 0;
1153     $args{'Data'}->bodyhandle(MIME::Body::File->new( $tmp_fn ));
1154     $args{'Data'}->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
1155     return %res;
1156 }
1157
1158 sub _DecryptInlineBlock {
1159     my $self = shift;
1160     my %args = (
1161         BlockHandle => undef,
1162         Passphrase => undef,
1163         @_
1164     );
1165
1166     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1167     binmode $tmp_fh, ':raw';
1168
1169     my %res = $self->CallGnuPG(
1170         Command     => "decrypt",
1171         Handles     => { stdout => $tmp_fh, stdin => $args{'BlockHandle'} },
1172         Passphrase  => $args{'Passphrase'},
1173     );
1174
1175     # if the decryption is fine but the signature is bad, then without this
1176     # status check we lose the decrypted text
1177     # XXX: add argument to the function to control this check
1178     delete $res{'message'} if $res{'status'} =~ /DECRYPTION_OKAY/;
1179
1180     return (undef, undef, %res) if $res{message};
1181
1182     seek $tmp_fh, 0, 0;
1183     return ($tmp_fh, $tmp_fn, %res);
1184 }
1185
1186 sub DecryptAttachment {
1187     my $self = shift;
1188     my %args = (
1189         Data => undef,
1190         Passphrase => undef,
1191         @_
1192     );
1193
1194     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1195         require RT::EmailParser;
1196         RT::EmailParser->_DecodeBody($args{'Data'});
1197     }
1198
1199     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1200     binmode $tmp_fh, ':raw';
1201     $args{'Data'}->bodyhandle->print( $tmp_fh );
1202     seek $tmp_fh, 0, 0;
1203
1204     my ($res_fh, $res_fn, %res) = $self->_DecryptInlineBlock(
1205         %args,
1206         BlockHandle => $tmp_fh,
1207     );
1208     return %res unless $res_fh;
1209
1210     $args{'Data'}->bodyhandle(MIME::Body::File->new($res_fn) );
1211     $args{'Data'}->{'__store_tmp_handle_to_avoid_early_cleanup'} = $res_fh;
1212
1213     my $head = $args{'Data'}->head;
1214
1215     # we can not trust original content type
1216     # TODO: and don't have way to detect, so we just use octet-stream
1217     # some clients may send .asc files (encryped) as text/plain
1218     $head->mime_attr( "Content-Type" => 'application/octet-stream' );
1219
1220     my $filename = $head->recommended_filename;
1221     $filename =~ s/\.${RE_FILE_EXTENSIONS}$//i;
1222     $head->mime_attr( $_ => $filename )
1223         foreach (qw(Content-Type.name Content-Disposition.filename));
1224
1225     return %res;
1226 }
1227
1228 sub DecryptContent {
1229     my $self = shift;
1230     my %args = (
1231         Content => undef,
1232         Passphrase => undef,
1233         @_
1234     );
1235
1236     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1237     binmode $tmp_fh, ':raw';
1238
1239     my %res = $self->CallGnuPG(
1240         Command     => "decrypt",
1241         Handles     => { stdout => $tmp_fh },
1242         Passphrase  => $args{'Passphrase'},
1243         Content     => $args{'Content'},
1244     );
1245
1246     # if the decryption is fine but the signature is bad, then without this
1247     # status check we lose the decrypted text
1248     # XXX: add argument to the function to control this check
1249     delete $res{'message'} if $res{'status'} =~ /DECRYPTION_OKAY/;
1250
1251     return %res if $res{'message'};
1252
1253     ${ $args{'Content'} } = '';
1254     seek $tmp_fh, 0, 0;
1255     while (1) {
1256         my $status = read $tmp_fh, my $buf, 4*1024;
1257         unless ( defined $status ) {
1258             $RT::Logger->crit( "couldn't read message: $!" );
1259         } elsif ( !$status ) {
1260             last;
1261         }
1262         ${ $args{'Content'} } .= $buf;
1263     }
1264
1265     return %res;
1266 }
1267
1268 my %REASON_CODE_TO_TEXT = (
1269     NODATA => {
1270         1 => "No armored data",
1271         2 => "Expected a packet, but did not found one",
1272         3 => "Invalid packet found",
1273         4 => "Signature expected, but not found",
1274     },
1275     INV_RECP => {
1276         0 => "No specific reason given",
1277         1 => "Not Found",
1278         2 => "Ambigious specification",
1279         3 => "Wrong key usage",
1280         4 => "Key revoked",
1281         5 => "Key expired",
1282         6 => "No CRL known",
1283         7 => "CRL too old",
1284         8 => "Policy mismatch",
1285         9 => "Not a secret key",
1286         10 => "Key not trusted",
1287     },
1288     ERRSIG => {
1289         0 => 'not specified',
1290         4 => 'unknown algorithm',
1291         9 => 'missing public key',
1292     },
1293 );
1294
1295 sub ReasonCodeToText {
1296     my $keyword = shift;
1297     my $code = shift;
1298     return $REASON_CODE_TO_TEXT{ $keyword }{ $code }
1299         if exists $REASON_CODE_TO_TEXT{ $keyword }{ $code };
1300     return 'unknown';
1301 }
1302
1303 my %simple_keyword = (
1304     NO_RECP => {
1305         Operation => 'RecipientsCheck',
1306         Status    => 'ERROR',
1307         Message   => 'No recipients',
1308     },
1309     UNEXPECTED => {
1310         Operation => 'Data',
1311         Status    => 'ERROR',
1312         Message   => 'Unexpected data has been encountered',
1313     },
1314     BADARMOR => {
1315         Operation => 'Data',
1316         Status    => 'ERROR',
1317         Message   => 'The ASCII armor is corrupted',
1318     },
1319 );
1320
1321 # keywords we parse
1322 my %parse_keyword = map { $_ => 1 } qw(
1323     USERID_HINT
1324     SIG_CREATED GOODSIG BADSIG ERRSIG
1325     END_ENCRYPTION
1326     DECRYPTION_FAILED DECRYPTION_OKAY
1327     BAD_PASSPHRASE GOOD_PASSPHRASE
1328     NO_SECKEY NO_PUBKEY
1329     NO_RECP INV_RECP NODATA UNEXPECTED
1330 );
1331
1332 # keywords we ignore without any messages as we parse them using other
1333 # keywords as starting point or just ignore as they are useless for us
1334 my %ignore_keyword = map { $_ => 1 } qw(
1335     NEED_PASSPHRASE MISSING_PASSPHRASE BEGIN_SIGNING PLAINTEXT PLAINTEXT_LENGTH
1336     BEGIN_ENCRYPTION SIG_ID VALIDSIG
1337     ENC_TO BEGIN_DECRYPTION END_DECRYPTION GOODMDC
1338     TRUST_UNDEFINED TRUST_NEVER TRUST_MARGINAL TRUST_FULLY TRUST_ULTIMATE
1339     DECRYPTION_INFO
1340 );
1341
1342 sub ParseStatus {
1343     my $self = shift;
1344     my $status = shift;
1345     return () unless $status;
1346
1347     my @status;
1348     while ( $status =~ /\[GNUPG:\]\s*(.*?)(?=\[GNUPG:\]|\z)/igms ) {
1349         push @status, $1; $status[-1] =~ s/\s+/ /g; $status[-1] =~ s/\s+$//;
1350     }
1351     $status = join "\n", @status;
1352     study $status;
1353
1354     my @res;
1355     my (%user_hint, $latest_user_main_key);
1356     for ( my $i = 0; $i < @status; $i++ ) {
1357         my $line = $status[$i];
1358         my ($keyword, $args) = ($line =~ /^(\S+)\s*(.*)$/s);
1359         if ( $simple_keyword{ $keyword } ) {
1360             push @res, $simple_keyword{ $keyword };
1361             $res[-1]->{'Keyword'} = $keyword;
1362             next;
1363         }
1364         unless ( $parse_keyword{ $keyword } ) {
1365             $RT::Logger->warning("Skipped $keyword") unless $ignore_keyword{ $keyword };
1366             next;
1367         }
1368
1369         if ( $keyword eq 'USERID_HINT' ) {
1370             my %tmp = _ParseUserHint($status, $line);
1371             $latest_user_main_key = $tmp{'MainKey'};
1372             if ( $user_hint{ $tmp{'MainKey'} } ) {
1373                 while ( my ($k, $v) = each %tmp ) {
1374                     $user_hint{ $tmp{'MainKey'} }->{$k} = $v;
1375                 }
1376             } else {
1377                 $user_hint{ $tmp{'MainKey'} } = \%tmp;
1378             }
1379             next;
1380         }
1381         elsif ( $keyword eq 'BAD_PASSPHRASE' || $keyword eq 'GOOD_PASSPHRASE' ) {
1382             my $key_id = $args;
1383             my %res = (
1384                 Operation => 'PassphraseCheck',
1385                 Status    => $keyword eq 'BAD_PASSPHRASE'? 'BAD' : 'DONE',
1386                 Key       => $key_id,
1387             );
1388             $res{'Status'} = 'MISSING' if $status[ $i - 1 ] =~ /^MISSING_PASSPHRASE/;
1389             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1390                 next unless $line =~ /^NEED_PASSPHRASE\s+(\S+)\s+(\S+)\s+(\S+)/;
1391                 next if $key_id && $2 ne $key_id;
1392                 @res{'MainKey', 'Key', 'KeyType'} = ($1, $2, $3);
1393                 last;
1394             }
1395             $res{'Message'} = ucfirst( lc( $res{'Status'} eq 'DONE'? 'GOOD': $res{'Status'} ) ) .' passphrase';
1396             $res{'User'} = ( $user_hint{ $res{'MainKey'} } ||= {} ) if $res{'MainKey'};
1397             if ( exists $res{'User'}->{'EmailAddress'} ) {
1398                 $res{'Message'} .= ' for '. $res{'User'}->{'EmailAddress'};
1399             } else {
1400                 $res{'Message'} .= " for '0x$key_id'";
1401             }
1402             push @res, \%res;
1403         }
1404         elsif ( $keyword eq 'END_ENCRYPTION' ) {
1405             my %res = (
1406                 Operation => 'Encrypt',
1407                 Status    => 'DONE',
1408                 Message   => 'Data has been encrypted',
1409             );
1410             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1411                 next unless $line =~ /^BEGIN_ENCRYPTION\s+(\S+)\s+(\S+)/;
1412                 @res{'MdcMethod', 'SymAlgo'} = ($1, $2);
1413                 last;
1414             }
1415             push @res, \%res;
1416         }
1417         elsif ( $keyword eq 'DECRYPTION_FAILED' || $keyword eq 'DECRYPTION_OKAY' ) {
1418             my %res = ( Operation => 'Decrypt' );
1419             @res{'Status', 'Message'} = 
1420                 $keyword eq 'DECRYPTION_FAILED'
1421                 ? ('ERROR', 'Decryption failed')
1422                 : ('DONE',  'Decryption process succeeded');
1423
1424             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1425                 next unless $line =~ /^ENC_TO\s+(\S+)\s+(\S+)\s+(\S+)/;
1426                 my ($key, $alg, $key_length) = ($1, $2, $3);
1427
1428                 my %encrypted_to = (
1429                     Message   => "The message is encrypted to '0x$key'",
1430                     User      => ( $user_hint{ $key } ||= {} ),
1431                     Key       => $key,
1432                     KeyLength => $key_length,
1433                     Algorithm => $alg,
1434                 );
1435
1436                 push @{ $res{'EncryptedTo'} ||= [] }, \%encrypted_to;
1437             }
1438
1439             push @res, \%res;
1440         }
1441         elsif ( $keyword eq 'NO_SECKEY' || $keyword eq 'NO_PUBKEY' ) {
1442             my ($key) = split /\s+/, $args;
1443             my $type = $keyword eq 'NO_SECKEY'? 'secret': 'public';
1444             my %res = (
1445                 Operation => 'KeyCheck',
1446                 Status    => 'MISSING',
1447                 Message   => ucfirst( $type ) ." key '0x$key' is not available",
1448                 Key       => $key,
1449                 KeyType   => $type,
1450             );
1451             $res{'User'} = ( $user_hint{ $key } ||= {} );
1452             $res{'User'}{ ucfirst( $type ). 'KeyMissing' } = 1;
1453             push @res, \%res;
1454         }
1455         # GOODSIG, BADSIG, VALIDSIG, TRUST_*
1456         elsif ( $keyword eq 'GOODSIG' ) {
1457             my %res = (
1458                 Operation  => 'Verify',
1459                 Status     => 'DONE',
1460                 Message    => 'The signature is good',
1461             );
1462             @res{qw(Key UserString)} = split /\s+/, $args, 2;
1463             $res{'Message'} .= ', signed by '. $res{'UserString'};
1464
1465             foreach my $line ( @status[ $i .. $#status ] ) {
1466                 next unless $line =~ /^TRUST_(\S+)/;
1467                 $res{'Trust'} = $1;
1468                 last;
1469             }
1470             $res{'Message'} .= ', trust level is '. lc( $res{'Trust'} || 'unknown');
1471
1472             foreach my $line ( @status[ $i .. $#status ] ) {
1473                 next unless $line =~ /^VALIDSIG\s+(.*)/;
1474                 @res{ qw(
1475                     Fingerprint
1476                     CreationDate
1477                     Timestamp
1478                     ExpireTimestamp
1479                     Version
1480                     Reserved
1481                     PubkeyAlgo
1482                     HashAlgo
1483                     Class
1484                     PKFingerprint
1485                     Other
1486                 ) } = split /\s+/, $1, 10;
1487                 last;
1488             }
1489             push @res, \%res;
1490         }
1491         elsif ( $keyword eq 'BADSIG' ) {
1492             my %res = (
1493                 Operation  => 'Verify',
1494                 Status     => 'BAD',
1495                 Message    => 'The signature has not been verified okay',
1496             );
1497             @res{qw(Key UserString)} = split /\s+/, $args, 2;
1498             push @res, \%res;
1499         }
1500         elsif ( $keyword eq 'ERRSIG' ) {
1501             my %res = (
1502                 Operation => 'Verify',
1503                 Status    => 'ERROR',
1504                 Message   => 'Not possible to check the signature',
1505             );
1506             @res{qw(Key PubkeyAlgo HashAlgo Class Timestamp ReasonCode Other)}
1507                 = split /\s+/, $args, 7;
1508
1509             $res{'Reason'} = ReasonCodeToText( $keyword, $res{'ReasonCode'} );
1510             $res{'Message'} .= ", the reason is ". $res{'Reason'};
1511
1512             push @res, \%res;
1513         }
1514         elsif ( $keyword eq 'SIG_CREATED' ) {
1515             # SIG_CREATED <type> <pubkey algo> <hash algo> <class> <timestamp> <key fpr>
1516             my @props = split /\s+/, $args;
1517             push @res, {
1518                 Operation      => 'Sign',
1519                 Status         => 'DONE',
1520                 Message        => "Signed message",
1521                 Type           => $props[0],
1522                 PubKeyAlgo     => $props[1],
1523                 HashKeyAlgo    => $props[2],
1524                 Class          => $props[3],
1525                 Timestamp      => $props[4],
1526                 KeyFingerprint => $props[5],
1527                 User           => $user_hint{ $latest_user_main_key },
1528             };
1529             $res[-1]->{Message} .= ' by '. $user_hint{ $latest_user_main_key }->{'EmailAddress'}
1530                 if $user_hint{ $latest_user_main_key };
1531         }
1532         elsif ( $keyword eq 'INV_RECP' ) {
1533             my ($rcode, $recipient) = split /\s+/, $args, 2;
1534             my $reason = ReasonCodeToText( $keyword, $rcode );
1535             push @res, {
1536                 Operation  => 'RecipientsCheck',
1537                 Status     => 'ERROR',
1538                 Message    => "Recipient '$recipient' is unusable, the reason is '$reason'",
1539                 Recipient  => $recipient,
1540                 ReasonCode => $rcode,
1541                 Reason     => $reason,
1542             };
1543         }
1544         elsif ( $keyword eq 'NODATA' ) {
1545             my $rcode = (split /\s+/, $args)[0];
1546             my $reason = ReasonCodeToText( $keyword, $rcode );
1547             push @res, {
1548                 Operation  => 'Data',
1549                 Status     => 'ERROR',
1550                 Message    => "No data has been found. The reason is '$reason'",
1551                 ReasonCode => $rcode,
1552                 Reason     => $reason,
1553             };
1554         }
1555         else {
1556             $RT::Logger->warning("Keyword $keyword is unknown");
1557             next;
1558         }
1559         $res[-1]{'Keyword'} = $keyword if @res && !$res[-1]{'Keyword'};
1560     }
1561     return @res;
1562 }
1563
1564 sub _ParseUserHint {
1565     my ($status, $hint) = (@_);
1566     my ($main_key_id, $user_str) = ($hint =~ /^USERID_HINT\s+(\S+)\s+(.*)$/);
1567     return () unless $main_key_id;
1568     return (
1569         MainKey      => $main_key_id,
1570         String       => $user_str,
1571         EmailAddress => (map $_->address, Email::Address->parse( $user_str ))[0],
1572     );
1573 }
1574
1575 sub _PrepareGnuPGOptions {
1576     my %opt = @_;
1577     my %res = map { lc $_ => $opt{ $_ } } grep $supported_opt{ lc $_ }, keys %opt;
1578     $res{'extra_args'} ||= [];
1579     foreach my $o ( grep !$supported_opt{ lc $_ }, keys %opt ) {
1580         push @{ $res{'extra_args'} }, '--'. lc $o;
1581         push @{ $res{'extra_args'} }, $opt{ $o }
1582             if defined $opt{ $o };
1583     }
1584     return %res;
1585 }
1586
1587 sub GetKeysForEncryption {
1588     my $self = shift;
1589     my %args = (Recipient => undef, @_);
1590     my %res = $self->GetKeysInfo( Key => delete $args{'Recipient'}, %args, Type => 'public' );
1591     return %res if $res{'exit_code'};
1592     return %res unless $res{'info'};
1593
1594     foreach my $key ( splice @{ $res{'info'} } ) {
1595         # skip disabled keys
1596         next if $key->{'Capabilities'} =~ /D/;
1597         # skip keys not suitable for encryption
1598         next unless $key->{'Capabilities'} =~ /e/i;
1599         # skip disabled, expired, revoked and keys with no trust,
1600         # but leave keys with unknown trust level
1601         next if $key->{'TrustLevel'} < 0;
1602
1603         push @{ $res{'info'} }, $key;
1604     }
1605     delete $res{'info'} unless @{ $res{'info'} };
1606     return %res;
1607 }
1608
1609 sub GetKeysForSigning {
1610     my $self = shift;
1611     my %args = (Signer => undef, @_);
1612     return $self->GetKeysInfo( Key => delete $args{'Signer'}, %args, Type => 'private' );
1613 }
1614
1615 sub GetKeysInfo {
1616     my $self = shift;
1617     my %args = (
1618         Key   => undef,
1619         Type  => 'public',
1620         Force => 0,
1621         @_
1622     );
1623
1624     my $email = $args{'Key'};
1625     my $type = $args{'Type'};
1626     unless ( $email ) {
1627         return (exit_code => 0) unless $args{'Force'};
1628     }
1629
1630     my @info;
1631     my $method = $type eq 'private'? 'list_secret_keys': 'list_public_keys';
1632     my %res = $self->CallGnuPG(
1633         Options     => {
1634             'with-colons'     => undef, # parseable format
1635             'fingerprint'     => undef, # show fingerprint
1636             'fixed-list-mode' => undef, # don't merge uid with keys
1637         },
1638         Command     => $method,
1639         ( $email ? (CommandArgs => ['--', $email]) : () ),
1640         Output      => \@info,
1641     );
1642
1643     # Asking for a non-existent key is not an error
1644     if ($res{message} and $res{logger} =~ /(secret key not available|public key not found)/) {
1645         delete $res{exit_code};
1646         delete $res{message};
1647     }
1648
1649     return %res if $res{'message'};
1650
1651     @info = $self->ParseKeysInfo( @info );
1652     $res{'info'} = \@info;
1653     return %res;
1654 }
1655
1656 sub ParseKeysInfo {
1657     my $self = shift;
1658     my @lines = @_;
1659
1660     my %gpg_opt = RT->Config->Get('GnuPGOptions');
1661
1662     my @res = ();
1663     foreach my $line( @lines ) {
1664         chomp $line;
1665         my $tag;
1666         ($tag, $line) = split /:/, $line, 2;
1667         if ( $tag eq 'pub' ) {
1668             my %info;
1669             @info{ qw(
1670                 TrustChar KeyLength Algorithm Key
1671                 Created Expire Empty OwnerTrustChar
1672                 Empty Empty Capabilities Other
1673             ) } = split /:/, $line, 12;
1674
1675             # workaround gnupg's wierd behaviour, --list-keys command report calculated trust levels
1676             # for any model except 'always', so you can change models and see changes, but not for 'always'
1677             # we try to handle it in a simple way - we set ultimate trust for any key with trust
1678             # level >= 0 if trust model is 'always'
1679             my $always_trust;
1680             $always_trust = 1 if exists $gpg_opt{'always-trust'};
1681             $always_trust = 1 if exists $gpg_opt{'trust-model'} && $gpg_opt{'trust-model'} eq 'always';
1682             @info{qw(Trust TrustTerse TrustLevel)} = 
1683                 _ConvertTrustChar( $info{'TrustChar'} );
1684             if ( $always_trust && $info{'TrustLevel'} >= 0 ) {
1685                 @info{qw(Trust TrustTerse TrustLevel)} = 
1686                     _ConvertTrustChar( 'u' );
1687             }
1688
1689             @info{qw(OwnerTrust OwnerTrustTerse OwnerTrustLevel)} = 
1690                 _ConvertTrustChar( $info{'OwnerTrustChar'} );
1691             $info{ $_ } = $self->ParseDate( $info{ $_ } )
1692                 foreach qw(Created Expire);
1693             push @res, \%info;
1694         }
1695         elsif ( $tag eq 'sec' ) {
1696             my %info;
1697             @info{ qw(
1698                 Empty KeyLength Algorithm Key
1699                 Created Expire Empty OwnerTrustChar
1700                 Empty Empty Capabilities Other
1701             ) } = split /:/, $line, 12;
1702             @info{qw(OwnerTrust OwnerTrustTerse OwnerTrustLevel)} = 
1703                 _ConvertTrustChar( $info{'OwnerTrustChar'} );
1704             $info{ $_ } = $self->ParseDate( $info{ $_ } )
1705                 foreach qw(Created Expire);
1706             push @res, \%info;
1707         }
1708         elsif ( $tag eq 'uid' ) {
1709             my %info;
1710             @info{ qw(Trust Created Expire String) }
1711                 = (split /:/, $line)[0,4,5,8];
1712             $info{ $_ } = $self->ParseDate( $info{ $_ } )
1713                 foreach qw(Created Expire);
1714             push @{ $res[-1]{'User'} ||= [] }, \%info;
1715         }
1716         elsif ( $tag eq 'fpr' ) {
1717             $res[-1]{'Fingerprint'} = (split /:/, $line, 10)[8];
1718         }
1719     }
1720     return @res;
1721 }
1722
1723 {
1724     my %verbose = (
1725         # deprecated
1726         d   => [
1727             "The key has been disabled", #loc
1728             "key disabled", #loc
1729             "-2"
1730         ],
1731
1732         r   => [
1733             "The key has been revoked", #loc
1734             "key revoked", #loc
1735             -3,
1736         ],
1737
1738         e   => [ "The key has expired", #loc
1739             "key expired", #loc
1740             '-4',
1741         ],
1742
1743         n   => [ "Don't trust this key at all", #loc
1744             'none', #loc
1745             -1,
1746         ],
1747
1748         #gpupg docs says that '-' and 'q' may safely be treated as the same value
1749         '-' => [
1750             'Unknown (no trust value assigned)', #loc
1751             'not set',
1752             0,
1753         ],
1754         q   => [
1755             'Unknown (no trust value assigned)', #loc
1756             'not set',
1757             0,
1758         ],
1759         o   => [
1760             'Unknown (this value is new to the system)', #loc
1761             'unknown',
1762             0,
1763         ],
1764
1765         m   => [
1766             "There is marginal trust in this key", #loc
1767             'marginal', #loc
1768             1,
1769         ],
1770         f   => [
1771             "The key is fully trusted", #loc
1772             'full', #loc
1773             2,
1774         ],
1775         u   => [
1776             "The key is ultimately trusted", #loc
1777             'ultimate', #loc
1778             3,
1779         ],
1780     );
1781
1782     sub _ConvertTrustChar {
1783         my $value = shift;
1784         return @{ $verbose{'-'} } unless $value;
1785         $value = substr $value, 0, 1;
1786         return @{ $verbose{ $value } || $verbose{'o'} };
1787     }
1788 }
1789
1790 sub DeleteKey {
1791     my $self = shift;
1792     my $key = shift;
1793
1794     return $self->CallGnuPG(
1795         Command     => "--delete-secret-and-public-key",
1796         CommandArgs => ["--", $key],
1797         Callback    => sub {
1798             my %handle = @_;
1799             while ( my $str = readline $handle{'status'} ) {
1800                 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL delete_key\..*/ ) {
1801                     print { $handle{'command'} } "y\n";
1802                 }
1803             }
1804         },
1805     );
1806 }
1807
1808 sub ImportKey {
1809     my $self = shift;
1810     my $key = shift;
1811
1812     return $self->CallGnuPG(
1813         Command     => "import_keys",
1814         Content     => $key,
1815     );
1816 }
1817
1818 sub GnuPGPath {
1819     state $cache = RT->Config->Get('GnuPG')->{'GnuPG'};
1820     $cache = $_[1] if @_ > 1;
1821     return $cache;
1822 }
1823
1824 sub Probe {
1825     my $self = shift;
1826     my $gnupg = GnuPG::Interface->new;
1827
1828     my $bin = $self->GnuPGPath();
1829     unless ($bin) {
1830         $RT::Logger->warning(
1831             "No gpg path set; GnuPG support has been disabled.  ".
1832             "Check the 'GnuPG' configuration in %GnuPG");
1833         return 0;
1834     }
1835
1836     if ($bin =~ m{^/}) {
1837         unless (-f $bin and -x _) {
1838             $RT::Logger->warning(
1839                 "Invalid gpg path $bin; GnuPG support has been disabled.  ".
1840                 "Check the 'GnuPG' configuration in %GnuPG");
1841             return 0;
1842         }
1843     } else {
1844         local $ENV{PATH} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin'
1845             unless defined $ENV{PATH};
1846         my $path = File::Which::which( $bin );
1847         unless ($path) {
1848             $RT::Logger->warning(
1849                 "Can't find gpg binary '$bin' in PATH ($ENV{PATH}); GnuPG support has been disabled.  ".
1850                 "You may need to specify a full path to gpg via the 'GnuPG' configuration in %GnuPG");
1851             return 0;
1852         }
1853         $self->GnuPGPath( $bin = $path );
1854     }
1855
1856     $gnupg->call( $bin );
1857     $gnupg->options->hash_init(
1858         _PrepareGnuPGOptions( RT->Config->Get('GnuPGOptions') )
1859     );
1860     $gnupg->options->meta_interactive( 0 );
1861
1862     my ($handles, $handle_list) = _make_gpg_handles();
1863     my %handle = %$handle_list;
1864
1865     local $@ = undef;
1866     eval {
1867         local $SIG{'CHLD'} = 'DEFAULT';
1868         my $pid = safe_run_child {
1869             $gnupg->wrap_call(
1870                 commands => ['--version' ],
1871                 handles  => $handles
1872             )
1873         };
1874         close $handle{'stdin'} or die "Can't close gnupg input handle: $!";
1875         waitpid $pid, 0;
1876     };
1877     if ( $@ ) {
1878         $RT::Logger->warning(
1879             "RT's GnuPG libraries couldn't successfully execute gpg.".
1880                 " GnuPG support has been disabled");
1881         $RT::Logger->debug(
1882             "Probe for GPG failed."
1883             ." Couldn't run `gpg --version`: ". $@
1884         );
1885         return 0;
1886     }
1887
1888 # on some systems gpg exits with code 2, but still 100% functional,
1889 # it's general error system error or incorrect command, command is correct,
1890 # but there is no way to get actuall error
1891     if ( $? && ($? >> 8) != 2 ) {
1892         my $msg = "Probe for GPG failed."
1893             ." Process exited with code ". ($? >> 8)
1894             . ($? & 127 ? (" as recieved signal ". ($? & 127)) : '')
1895             . ".";
1896         foreach ( qw(stderr logger status) ) {
1897             my $tmp = do { local $/ = undef; readline $handle{$_} };
1898             next unless $tmp && $tmp =~ /\S/s;
1899             close $handle{$_} or $tmp .= "\nFailed to close: $!";
1900             $msg .= "\n$_:\n$tmp\n";
1901         }
1902         $RT::Logger->warning(
1903             "RT's GnuPG libraries couldn't successfully execute gpg.".
1904                 " GnuPG support has been disabled");
1905         $RT::Logger->debug( $msg );
1906         return 0;
1907     }
1908     return 1;
1909 }
1910
1911
1912 sub _make_gpg_handles {
1913     my %handle_map = (@_);
1914     $handle_map{$_} = IO::Handle->new
1915         foreach grep !defined $handle_map{$_}, 
1916         qw(stdin stdout stderr logger status command);
1917
1918     my $handles = GnuPG::Handles->new(%handle_map);
1919     return ($handles, \%handle_map);
1920 }
1921
1922 RT::Base->_ImportOverlays();
1923
1924 1;