lib/RT/Crypt/GnuPG.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2013 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         my $path = File::Which::which( $bin );
1844         unless ($path) {
1845             $RT::Logger->warning(
1846                 "Can't find gpg binary '$bin' in PATH; GnuPG support has been disabled.  ".
1847                 "Check the 'GnuPG' configuration in %GnuPG");
1848             return 0;
1849         }
1850         $self->GnuPGPath( $bin = $path );
1851     }
1852
1853     $gnupg->call( $bin );
1854     $gnupg->options->hash_init(
1855         _PrepareGnuPGOptions( RT->Config->Get('GnuPGOptions') )
1856     );
1857     $gnupg->options->meta_interactive( 0 );
1858
1859     my ($handles, $handle_list) = _make_gpg_handles();
1860     my %handle = %$handle_list;
1861
1862     local $@ = undef;
1863     eval {
1864         local $SIG{'CHLD'} = 'DEFAULT';
1865         my $pid = safe_run_child {
1866             $gnupg->wrap_call(
1867                 commands => ['--version' ],
1868                 handles  => $handles
1869             )
1870         };
1871         close $handle{'stdin'} or die "Can't close gnupg input handle: $!";
1872         waitpid $pid, 0;
1873     };
1874     if ( $@ ) {
1875         $RT::Logger->warning(
1876             "RT's GnuPG libraries couldn't successfully execute gpg.".
1877                 " GnuPG support has been disabled");
1878         $RT::Logger->debug(
1879             "Probe for GPG failed."
1880             ." Couldn't run `gpg --version`: ". $@
1881         );
1882         return 0;
1883     }
1884
1885 # on some systems gpg exits with code 2, but still 100% functional,
1886 # it's general error system error or incorrect command, command is correct,
1887 # but there is no way to get actuall error
1888     if ( $? && ($? >> 8) != 2 ) {
1889         my $msg = "Probe for GPG failed."
1890             ." Process exited with code ". ($? >> 8)
1891             . ($? & 127 ? (" as recieved signal ". ($? & 127)) : '')
1892             . ".";
1893         foreach ( qw(stderr logger status) ) {
1894             my $tmp = do { local $/ = undef; readline $handle{$_} };
1895             next unless $tmp && $tmp =~ /\S/s;
1896             close $handle{$_} or $tmp .= "\nFailed to close: $!";
1897             $msg .= "\n$_:\n$tmp\n";
1898         }
1899         $RT::Logger->warning(
1900             "RT's GnuPG libraries couldn't successfully execute gpg.".
1901                 " GnuPG support has been disabled");
1902         $RT::Logger->debug( $msg );
1903         return 0;
1904     }
1905     return 1;
1906 }
1907
1908
1909 sub _make_gpg_handles {
1910     my %handle_map = (@_);
1911     $handle_map{$_} = IO::Handle->new
1912         foreach grep !defined $handle_map{$_},
1913         qw(stdin stdout stderr logger status command);
1914
1915     my $handles = GnuPG::Handles->new(%handle_map);
1916     return ($handles, \%handle_map);
1917 }
1918
1919 RT::Base->_ImportOverlays();
1920
1921 1;