316d2fa6e7f21839c9ed1820afa5e5fcdb0ef984
[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( $entity->head->get( $_ ) ),
498             qw(To Cc Bcc);
499
500         my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
501         binmode $tmp_fh, ':raw';
502
503         $entity->make_multipart( 'mixed', Force => 1 );
504         %res = $self->CallGnuPG(
505             Signer     => $args{'Signer'},
506             Recipients => \@recipients,
507             Command    => ( $args{'Sign'} ? "sign_and_encrypt" : "encrypt" ),
508             Handles    => { stdout => $tmp_fh },
509             Passphrase => $args{'Passphrase'},
510             Content    => $entity->parts(0),
511         );
512         return %res if $res{message};
513
514         my $protocol = 'application/pgp-encrypted';
515         $entity->parts([]);
516         $entity->head->mime_attr( 'Content-Type' => 'multipart/encrypted' );
517         $entity->head->mime_attr( 'Content-Type.protocol' => $protocol );
518         $entity->attach(
519             Type        => $protocol,
520             Disposition => 'inline',
521             Data        => ['Version: 1',''],
522             Encoding    => '7bit',
523         );
524         $entity->attach(
525             Type        => 'application/octet-stream',
526             Disposition => 'inline',
527             Path        => $tmp_fn,
528             Filename    => '',
529             Encoding    => '7bit',
530         );
531         $entity->parts(-1)->bodyhandle->{'_dirty_hack_to_save_a_ref_tmp_fh'} = $tmp_fh;
532     }
533     return %res;
534 }
535
536 sub SignEncryptInline {
537     my $self = shift;
538     my %args = ( @_ );
539
540     my $entity = $args{'Entity'};
541
542     my %res;
543     $entity->make_singlepart;
544     if ( $entity->is_multipart ) {
545         foreach ( $entity->parts ) {
546             %res = $self->SignEncryptInline( @_, Entity => $_ );
547             return %res if $res{'exit_code'};
548         }
549         return %res;
550     }
551
552     return $self->_SignEncryptTextInline( @_ )
553         if $entity->effective_type =~ /^text\//i;
554
555     return $self->_SignEncryptAttachmentInline( @_ );
556 }
557
558 sub _SignEncryptTextInline {
559     my $self = shift;
560     my %args = (
561         Entity => undef,
562
563         Sign => 1,
564         Signer => undef,
565         Passphrase => undef,
566
567         Encrypt => 1,
568         Recipients => undef,
569
570         @_
571     );
572     return unless $args{'Sign'} || $args{'Encrypt'};
573
574     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
575     binmode $tmp_fh, ':raw';
576
577     my $entity = $args{'Entity'};
578     my %res = $self->CallGnuPG(
579         Signer     => $args{'Signer'},
580         Recipients => $args{'Recipients'},
581         Command    => ( $args{'Sign'} && $args{'Encrypt'}
582                       ? 'sign_and_encrypt'
583                       : ( $args{'Sign'}
584                         ? 'clearsign'
585                         : 'encrypt' ) ),
586         Handles    => { stdout => $tmp_fh },
587         Passphrase => $args{'Passphrase'},
588         Content    => $entity->bodyhandle,
589     );
590     return %res if $res{message};
591
592     $entity->bodyhandle( MIME::Body::File->new( $tmp_fn) );
593     $entity->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
594
595     return %res;
596 }
597
598 sub _SignEncryptAttachmentInline {
599     my $self = shift;
600     my %args = (
601         Entity => undef,
602
603         Sign => 1,
604         Signer => undef,
605         Passphrase => undef,
606
607         Encrypt => 1,
608         Recipients => undef,
609
610         @_
611     );
612     return unless $args{'Sign'} || $args{'Encrypt'};
613
614
615     my $entity = $args{'Entity'};
616
617     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
618     binmode $tmp_fh, ':raw';
619
620     my %res = $self->CallGnuPG(
621         Signer     => $args{'Signer'},
622         Recipients => $args{'Recipients'},
623         Command    => ( $args{'Sign'} && $args{'Encrypt'}
624                       ? 'sign_and_encrypt'
625                       : ( $args{'Sign'}
626                         ? 'detach_sign'
627                         : 'encrypt' ) ),
628         Handles    => { stdout => $tmp_fh },
629         Passphrase => $args{'Passphrase'},
630         Content    => $entity->bodyhandle,
631     );
632     return %res if $res{message};
633
634     my $filename = mime_recommended_filename( $entity ) || 'no_name';
635     if ( $args{'Sign'} && !$args{'Encrypt'} ) {
636         $entity->make_multipart;
637         $entity->attach(
638             Type     => 'application/octet-stream',
639             Path     => $tmp_fn,
640             Filename => "$filename.sig",
641             Disposition => 'attachment',
642         );
643     } else {
644         $entity->bodyhandle(MIME::Body::File->new( $tmp_fn) );
645         $entity->effective_type('application/octet-stream');
646         $entity->head->mime_attr( $_ => "$filename.pgp" )
647             foreach (qw(Content-Type.name Content-Disposition.filename));
648
649     }
650     $entity->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
651
652     return %res;
653 }
654
655 sub SignEncryptContent {
656     my $self = shift;
657     my %args = (
658         Content => undef,
659
660         Sign => 1,
661         Signer => undef,
662         Passphrase => undef,
663
664         Encrypt => 1,
665         Recipients => undef,
666
667         @_
668     );
669     return unless $args{'Sign'} || $args{'Encrypt'};
670
671     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
672     binmode $tmp_fh, ':raw';
673
674     my %res = $self->CallGnuPG(
675         Signer     => $args{'Signer'},
676         Recipients => $args{'Recipients'},
677         Command    => ( $args{'Sign'} && $args{'Encrypt'}
678                       ? 'sign_and_encrypt'
679                       : ( $args{'Sign'}
680                         ? 'clearsign'
681                         : 'encrypt' ) ),
682         Handles    => { stdout => $tmp_fh },
683         Passphrase => $args{'Passphrase'},
684         Content    => $args{'Content'},
685     );
686     return %res if $res{message};
687
688     ${ $args{'Content'} } = '';
689     seek $tmp_fh, 0, 0;
690     while (1) {
691         my $status = read $tmp_fh, my $buf, 4*1024;
692         unless ( defined $status ) {
693             $RT::Logger->crit( "couldn't read message: $!" );
694         } elsif ( !$status ) {
695             last;
696         }
697         ${ $args{'Content'} } .= $buf;
698     }
699
700     return %res;
701 }
702
703 sub CheckIfProtected {
704     my $self = shift;
705     my %args = ( Entity => undef, @_ );
706
707     my $entity = $args{'Entity'};
708
709     # we check inline PGP block later in another sub
710     return () unless $entity->is_multipart;
711
712     # RFC3156, multipart/{signed,encrypted}
713     my $type = $entity->effective_type;
714     return () unless $type =~ /^multipart\/(?:encrypted|signed)$/;
715
716     unless ( $entity->parts == 2 ) {
717         $RT::Logger->error( "Encrypted or signed entity must has two subparts. Skipped" );
718         return ();
719     }
720
721     my $protocol = $entity->head->mime_attr( 'Content-Type.protocol' );
722     unless ( $protocol ) {
723         # if protocol is not set then we can check second part for PGP message
724         $RT::Logger->error( "Entity is '$type', but has no protocol defined. Checking for PGP part" );
725         my $protected = $self->_CheckIfProtectedInline( $entity->parts(1), 1 );
726         return () unless $protected;
727
728         if ( $protected eq 'signature' ) {
729             $RT::Logger->debug("Found part signed according to RFC3156");
730             return (
731                 Type      => 'signed',
732                 Format    => 'RFC3156',
733                 Top       => $entity,
734                 Data      => $entity->parts(0),
735                 Signature => $entity->parts(1),
736             );
737         } else {
738             $RT::Logger->debug("Found part encrypted according to RFC3156");
739             return (
740                 Type   => 'encrypted',
741                 Format => 'RFC3156',
742                 Top    => $entity,
743                 Data   => $entity->parts(1),
744                 Info   => $entity->parts(0),
745             );
746         }
747     }
748     elsif ( $type eq 'multipart/encrypted' ) {
749         unless ( $protocol eq 'application/pgp-encrypted' ) {
750             $RT::Logger->info( "Skipping protocol '$protocol', only 'application/pgp-encrypted' is supported" );
751             return ();
752         }
753         $RT::Logger->debug("Found part encrypted according to RFC3156");
754         return (
755             Type   => 'encrypted',
756             Format => 'RFC3156',
757             Top    => $entity,
758             Data   => $entity->parts(1),
759             Info   => $entity->parts(0),
760         );
761     } else {
762         unless ( $protocol eq 'application/pgp-signature' ) {
763             $RT::Logger->info( "Skipping protocol '$protocol', only 'application/pgp-signature' is supported" );
764             return ();
765         }
766         $RT::Logger->debug("Found part signed according to RFC3156");
767         return (
768             Type      => 'signed',
769             Format    => 'RFC3156',
770             Top       => $entity,
771             Data      => $entity->parts(0),
772             Signature => $entity->parts(1),
773         );
774     }
775     return ();
776 }
777
778
779 sub FindScatteredParts {
780     my $self = shift;
781     my %args = ( Parts => [], Skip => {}, @_ );
782
783     my @res;
784
785     my @parts = @{ $args{'Parts'} };
786
787     # attachments signed with signature in another part
788     {
789         my @file_indices;
790         for (my $i = 0; $i < @parts; $i++ ) {
791             my $part = $parts[ $i ];
792
793             # we can not associate a signature within an attachment
794             # without file names
795             my $fname = $part->head->recommended_filename;
796             next unless $fname;
797
798             my $type = $part->effective_type;
799
800             if ( $type eq 'application/pgp-signature' ) {
801                 push @file_indices, $i;
802             }
803             elsif ( $type eq 'application/octet-stream' && $fname =~ /\.sig$/i ) {
804                 push @file_indices, $i;
805             }
806         }
807
808         foreach my $i ( @file_indices ) {
809             my $sig_part = $parts[ $i ];
810             my $sig_name = $sig_part->head->recommended_filename;
811             my ($file_name) = $sig_name =~ /^(.*?)(?:\.sig)?$/;
812
813             my ($data_part_idx) =
814                 grep $file_name eq ($parts[$_]->head->recommended_filename||''),
815                 grep $sig_part  ne  $parts[$_],
816                     0 .. @parts - 1;
817             unless ( defined $data_part_idx ) {
818                 $RT::Logger->error("Found $sig_name attachment, but didn't find $file_name");
819                 next;
820             }
821
822             my $data_part_in = $parts[ $data_part_idx ];
823
824             $RT::Logger->debug("Found signature (in '$sig_name') of attachment '$file_name'");
825
826             $args{'Skip'}{$data_part_in} = 1;
827             $args{'Skip'}{$sig_part} = 1;
828             push @res, {
829                 Type      => 'signed',
830                 Format    => 'Attachment',
831                 Top       => $args{'Parents'}{$sig_part},
832                 Data      => $data_part_in,
833                 Signature => $sig_part,
834             };
835         }
836     }
837
838     # attachments with inline encryption
839     foreach my $part ( @parts ) {
840         next if $args{'Skip'}{$part};
841
842         my $fname = $part->head->recommended_filename || '';
843         next unless $fname =~ /\.${RE_FILE_EXTENSIONS}$/;
844
845         $RT::Logger->debug("Found encrypted attachment '$fname'");
846
847         $args{'Skip'}{$part} = 1;
848         push @res, {
849             Type    => 'encrypted',
850             Format  => 'Attachment',
851             Data    => $part,
852         };
853     }
854
855     # inline PGP block
856     foreach my $part ( @parts ) {
857         next if $args{'Skip'}{$part};
858
859         my $type = $self->_CheckIfProtectedInline( $part );
860         next unless $type;
861
862         my $file = ($part->head->recommended_filename||'') =~ /\.${RE_FILE_EXTENSIONS}$/;
863
864         $args{'Skip'}{$part} = 1;
865         push @res, {
866             Type      => $type,
867             Format    => !$file || $type eq 'signed'? 'Inline' : 'Attachment',
868             Data      => $part,
869         };
870     }
871
872     return @res;
873 }
874
875 sub _CheckIfProtectedInline {
876     my $self = shift;
877     my $entity = shift;
878     my $check_for_signature = shift || 0;
879
880     my $io = $entity->open('r');
881     unless ( $io ) {
882         $RT::Logger->warning( "Entity of type ". $entity->effective_type ." has no body" );
883         return '';
884     }
885
886     # Deal with "partitioned" PGP mail, which (contrary to common
887     # sense) unnecessarily applies a base64 transfer encoding to PGP
888     # mail (whose content is already base64-encoded).
889     if ( $entity->bodyhandle->is_encoded and $entity->head->mime_encoding ) {
890         my $decoder = MIME::Decoder->new( $entity->head->mime_encoding );
891         if ($decoder) {
892             local $@;
893             eval {
894                 my $buf = '';
895                 open my $fh, '>', \$buf
896                     or die "Couldn't open scalar for writing: $!";
897                 binmode $fh, ":raw";
898                 $decoder->decode($io, $fh);
899                 close $fh or die "Couldn't close scalar: $!";
900
901                 open $fh, '<', \$buf
902                     or die "Couldn't re-open scalar for reading: $!";
903                 binmode $fh, ":raw";
904                 $io = $fh;
905                 1;
906             } or do {
907                 $RT::Logger->error("Couldn't decode body: $@");
908             }
909         }
910     }
911
912     while ( defined($_ = $io->getline) ) {
913         if ( /^-----BEGIN PGP (SIGNED )?MESSAGE-----/ ) {
914             return $1? 'signed': 'encrypted';
915         }
916         elsif ( $check_for_signature && !/^-----BEGIN PGP SIGNATURE-----/ ) {
917             return 'signature';
918         }
919     }
920     $io->close;
921     return '';
922 }
923
924 sub VerifyDecrypt {
925     my $self = shift;
926     my %args = (
927         Info      => undef,
928         @_
929     );
930
931     my %res;
932
933     my $item = $args{'Info'};
934     my $status_on;
935     if ( $item->{'Type'} eq 'signed' ) {
936         if ( $item->{'Format'} eq 'RFC3156' ) {
937             %res = $self->VerifyRFC3156( %$item );
938             $status_on = $item->{'Top'};
939         } elsif ( $item->{'Format'} eq 'Inline' ) {
940             %res = $self->VerifyInline( %$item );
941             $status_on = $item->{'Data'};
942         } elsif ( $item->{'Format'} eq 'Attachment' ) {
943             %res = $self->VerifyAttachment( %$item );
944             $status_on = $item->{'Data'};
945         } else {
946             die "Unknown format '".$item->{'Format'} . "' of GnuPG signed part";
947         }
948     } elsif ( $item->{'Type'} eq 'encrypted' ) {
949         if ( $item->{'Format'} eq 'RFC3156' ) {
950             %res = $self->DecryptRFC3156( %$item );
951             $status_on = $item->{'Top'};
952         } elsif ( $item->{'Format'} eq 'Inline' ) {
953             %res = $self->DecryptInline( %$item );
954             $status_on = $item->{'Data'};
955         } elsif ( $item->{'Format'} eq 'Attachment' ) {
956             %res = $self->DecryptAttachment( %$item );
957             $status_on = $item->{'Data'};
958         } else {
959             die "Unknown format '".$item->{'Format'} . "' of GnuPG encrypted part";
960         }
961     } else {
962         die "Unknown type '".$item->{'Type'} . "' of protected item";
963     }
964
965     return (%res, status_on => $status_on);
966 }
967
968 sub VerifyInline { return (shift)->DecryptInline( @_ ) }
969
970 sub VerifyAttachment {
971     my $self = shift;
972     my %args = ( Data => undef, Signature => undef, @_ );
973
974     foreach ( $args{'Data'}, $args{'Signature'} ) {
975         next unless $_->bodyhandle->is_encoded;
976
977         require RT::EmailParser;
978         RT::EmailParser->_DecodeBody($_);
979     }
980
981     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
982     binmode $tmp_fh, ':raw';
983     $args{'Data'}->bodyhandle->print( $tmp_fh );
984     $tmp_fh->flush;
985
986     my %res = $self->CallGnuPG(
987         Command     => "verify",
988         CommandArgs => [ '-', $tmp_fn ],
989         Passphrase  => $args{'Passphrase'},
990         Content     => $args{'Signature'}->bodyhandle,
991     );
992
993     $args{'Top'}->parts( [
994         grep "$_" ne $args{'Signature'}, $args{'Top'}->parts
995     ] );
996     $args{'Top'}->make_singlepart;
997
998     return %res;
999 }
1000
1001 sub VerifyRFC3156 {
1002     my $self = shift;
1003     my %args = ( Data => undef, Signature => undef, @_ );
1004
1005     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1006     binmode $tmp_fh, ':raw:eol(CRLF?)';
1007     $args{'Data'}->print( $tmp_fh );
1008     $tmp_fh->flush;
1009
1010     my %res = $self->CallGnuPG(
1011         Command     => "verify",
1012         CommandArgs => [ '-', $tmp_fn ],
1013         Passphrase  => $args{'Passphrase'},
1014         Content     => $args{'Signature'}->bodyhandle,
1015     );
1016
1017     $args{'Top'}->parts( [ $args{'Data'} ] );
1018     $args{'Top'}->make_singlepart;
1019
1020     return %res;
1021 }
1022
1023 sub DecryptRFC3156 {
1024     my $self = shift;
1025     my %args = (
1026         Data => undef,
1027         Info => undef,
1028         Top => undef,
1029         Passphrase => undef,
1030         @_
1031     );
1032
1033     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1034         require RT::EmailParser;
1035         RT::EmailParser->_DecodeBody($args{'Data'});
1036     }
1037
1038     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1039     binmode $tmp_fh, ':raw';
1040
1041     my %res = $self->CallGnuPG(
1042         Command     => "decrypt",
1043         Handles     => { stdout => $tmp_fh },
1044         Passphrase  => $args{'Passphrase'},
1045         Content     => $args{'Data'}->bodyhandle,
1046     );
1047
1048     # if the decryption is fine but the signature is bad, then without this
1049     # status check we lose the decrypted text
1050     # XXX: add argument to the function to control this check
1051     delete $res{'message'} if $res{'status'} =~ /DECRYPTION_OKAY/;
1052
1053     return %res if $res{message};
1054
1055     seek $tmp_fh, 0, 0;
1056     my $parser = RT::EmailParser->new();
1057     my $decrypted = $parser->ParseMIMEEntityFromFileHandle( $tmp_fh, 0 );
1058     $decrypted->{'__store_link_to_object_to_avoid_early_cleanup'} = $parser;
1059
1060     $args{'Top'}->parts( [$decrypted] );
1061     $args{'Top'}->make_singlepart;
1062
1063     return %res;
1064 }
1065
1066 sub DecryptInline {
1067     my $self = shift;
1068     my %args = (
1069         Data => undef,
1070         Passphrase => undef,
1071         @_
1072     );
1073
1074     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1075         require RT::EmailParser;
1076         RT::EmailParser->_DecodeBody($args{'Data'});
1077     }
1078
1079     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1080     binmode $tmp_fh, ':raw';
1081
1082     my $io = $args{'Data'}->open('r');
1083     unless ( $io ) {
1084         die "Entity has no body, never should happen";
1085     }
1086
1087     my %res;
1088
1089     my ($had_literal, $in_block) = ('', 0);
1090     my ($block_fh, $block_fn) = File::Temp::tempfile( UNLINK => 1 );
1091     binmode $block_fh, ':raw';
1092
1093     while ( defined(my $str = $io->getline) ) {
1094         if ( $in_block && $str =~ /^-----END PGP (?:MESSAGE|SIGNATURE)-----/ ) {
1095             print $block_fh $str;
1096             $in_block--;
1097             next if $in_block > 0;
1098
1099             seek $block_fh, 0, 0;
1100
1101             my ($res_fh, $res_fn);
1102             ($res_fh, $res_fn, %res) = $self->_DecryptInlineBlock(
1103                 %args,
1104                 BlockHandle => $block_fh,
1105             );
1106             return %res unless $res_fh;
1107
1108             print $tmp_fh "-----BEGIN OF PGP PROTECTED PART-----\n" if $had_literal;
1109             while (my $buf = <$res_fh> ) {
1110                 print $tmp_fh $buf;
1111             }
1112             print $tmp_fh "-----END OF PART-----\n" if $had_literal;
1113
1114             ($block_fh, $block_fn) = File::Temp::tempfile( UNLINK => 1 );
1115             binmode $block_fh, ':raw';
1116             $in_block = 0;
1117         }
1118         elsif ( $str =~ /^-----BEGIN PGP (SIGNED )?MESSAGE-----/ ) {
1119             $in_block++;
1120             print $block_fh $str;
1121         }
1122         elsif ( $in_block ) {
1123             print $block_fh $str;
1124         }
1125         else {
1126             print $tmp_fh $str;
1127             $had_literal = 1 if /\S/s;
1128         }
1129     }
1130     $io->close;
1131
1132     if ( $in_block ) {
1133         # we're still in a block, this not bad not good. let's try to
1134         # decrypt what we have, it can be just missing -----END PGP...
1135         seek $block_fh, 0, 0;
1136
1137         my ($res_fh, $res_fn);
1138         ($res_fh, $res_fn, %res) = $self->_DecryptInlineBlock(
1139             %args,
1140             BlockHandle => $block_fh,
1141         );
1142         return %res unless $res_fh;
1143
1144         print $tmp_fh "-----BEGIN OF PGP PROTECTED PART-----\n" if $had_literal;
1145         while (my $buf = <$res_fh> ) {
1146             print $tmp_fh $buf;
1147         }
1148         print $tmp_fh "-----END OF PART-----\n" if $had_literal;
1149     }
1150
1151     seek $tmp_fh, 0, 0;
1152     $args{'Data'}->bodyhandle(MIME::Body::File->new( $tmp_fn ));
1153     $args{'Data'}->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
1154     return %res;
1155 }
1156
1157 sub _DecryptInlineBlock {
1158     my $self = shift;
1159     my %args = (
1160         BlockHandle => undef,
1161         Passphrase => undef,
1162         @_
1163     );
1164
1165     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1166     binmode $tmp_fh, ':raw';
1167
1168     my %res = $self->CallGnuPG(
1169         Command     => "decrypt",
1170         Handles     => { stdout => $tmp_fh, stdin => $args{'BlockHandle'} },
1171         Passphrase  => $args{'Passphrase'},
1172     );
1173
1174     # if the decryption is fine but the signature is bad, then without this
1175     # status check we lose the decrypted text
1176     # XXX: add argument to the function to control this check
1177     delete $res{'message'} if $res{'status'} =~ /DECRYPTION_OKAY/;
1178
1179     return (undef, undef, %res) if $res{message};
1180
1181     seek $tmp_fh, 0, 0;
1182     return ($tmp_fh, $tmp_fn, %res);
1183 }
1184
1185 sub DecryptAttachment {
1186     my $self = shift;
1187     my %args = (
1188         Data => undef,
1189         Passphrase => undef,
1190         @_
1191     );
1192
1193     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1194         require RT::EmailParser;
1195         RT::EmailParser->_DecodeBody($args{'Data'});
1196     }
1197
1198     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1199     binmode $tmp_fh, ':raw';
1200     $args{'Data'}->bodyhandle->print( $tmp_fh );
1201     seek $tmp_fh, 0, 0;
1202
1203     my ($res_fh, $res_fn, %res) = $self->_DecryptInlineBlock(
1204         %args,
1205         BlockHandle => $tmp_fh,
1206     );
1207     return %res unless $res_fh;
1208
1209     $args{'Data'}->bodyhandle(MIME::Body::File->new($res_fn) );
1210     $args{'Data'}->{'__store_tmp_handle_to_avoid_early_cleanup'} = $res_fh;
1211
1212     my $head = $args{'Data'}->head;
1213
1214     # we can not trust original content type
1215     # TODO: and don't have way to detect, so we just use octet-stream
1216     # some clients may send .asc files (encryped) as text/plain
1217     $head->mime_attr( "Content-Type" => 'application/octet-stream' );
1218
1219     my $filename = $head->recommended_filename;
1220     $filename =~ s/\.${RE_FILE_EXTENSIONS}$//i;
1221     $head->mime_attr( $_ => $filename )
1222         foreach (qw(Content-Type.name Content-Disposition.filename));
1223
1224     return %res;
1225 }
1226
1227 sub DecryptContent {
1228     my $self = shift;
1229     my %args = (
1230         Content => undef,
1231         Passphrase => undef,
1232         @_
1233     );
1234
1235     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1236     binmode $tmp_fh, ':raw';
1237
1238     my %res = $self->CallGnuPG(
1239         Command     => "decrypt",
1240         Handles     => { stdout => $tmp_fh },
1241         Passphrase  => $args{'Passphrase'},
1242         Content     => $args{'Content'},
1243     );
1244
1245     # if the decryption is fine but the signature is bad, then without this
1246     # status check we lose the decrypted text
1247     # XXX: add argument to the function to control this check
1248     delete $res{'message'} if $res{'status'} =~ /DECRYPTION_OKAY/;
1249
1250     return %res if $res{'message'};
1251
1252     ${ $args{'Content'} } = '';
1253     seek $tmp_fh, 0, 0;
1254     while (1) {
1255         my $status = read $tmp_fh, my $buf, 4*1024;
1256         unless ( defined $status ) {
1257             $RT::Logger->crit( "couldn't read message: $!" );
1258         } elsif ( !$status ) {
1259             last;
1260         }
1261         ${ $args{'Content'} } .= $buf;
1262     }
1263
1264     return %res;
1265 }
1266
1267 my %REASON_CODE_TO_TEXT = (
1268     NODATA => {
1269         1 => "No armored data",
1270         2 => "Expected a packet, but did not found one",
1271         3 => "Invalid packet found",
1272         4 => "Signature expected, but not found",
1273     },
1274     INV_RECP => {
1275         0 => "No specific reason given",
1276         1 => "Not Found",
1277         2 => "Ambigious specification",
1278         3 => "Wrong key usage",
1279         4 => "Key revoked",
1280         5 => "Key expired",
1281         6 => "No CRL known",
1282         7 => "CRL too old",
1283         8 => "Policy mismatch",
1284         9 => "Not a secret key",
1285         10 => "Key not trusted",
1286     },
1287     ERRSIG => {
1288         0 => 'not specified',
1289         4 => 'unknown algorithm',
1290         9 => 'missing public key',
1291     },
1292 );
1293
1294 sub ReasonCodeToText {
1295     my $keyword = shift;
1296     my $code = shift;
1297     return $REASON_CODE_TO_TEXT{ $keyword }{ $code }
1298         if exists $REASON_CODE_TO_TEXT{ $keyword }{ $code };
1299     return 'unknown';
1300 }
1301
1302 my %simple_keyword = (
1303     NO_RECP => {
1304         Operation => 'RecipientsCheck',
1305         Status    => 'ERROR',
1306         Message   => 'No recipients',
1307     },
1308     UNEXPECTED => {
1309         Operation => 'Data',
1310         Status    => 'ERROR',
1311         Message   => 'Unexpected data has been encountered',
1312     },
1313     BADARMOR => {
1314         Operation => 'Data',
1315         Status    => 'ERROR',
1316         Message   => 'The ASCII armor is corrupted',
1317     },
1318 );
1319
1320 # keywords we parse
1321 my %parse_keyword = map { $_ => 1 } qw(
1322     USERID_HINT
1323     SIG_CREATED GOODSIG BADSIG ERRSIG
1324     END_ENCRYPTION
1325     DECRYPTION_FAILED DECRYPTION_OKAY
1326     BAD_PASSPHRASE GOOD_PASSPHRASE
1327     NO_SECKEY NO_PUBKEY
1328     NO_RECP INV_RECP NODATA UNEXPECTED
1329 );
1330
1331 # keywords we ignore without any messages as we parse them using other
1332 # keywords as starting point or just ignore as they are useless for us
1333 my %ignore_keyword = map { $_ => 1 } qw(
1334     NEED_PASSPHRASE MISSING_PASSPHRASE BEGIN_SIGNING PLAINTEXT PLAINTEXT_LENGTH
1335     BEGIN_ENCRYPTION SIG_ID VALIDSIG
1336     ENC_TO BEGIN_DECRYPTION END_DECRYPTION GOODMDC
1337     TRUST_UNDEFINED TRUST_NEVER TRUST_MARGINAL TRUST_FULLY TRUST_ULTIMATE
1338     DECRYPTION_INFO
1339 );
1340
1341 sub ParseStatus {
1342     my $self = shift;
1343     my $status = shift;
1344     return () unless $status;
1345
1346     my @status;
1347     while ( $status =~ /\[GNUPG:\]\s*(.*?)(?=\[GNUPG:\]|\z)/igms ) {
1348         push @status, $1; $status[-1] =~ s/\s+/ /g; $status[-1] =~ s/\s+$//;
1349     }
1350     $status = join "\n", @status;
1351     study $status;
1352
1353     my @res;
1354     my (%user_hint, $latest_user_main_key);
1355     for ( my $i = 0; $i < @status; $i++ ) {
1356         my $line = $status[$i];
1357         my ($keyword, $args) = ($line =~ /^(\S+)\s*(.*)$/s);
1358         if ( $simple_keyword{ $keyword } ) {
1359             push @res, $simple_keyword{ $keyword };
1360             $res[-1]->{'Keyword'} = $keyword;
1361             next;
1362         }
1363         unless ( $parse_keyword{ $keyword } ) {
1364             $RT::Logger->warning("Skipped $keyword") unless $ignore_keyword{ $keyword };
1365             next;
1366         }
1367
1368         if ( $keyword eq 'USERID_HINT' ) {
1369             my %tmp = _ParseUserHint($status, $line);
1370             $latest_user_main_key = $tmp{'MainKey'};
1371             if ( $user_hint{ $tmp{'MainKey'} } ) {
1372                 while ( my ($k, $v) = each %tmp ) {
1373                     $user_hint{ $tmp{'MainKey'} }->{$k} = $v;
1374                 }
1375             } else {
1376                 $user_hint{ $tmp{'MainKey'} } = \%tmp;
1377             }
1378             next;
1379         }
1380         elsif ( $keyword eq 'BAD_PASSPHRASE' || $keyword eq 'GOOD_PASSPHRASE' ) {
1381             my $key_id = $args;
1382             my %res = (
1383                 Operation => 'PassphraseCheck',
1384                 Status    => $keyword eq 'BAD_PASSPHRASE'? 'BAD' : 'DONE',
1385                 Key       => $key_id,
1386             );
1387             $res{'Status'} = 'MISSING' if $status[ $i - 1 ] =~ /^MISSING_PASSPHRASE/;
1388             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1389                 next unless $line =~ /^NEED_PASSPHRASE\s+(\S+)\s+(\S+)\s+(\S+)/;
1390                 next if $key_id && $2 ne $key_id;
1391                 @res{'MainKey', 'Key', 'KeyType'} = ($1, $2, $3);
1392                 last;
1393             }
1394             $res{'Message'} = ucfirst( lc( $res{'Status'} eq 'DONE'? 'GOOD': $res{'Status'} ) ) .' passphrase';
1395             $res{'User'} = ( $user_hint{ $res{'MainKey'} } ||= {} ) if $res{'MainKey'};
1396             if ( exists $res{'User'}->{'EmailAddress'} ) {
1397                 $res{'Message'} .= ' for '. $res{'User'}->{'EmailAddress'};
1398             } else {
1399                 $res{'Message'} .= " for '0x$key_id'";
1400             }
1401             push @res, \%res;
1402         }
1403         elsif ( $keyword eq 'END_ENCRYPTION' ) {
1404             my %res = (
1405                 Operation => 'Encrypt',
1406                 Status    => 'DONE',
1407                 Message   => 'Data has been encrypted',
1408             );
1409             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1410                 next unless $line =~ /^BEGIN_ENCRYPTION\s+(\S+)\s+(\S+)/;
1411                 @res{'MdcMethod', 'SymAlgo'} = ($1, $2);
1412                 last;
1413             }
1414             push @res, \%res;
1415         }
1416         elsif ( $keyword eq 'DECRYPTION_FAILED' || $keyword eq 'DECRYPTION_OKAY' ) {
1417             my %res = ( Operation => 'Decrypt' );
1418             @res{'Status', 'Message'} = 
1419                 $keyword eq 'DECRYPTION_FAILED'
1420                 ? ('ERROR', 'Decryption failed')
1421                 : ('DONE',  'Decryption process succeeded');
1422
1423             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1424                 next unless $line =~ /^ENC_TO\s+(\S+)\s+(\S+)\s+(\S+)/;
1425                 my ($key, $alg, $key_length) = ($1, $2, $3);
1426
1427                 my %encrypted_to = (
1428                     Message   => "The message is encrypted to '0x$key'",
1429                     User      => ( $user_hint{ $key } ||= {} ),
1430                     Key       => $key,
1431                     KeyLength => $key_length,
1432                     Algorithm => $alg,
1433                 );
1434
1435                 push @{ $res{'EncryptedTo'} ||= [] }, \%encrypted_to;
1436             }
1437
1438             push @res, \%res;
1439         }
1440         elsif ( $keyword eq 'NO_SECKEY' || $keyword eq 'NO_PUBKEY' ) {
1441             my ($key) = split /\s+/, $args;
1442             my $type = $keyword eq 'NO_SECKEY'? 'secret': 'public';
1443             my %res = (
1444                 Operation => 'KeyCheck',
1445                 Status    => 'MISSING',
1446                 Message   => ucfirst( $type ) ." key '0x$key' is not available",
1447                 Key       => $key,
1448                 KeyType   => $type,
1449             );
1450             $res{'User'} = ( $user_hint{ $key } ||= {} );
1451             $res{'User'}{ ucfirst( $type ). 'KeyMissing' } = 1;
1452             push @res, \%res;
1453         }
1454         # GOODSIG, BADSIG, VALIDSIG, TRUST_*
1455         elsif ( $keyword eq 'GOODSIG' ) {
1456             my %res = (
1457                 Operation  => 'Verify',
1458                 Status     => 'DONE',
1459                 Message    => 'The signature is good',
1460             );
1461             @res{qw(Key UserString)} = split /\s+/, $args, 2;
1462             $res{'Message'} .= ', signed by '. $res{'UserString'};
1463
1464             foreach my $line ( @status[ $i .. $#status ] ) {
1465                 next unless $line =~ /^TRUST_(\S+)/;
1466                 $res{'Trust'} = $1;
1467                 last;
1468             }
1469             $res{'Message'} .= ', trust level is '. lc( $res{'Trust'} || 'unknown');
1470
1471             foreach my $line ( @status[ $i .. $#status ] ) {
1472                 next unless $line =~ /^VALIDSIG\s+(.*)/;
1473                 @res{ qw(
1474                     Fingerprint
1475                     CreationDate
1476                     Timestamp
1477                     ExpireTimestamp
1478                     Version
1479                     Reserved
1480                     PubkeyAlgo
1481                     HashAlgo
1482                     Class
1483                     PKFingerprint
1484                     Other
1485                 ) } = split /\s+/, $1, 10;
1486                 last;
1487             }
1488             push @res, \%res;
1489         }
1490         elsif ( $keyword eq 'BADSIG' ) {
1491             my %res = (
1492                 Operation  => 'Verify',
1493                 Status     => 'BAD',
1494                 Message    => 'The signature has not been verified okay',
1495             );
1496             @res{qw(Key UserString)} = split /\s+/, $args, 2;
1497             push @res, \%res;
1498         }
1499         elsif ( $keyword eq 'ERRSIG' ) {
1500             my %res = (
1501                 Operation => 'Verify',
1502                 Status    => 'ERROR',
1503                 Message   => 'Not possible to check the signature',
1504             );
1505             @res{qw(Key PubkeyAlgo HashAlgo Class Timestamp ReasonCode Other)}
1506                 = split /\s+/, $args, 7;
1507
1508             $res{'Reason'} = ReasonCodeToText( $keyword, $res{'ReasonCode'} );
1509             $res{'Message'} .= ", the reason is ". $res{'Reason'};
1510
1511             push @res, \%res;
1512         }
1513         elsif ( $keyword eq 'SIG_CREATED' ) {
1514             # SIG_CREATED <type> <pubkey algo> <hash algo> <class> <timestamp> <key fpr>
1515             my @props = split /\s+/, $args;
1516             push @res, {
1517                 Operation      => 'Sign',
1518                 Status         => 'DONE',
1519                 Message        => "Signed message",
1520                 Type           => $props[0],
1521                 PubKeyAlgo     => $props[1],
1522                 HashKeyAlgo    => $props[2],
1523                 Class          => $props[3],
1524                 Timestamp      => $props[4],
1525                 KeyFingerprint => $props[5],
1526                 User           => $user_hint{ $latest_user_main_key },
1527             };
1528             $res[-1]->{Message} .= ' by '. $user_hint{ $latest_user_main_key }->{'EmailAddress'}
1529                 if $user_hint{ $latest_user_main_key };
1530         }
1531         elsif ( $keyword eq 'INV_RECP' ) {
1532             my ($rcode, $recipient) = split /\s+/, $args, 2;
1533             my $reason = ReasonCodeToText( $keyword, $rcode );
1534             push @res, {
1535                 Operation  => 'RecipientsCheck',
1536                 Status     => 'ERROR',
1537                 Message    => "Recipient '$recipient' is unusable, the reason is '$reason'",
1538                 Recipient  => $recipient,
1539                 ReasonCode => $rcode,
1540                 Reason     => $reason,
1541             };
1542         }
1543         elsif ( $keyword eq 'NODATA' ) {
1544             my $rcode = (split /\s+/, $args)[0];
1545             my $reason = ReasonCodeToText( $keyword, $rcode );
1546             push @res, {
1547                 Operation  => 'Data',
1548                 Status     => 'ERROR',
1549                 Message    => "No data has been found. The reason is '$reason'",
1550                 ReasonCode => $rcode,
1551                 Reason     => $reason,
1552             };
1553         }
1554         else {
1555             $RT::Logger->warning("Keyword $keyword is unknown");
1556             next;
1557         }
1558         $res[-1]{'Keyword'} = $keyword if @res && !$res[-1]{'Keyword'};
1559     }
1560     return @res;
1561 }
1562
1563 sub _ParseUserHint {
1564     my ($status, $hint) = (@_);
1565     my ($main_key_id, $user_str) = ($hint =~ /^USERID_HINT\s+(\S+)\s+(.*)$/);
1566     return () unless $main_key_id;
1567     return (
1568         MainKey      => $main_key_id,
1569         String       => $user_str,
1570         EmailAddress => (map $_->address, Email::Address->parse( $user_str ))[0],
1571     );
1572 }
1573
1574 sub _PrepareGnuPGOptions {
1575     my %opt = @_;
1576     my %res = map { lc $_ => $opt{ $_ } } grep $supported_opt{ lc $_ }, keys %opt;
1577     $res{'extra_args'} ||= [];
1578     foreach my $o ( grep !$supported_opt{ lc $_ }, keys %opt ) {
1579         push @{ $res{'extra_args'} }, '--'. lc $o;
1580         push @{ $res{'extra_args'} }, $opt{ $o }
1581             if defined $opt{ $o };
1582     }
1583     return %res;
1584 }
1585
1586 sub GetKeysForEncryption {
1587     my $self = shift;
1588     my %args = (Recipient => undef, @_);
1589     my %res = $self->GetKeysInfo( Key => delete $args{'Recipient'}, %args, Type => 'public' );
1590     return %res if $res{'exit_code'};
1591     return %res unless $res{'info'};
1592
1593     foreach my $key ( splice @{ $res{'info'} } ) {
1594         # skip disabled keys
1595         next if $key->{'Capabilities'} =~ /D/;
1596         # skip keys not suitable for encryption
1597         next unless $key->{'Capabilities'} =~ /e/i;
1598         # skip disabled, expired, revoked and keys with no trust,
1599         # but leave keys with unknown trust level
1600         next if $key->{'TrustLevel'} < 0;
1601
1602         push @{ $res{'info'} }, $key;
1603     }
1604     delete $res{'info'} unless @{ $res{'info'} };
1605     return %res;
1606 }
1607
1608 sub GetKeysForSigning {
1609     my $self = shift;
1610     my %args = (Signer => undef, @_);
1611     return $self->GetKeysInfo( Key => delete $args{'Signer'}, %args, Type => 'private' );
1612 }
1613
1614 sub GetKeysInfo {
1615     my $self = shift;
1616     my %args = (
1617         Key   => undef,
1618         Type  => 'public',
1619         Force => 0,
1620         @_
1621     );
1622
1623     my $email = $args{'Key'};
1624     my $type = $args{'Type'};
1625     unless ( $email ) {
1626         return (exit_code => 0) unless $args{'Force'};
1627     }
1628
1629     my @info;
1630     my $method = $type eq 'private'? 'list_secret_keys': 'list_public_keys';
1631     my %res = $self->CallGnuPG(
1632         Options     => {
1633             'with-colons'     => undef, # parseable format
1634             'fingerprint'     => undef, # show fingerprint
1635             'fixed-list-mode' => undef, # don't merge uid with keys
1636         },
1637         Command     => $method,
1638         ( $email ? (CommandArgs => ['--', $email]) : () ),
1639         Output      => \@info,
1640     );
1641
1642     # Asking for a non-existent key is not an error
1643     if ($res{message} and $res{logger} =~ /(secret key not available|public key not found)/) {
1644         delete $res{exit_code};
1645         delete $res{message};
1646     }
1647
1648     return %res if $res{'message'};
1649
1650     @info = $self->ParseKeysInfo( @info );
1651     $res{'info'} = \@info;
1652     return %res;
1653 }
1654
1655 sub ParseKeysInfo {
1656     my $self = shift;
1657     my @lines = @_;
1658
1659     my %gpg_opt = RT->Config->Get('GnuPGOptions');
1660
1661     my @res = ();
1662     foreach my $line( @lines ) {
1663         chomp $line;
1664         my $tag;
1665         ($tag, $line) = split /:/, $line, 2;
1666         if ( $tag eq 'pub' ) {
1667             my %info;
1668             @info{ qw(
1669                 TrustChar KeyLength Algorithm Key
1670                 Created Expire Empty OwnerTrustChar
1671                 Empty Empty Capabilities Other
1672             ) } = split /:/, $line, 12;
1673
1674             # workaround gnupg's wierd behaviour, --list-keys command report calculated trust levels
1675             # for any model except 'always', so you can change models and see changes, but not for 'always'
1676             # we try to handle it in a simple way - we set ultimate trust for any key with trust
1677             # level >= 0 if trust model is 'always'
1678             my $always_trust;
1679             $always_trust = 1 if exists $gpg_opt{'always-trust'};
1680             $always_trust = 1 if exists $gpg_opt{'trust-model'} && $gpg_opt{'trust-model'} eq 'always';
1681             @info{qw(Trust TrustTerse TrustLevel)} = 
1682                 _ConvertTrustChar( $info{'TrustChar'} );
1683             if ( $always_trust && $info{'TrustLevel'} >= 0 ) {
1684                 @info{qw(Trust TrustTerse TrustLevel)} = 
1685                     _ConvertTrustChar( 'u' );
1686             }
1687
1688             @info{qw(OwnerTrust OwnerTrustTerse OwnerTrustLevel)} = 
1689                 _ConvertTrustChar( $info{'OwnerTrustChar'} );
1690             $info{ $_ } = $self->ParseDate( $info{ $_ } )
1691                 foreach qw(Created Expire);
1692             push @res, \%info;
1693         }
1694         elsif ( $tag eq 'sec' ) {
1695             my %info;
1696             @info{ qw(
1697                 Empty KeyLength Algorithm Key
1698                 Created Expire Empty OwnerTrustChar
1699                 Empty Empty Capabilities Other
1700             ) } = split /:/, $line, 12;
1701             @info{qw(OwnerTrust OwnerTrustTerse OwnerTrustLevel)} = 
1702                 _ConvertTrustChar( $info{'OwnerTrustChar'} );
1703             $info{ $_ } = $self->ParseDate( $info{ $_ } )
1704                 foreach qw(Created Expire);
1705             push @res, \%info;
1706         }
1707         elsif ( $tag eq 'uid' ) {
1708             my %info;
1709             @info{ qw(Trust Created Expire String) }
1710                 = (split /:/, $line)[0,4,5,8];
1711             $info{ $_ } = $self->ParseDate( $info{ $_ } )
1712                 foreach qw(Created Expire);
1713             push @{ $res[-1]{'User'} ||= [] }, \%info;
1714         }
1715         elsif ( $tag eq 'fpr' ) {
1716             $res[-1]{'Fingerprint'} = (split /:/, $line, 10)[8];
1717         }
1718     }
1719     return @res;
1720 }
1721
1722 {
1723     my %verbose = (
1724         # deprecated
1725         d   => [
1726             "The key has been disabled", #loc
1727             "key disabled", #loc
1728             "-2"
1729         ],
1730
1731         r   => [
1732             "The key has been revoked", #loc
1733             "key revoked", #loc
1734             -3,
1735         ],
1736
1737         e   => [ "The key has expired", #loc
1738             "key expired", #loc
1739             '-4',
1740         ],
1741
1742         n   => [ "Don't trust this key at all", #loc
1743             'none', #loc
1744             -1,
1745         ],
1746
1747         #gpupg docs says that '-' and 'q' may safely be treated as the same value
1748         '-' => [
1749             'Unknown (no trust value assigned)', #loc
1750             'not set',
1751             0,
1752         ],
1753         q   => [
1754             'Unknown (no trust value assigned)', #loc
1755             'not set',
1756             0,
1757         ],
1758         o   => [
1759             'Unknown (this value is new to the system)', #loc
1760             'unknown',
1761             0,
1762         ],
1763
1764         m   => [
1765             "There is marginal trust in this key", #loc
1766             'marginal', #loc
1767             1,
1768         ],
1769         f   => [
1770             "The key is fully trusted", #loc
1771             'full', #loc
1772             2,
1773         ],
1774         u   => [
1775             "The key is ultimately trusted", #loc
1776             'ultimate', #loc
1777             3,
1778         ],
1779     );
1780
1781     sub _ConvertTrustChar {
1782         my $value = shift;
1783         return @{ $verbose{'-'} } unless $value;
1784         $value = substr $value, 0, 1;
1785         return @{ $verbose{ $value } || $verbose{'o'} };
1786     }
1787 }
1788
1789 sub DeleteKey {
1790     my $self = shift;
1791     my $key = shift;
1792
1793     return $self->CallGnuPG(
1794         Command     => "--delete-secret-and-public-key",
1795         CommandArgs => ["--", $key],
1796         Callback    => sub {
1797             my %handle = @_;
1798             while ( my $str = readline $handle{'status'} ) {
1799                 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL delete_key\..*/ ) {
1800                     print { $handle{'command'} } "y\n";
1801                 }
1802             }
1803         },
1804     );
1805 }
1806
1807 sub ImportKey {
1808     my $self = shift;
1809     my $key = shift;
1810
1811     return $self->CallGnuPG(
1812         Command     => "import_keys",
1813         Content     => $key,
1814     );
1815 }
1816
1817 sub GnuPGPath {
1818     state $cache = RT->Config->Get('GnuPG')->{'GnuPG'};
1819     $cache = $_[1] if @_ > 1;
1820     return $cache;
1821 }
1822
1823 sub Probe {
1824     my $self = shift;
1825     my $gnupg = GnuPG::Interface->new;
1826
1827     my $bin = $self->GnuPGPath();
1828     unless ($bin) {
1829         $RT::Logger->warning(
1830             "No gpg path set; GnuPG support has been disabled.  ".
1831             "Check the 'GnuPG' configuration in %GnuPG");
1832         return 0;
1833     }
1834
1835     if ($bin =~ m{^/}) {
1836         unless (-f $bin and -x _) {
1837             $RT::Logger->warning(
1838                 "Invalid gpg path $bin; GnuPG support has been disabled.  ".
1839                 "Check the 'GnuPG' configuration in %GnuPG");
1840             return 0;
1841         }
1842     } else {
1843         local $ENV{PATH} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin'
1844             unless defined $ENV{PATH};
1845         my $path = File::Which::which( $bin );
1846         unless ($path) {
1847             $RT::Logger->warning(
1848                 "Can't find gpg binary '$bin' in PATH ($ENV{PATH}); GnuPG support has been disabled.  ".
1849                 "You may need to specify a full path to gpg via the 'GnuPG' configuration in %GnuPG");
1850             return 0;
1851         }
1852         $self->GnuPGPath( $bin = $path );
1853     }
1854
1855     $gnupg->call( $bin );
1856     $gnupg->options->hash_init(
1857         _PrepareGnuPGOptions( RT->Config->Get('GnuPGOptions') )
1858     );
1859     $gnupg->options->meta_interactive( 0 );
1860
1861     my ($handles, $handle_list) = _make_gpg_handles();
1862     my %handle = %$handle_list;
1863
1864     local $@ = undef;
1865     eval {
1866         local $SIG{'CHLD'} = 'DEFAULT';
1867         my $pid = safe_run_child {
1868             $gnupg->wrap_call(
1869                 commands => ['--version' ],
1870                 handles  => $handles
1871             )
1872         };
1873         close $handle{'stdin'} or die "Can't close gnupg input handle: $!";
1874         waitpid $pid, 0;
1875     };
1876     if ( $@ ) {
1877         $RT::Logger->warning(
1878             "RT's GnuPG libraries couldn't successfully execute gpg.".
1879                 " GnuPG support has been disabled");
1880         $RT::Logger->debug(
1881             "Probe for GPG failed."
1882             ." Couldn't run `gpg --version`: ". $@
1883         );
1884         return 0;
1885     }
1886
1887 # on some systems gpg exits with code 2, but still 100% functional,
1888 # it's general error system error or incorrect command, command is correct,
1889 # but there is no way to get actuall error
1890     if ( $? && ($? >> 8) != 2 ) {
1891         my $msg = "Probe for GPG failed."
1892             ." Process exited with code ". ($? >> 8)
1893             . ($? & 127 ? (" as recieved signal ". ($? & 127)) : '')
1894             . ".";
1895         foreach ( qw(stderr logger status) ) {
1896             my $tmp = do { local $/ = undef; readline $handle{$_} };
1897             next unless $tmp && $tmp =~ /\S/s;
1898             close $handle{$_} or $tmp .= "\nFailed to close: $!";
1899             $msg .= "\n$_:\n$tmp\n";
1900         }
1901         $RT::Logger->warning(
1902             "RT's GnuPG libraries couldn't successfully execute gpg.".
1903                 " GnuPG support has been disabled");
1904         $RT::Logger->debug( $msg );
1905         return 0;
1906     }
1907     return 1;
1908 }
1909
1910
1911 sub _make_gpg_handles {
1912     my %handle_map = (@_);
1913     $handle_map{$_} = IO::Handle->new
1914         foreach grep !defined $handle_map{$_}, 
1915         qw(stdin stdout stderr logger status command);
1916
1917     my $handles = GnuPG::Handles->new(%handle_map);
1918     return ($handles, \%handle_map);
1919 }
1920
1921 RT::Base->_ImportOverlays();
1922
1923 1;