rt/lib/RT/Crypt/GnuPG.pm

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