rt/lib/RT/Crypt/GnuPG.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2011 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
  52 package RT::Crypt::GnuPG;
  53
  54 use IO::Handle;
  55 use GnuPG::Interface;
  56 use RT::EmailParser ();
  57 use RT::Util 'safe_run_child';
  58
  59 =head1 NAME
  60
  61 RT::Crypt::GnuPG - encrypt/decrypt and sign/verify email messages with the GNU Privacy Guard (GPG)
  62
  63 =head1 DESCRIPTION
  64
  65 This module provides support for encryption and signing of outgoing messages,
  66 as well as the decryption and verification of incoming email.
  67
  68 =head1 CONFIGURATION
  69
  70 You can control the configuration of this subsystem from RT's configuration file.
  71 Some options are available via the web interface, but to enable this functionality, you
  72 MUST start in the configuration file.
  73
  74 There are two hashes, GnuPG and GnuPGOptions in the configuration file. The
  75 first one controls RT specific options. It enables you to enable/disable facility
  76 or change the format of messages. The second one is a hash with options for the
  77 'gnupg' utility. You can use it to define a keyserver, enable auto-retrieval keys
  78 and set almost any option 'gnupg' supports on your system.
  79
  80 =head2 %GnuPG
  81
  82 =head3 Enabling GnuPG
  83
  84 Set to true value to enable this subsystem:
  85
  86     Set( %GnuPG,
  87         Enable => 1,
  88         ... other options ...
  89     );
  90
  91 However, note that you B<must> add the 'Auth::GnuPG' email filter to enable
  92 the handling of incoming encrypted/signed messages.
  93
  94 =head3 Format of outgoing messages
  95
  96 Format of outgoing messages can be controlled using the 'OutgoingMessagesFormat'
  97 option in the RT config:
  98
  99     Set( %GnuPG,
 100         ... other options ...
 101         OutgoingMessagesFormat => 'RFC',
 102         ... other options ...
 103     );
 104
 105 or
 106
 107     Set( %GnuPG,
 108         ... other options ...
 109         OutgoingMessagesFormat => 'Inline',
 110         ... other options ...
 111     );
 112
 113 This framework implements two formats of signing and encrypting of email messages:
 114
 115 =over
 116
 117 =item RFC
 118
 119 This format is also known as GPG/MIME and described in RFC3156 and RFC1847.
 120 Technique described in these RFCs is well supported by many mail user
 121 agents (MUA), but some MUAs support only inline signatures and encryption,
 122 so it's possible to use inline format (see below).
 123
 124 =item Inline
 125
 126 This format doesn't take advantage of MIME, but some mail clients do
 127 not support GPG/MIME.
 128
 129 We sign text parts using clear signatures. For each attachments another
 130 attachment with a signature is added with '.sig' extension.
 131
 132 Encryption of text parts is implemented using inline format, other parts
 133 are replaced with attachments with the filename extension '.pgp'.
 134
 135 This format is discouraged because modern mail clients typically don't support
 136 it well.
 137
 138 =back
 139
 140 =head3 Encrypting data in the database
 141
 142 You can allow users to encrypt data in the database using
 143 option C<AllowEncryptDataInDB>. By default it's disabled.
 144 Users must have rights to see and modify tickets to use
 145 this feature.
 146
 147 =head2 %GnuPGOptions
 148
 149 Use this hash to set options of the 'gnupg' program. You can define almost any
 150 option you want which  gnupg supports, but never try to set options which
 151 change output format or gnupg's commands, such as --sign (command),
 152 --list-options (option) and other.
 153
 154 Some GnuPG options take arguments while others take none. (Such as  --use-agent).
 155 For options without specific value use C<undef> as hash value.
 156 To disable these option just comment them out or delete them from the hash
 157
 158     Set(%GnuPGOptions,
 159         'option-with-value' => 'value',
 160         'enabled-option-without-value' => undef,
 161         # 'commented-option' => 'value or undef',
 162     );
 163
 164 B<NOTE> that options may contain '-' character and such options B<MUST> be
 165 quoted, otherwise you can see quite cryptic error 'gpg: Invalid option "--0"'.
 166
 167 =over
 168
 169 =item --homedir
 170
 171 The GnuPG home directory, by default it is set to F</opt/rt3/var/data/gpg>.
 172
 173 You can manage this data with the 'gpg' commandline utility
 174 using the GNUPGHOME environment variable or --homedir option.
 175 Other utilities may be used as well.
 176
 177 In a standard installation, access to this directory should be granted to
 178 the web server user which is running RT's web interface, but if you're running
 179 cronjobs or other utilities that access RT directly via API and may generate
 180 encrypted/signed notifications then the users you execute these scripts under
 181 must have access too.
 182
 183 However, granting access to the dir to many users makes your setup less secure,
 184 some features, such as auto-import of keys, may not be available if you do not.
 185 To enable this features and suppress warnings about permissions on
 186 the dir use --no-permission-warning.
 187
 188 =item --digest-algo
 189
 190 This option is required in advance when RFC format for outgoing messages is
 191 used. We can not get default algorithm from gpg program so RT uses 'SHA1' by
 192 default. You may want to override it. You can use MD5, SHA1, RIPEMD160,
 193 SHA256 or other, however use `gpg --version` command to get information about
 194 supported algorithms by your gpg. These algorithms are listed as hash-functions.
 195
 196 =item --use-agent
 197
 198 This option lets you use GPG Agent to cache the passphrase of RT's key. See
 199 L<http://www.gnupg.org/documentation/manuals/gnupg/Invoking-GPG_002dAGENT.html>
 200 for information about GPG Agent.
 201
 202 =item --passphrase
 203
 204 This option lets you set the passphrase of RT's key directly. This option is
 205 special in that it isn't passed directly to GPG, but is put into a file that
 206 GPG then reads (which is more secure). The downside is that anyone who has read
 207 access to your RT_SiteConfig.pm file can see the passphrase, thus we recommend
 208 the --use-agent option instead.
 209
 210 =item other
 211
 212 Read `man gpg` to get list of all options this program support.
 213
 214 =back
 215
 216 =head2 Per-queue options
 217
 218 Using the web interface it's possible to enable signing and/or encrypting by
 219 default. As an administrative user of RT, open 'Configuration' then 'Queues',
 220 and select a queue. On the page you can see information about the queue's keys
 221 at the bottom and two checkboxes to choose default actions.
 222
 223 As well, encryption is enabled for autoreplies and other notifications when
 224 an encypted message enters system via mailgate interface even if queue's
 225 option is disabled.
 226
 227 =head2 Handling incoming messages
 228
 229 To enable handling of encrypted and signed message in the RT you should add
 230 'Auth::GnuPG' mail plugin.
 231
 232     Set(@MailPlugins, 'Auth::MailFrom', 'Auth::GnuPG', ...other filter...);
 233
 234 See also `perldoc lib/RT/Interface/Email/Auth/GnuPG.pm`.
 235
 236 =head2 Errors handling
 237
 238 There are several global templates created in the database by default. RT
 239 uses these templates to send error messages to users or RT's owner. These
 240 templates have 'Error:' or 'Error to RT owner:' prefix in the name. You can
 241 adjust the text of the messages using the web interface.
 242
 243 Note that C<$TicketObj>, C<$TransactionObj> and other variable usually available
 244 in RT's templates are not available in these templates, but each template
 245 used for errors reporting has set of available data structures you can use to
 246 build better messages. See default templates and descriptions below.
 247
 248 As well, you can disable particular notification by deleting content of
 249 a template. You can delete a template too, but in this case you'll see
 250 error messages in the logs when RT can not load template you've deleted.
 251
 252 =head3 Problems with public keys
 253
 254 Template 'Error: public key' is used to inform the user that RT has problems with
 255 his public key and won't be able to send him encrypted content. There are several
 256 reasons why RT can't use a key. However, the actual reason is not sent to the user,
 257 but sent to RT owner using 'Error to RT owner: public key'.
 258
 259 The possible reasons: "Not Found", "Ambiguous specification", "Wrong
 260 key usage", "Key revoked", "Key expired", "No CRL known", "CRL too
 261 old", "Policy mismatch", "Not a secret key", "Key not trusted" or
 262 "No specific reason given".
 263
 264 Due to limitations of GnuPG, it's impossible to encrypt to an untrusted key,
 265 unless 'always trust' mode is enabled.
 266
 267 In the 'Error: public key' template there are a few additional variables available:
 268
 269 =over 4
 270
 271 =item $Message - user friendly error message
 272
 273 =item $Reason - short reason as listed above
 274
 275 =item $Recipient - recipient's identification
 276
 277 =item $AddressObj - L<Email::Address> object containing recipient's email address
 278
 279 =back
 280
 281 A message can have several invalid recipients, to avoid sending many emails
 282 to the RT owner the system sends one message to the owner, grouped by
 283 recipient. In the 'Error to RT owner: public key' template a C<@BadRecipients>
 284 array is available where each element is a hash reference that describes one
 285 recipient using the same fields as described above. So it's something like:
 286
 287     @BadRecipients = (
 288         { Message => '...', Reason => '...', Recipient => '...', ...},
 289         { Message => '...', Reason => '...', Recipient => '...', ...},
 290         ...
 291     )
 292
 293 =head3 Private key doesn't exist
 294
 295 Template 'Error: no private key' is used to inform the user that
 296 he sent an encrypted email, but we have no private key to decrypt
 297 it.
 298
 299 In this template C<$Message> object of L<MIME::Entity> class
 300 available. It's the message RT received.
 301
 302 =head3 Invalid data
 303
 304 Template 'Error: bad GnuPG data' used to inform the user that a
 305 message he sent has invalid data and can not be handled.
 306
 307 There are several reasons for this error, but most of them are data
 308 corruption or absence of expected information.
 309
 310 In this template C<@Messages> array is available and contains list
 311 of error messages.
 312
 313 =head1 FOR DEVELOPERS
 314
 315 =head2 Documentation and references
 316
 317 * RFC1847 - Security Multiparts for MIME: Multipart/Signed and Multipart/Encrypted.
 318 Describes generic MIME security framework, "mulitpart/signed" and "multipart/encrypted"
 319 MIME types.
 320
 321 * RFC3156 - MIME Security with Pretty Good Privacy (PGP),
 322 updates RFC2015.
 323
 324 =cut
 325
 326 # gnupg options supported by GnuPG::Interface
 327 # other otions should be handled via extra_args argument
 328 my %supported_opt = map { $_ => 1 } qw(
 329        always_trust
 330        armor
 331        batch
 332        comment
 333        compress_algo
 334        default_key
 335        encrypt_to
 336        extra_args
 337        force_v3_sigs
 338        homedir
 339        logger_fd
 340        no_greeting
 341        no_options
 342        no_verbose
 343        openpgp
 344        options
 345        passphrase_fd
 346        quiet
 347        recipients
 348        rfc1991
 349        status_fd
 350        textmode
 351        verbose
 352 );
 353
 354 # DEV WARNING: always pass all STD* handles to GnuPG interface even if we don't
 355 # need them, just pass 'new IO::Handle' and then close it after safe_run_child.
 356 # we don't want to leak anything into FCGI/Apache/MP handles, this break things.
 357 # So code should look like:
 358 #        my $handles = GnuPG::Handles->new(
 359 #            stdin  => ($handle{'stdin'}  = new IO::Handle),
 360 #            stdout => ($handle{'stdout'} = new IO::Handle),
 361 #            stderr => ($handle{'stderr'}  = new IO::Handle),
 362 #            ...
 363 #        );
 364
 365 =head2 SignEncrypt Entity => MIME::Entity, [ Encrypt => 1, Sign => 1, ... ]
 366
 367 Signs and/or encrypts an email message with GnuPG utility.
 368
 369 =over
 370
 371 =item Signing
 372
 373 During signing you can pass C<Signer> argument to set key we sign with this option
 374 overrides gnupg's C<default-key> option. If C<Signer> argument is not provided
 375 then address of a message sender is used.
 376
 377 As well you can pass C<Passphrase>, but if value is undefined then L</GetPassphrase>
 378 called to get it.
 379
 380 =item Encrypting
 381
 382 During encryption you can pass a C<Recipients> array, otherwise C<To>, C<Cc> and
 383 C<Bcc> fields of the message are used to fetch the list.
 384
 385 =back
 386
 387 Returns a hash with the following keys:
 388
 389 * exit_code
 390 * error
 391 * logger
 392 * status
 393 * message
 394
 395 =cut
 396
 397 sub SignEncrypt {
 398     my %args = (@_);
 399
 400     my $entity = $args{'Entity'};
 401     if ( $args{'Sign'} && !defined $args{'Signer'} ) {
 402         $args{'Signer'} = UseKeyForSigning()
 403             || (Email::Address->parse( $entity->head->get( 'From' ) ))[0]->address;
 404     }
 405     if ( $args{'Encrypt'} && !$args{'Recipients'} ) {
 406         my %seen;
 407         $args{'Recipients'} = [
 408             grep $_ && !$seen{ $_ }++, map $_->address,
 409             map Email::Address->parse( $entity->head->get( $_ ) ),
 410             qw(To Cc Bcc)
 411         ];
 412     }
 413
 414     my $format = lc RT->Config->Get('GnuPG')->{'OutgoingMessagesFormat'} || 'RFC';
 415     if ( $format eq 'inline' ) {
 416         return SignEncryptInline( %args );
 417     } else {
 418         return SignEncryptRFC3156( %args );
 419     }
 420 }
 421
 422 sub SignEncryptRFC3156 {
 423     my %args = (
 424         Entity => undef,
 425
 426         Sign => 1,
 427         Signer => undef,
 428         Passphrase => undef,
 429
 430         Encrypt => 1,
 431         Recipients => undef,
 432
 433         @_
 434     );
 435
 436     my $gnupg = new GnuPG::Interface;
 437     my %opt = RT->Config->Get('GnuPGOptions');
 438
 439     # handling passphrase in GnuPGOptions
 440     $args{'Passphrase'} = delete $opt{'passphrase'}
 441         if !defined $args{'Passphrase'};
 442
 443     $opt{'digest-algo'} ||= 'SHA1';
 444     $opt{'default_key'} = $args{'Signer'}
 445         if $args{'Sign'} && $args{'Signer'};
 446     $gnupg->options->hash_init(
 447         _PrepareGnuPGOptions( %opt ),
 448         armor => 1,
 449         meta_interactive => 0,
 450     );
 451
 452     my $entity = $args{'Entity'};
 453
 454     if ( $args{'Sign'} && !defined $args{'Passphrase'} ) {
 455         $args{'Passphrase'} = GetPassphrase( Address => $args{'Signer'} );
 456     }
 457
 458     my %res;
 459     if ( $args{'Sign'} && !$args{'Encrypt'} ) {
 460         # required by RFC3156(Ch. 5) and RFC1847(Ch. 2.1)
 461         foreach ( grep !$_->is_multipart, $entity->parts_DFS ) {
 462             my $tenc = $_->head->mime_encoding;
 463             unless ( $tenc =~ m/^(?:7bit|quoted-printable|base64)$/i ) {
 464                 $_->head->mime_attr( 'Content-Transfer-Encoding'
 465                     => $_->effective_type =~ m{^text/}? 'quoted-printable': 'base64'
 466                 );
 467             }
 468         }
 469
 470         my ($handles, $handle_list) = _make_gpg_handles(stdin =>IO::Handle::CRLF->new );
 471         my %handle = %$handle_list;
 472
 473         $gnupg->passphrase( $args{'Passphrase'} );
 474
 475         eval {
 476             local $SIG{'CHLD'} = 'DEFAULT';
 477             my $pid = safe_run_child { $gnupg->detach_sign( handles => $handles ) };
 478             $entity->make_multipart( 'mixed', Force => 1 );
 479             {
 480                 local $SIG{'PIPE'} = 'IGNORE';
 481                 $entity->parts(0)->print( $handle{'stdin'} );
 482                 close $handle{'stdin'};
 483             }
 484             waitpid $pid, 0;
 485         };
 486         my $err = $@;
 487         my @signature = readline $handle{'stdout'};
 488         close $handle{'stdout'};
 489
 490         $res{'exit_code'} = $?;
 491         foreach ( qw(stderr logger status) ) {
 492             $res{$_} = do { local $/; readline $handle{$_} };
 493             delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 494             close $handle{$_};
 495         }
 496         $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 497         $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
 498         $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 499         if ( $err || $res{'exit_code'} ) {
 500             $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
 501             return %res;
 502         }
 503
 504         # setup RFC1847(Ch.2.1) requirements
 505         my $protocol = 'application/pgp-signature';
 506         $entity->head->mime_attr( 'Content-Type' => 'multipart/signed' );
 507         $entity->head->mime_attr( 'Content-Type.protocol' => $protocol );
 508         $entity->head->mime_attr( 'Content-Type.micalg'   => 'pgp-'. lc $opt{'digest-algo'} );
 509         $entity->attach(
 510             Type        => $protocol,
 511             Disposition => 'inline',
 512             Data        => \@signature,
 513             Encoding    => '7bit',
 514         );
 515     }
 516     if ( $args{'Encrypt'} ) {
 517         my %seen;
 518         $gnupg->options->push_recipients( $_ ) foreach
 519             map UseKeyForEncryption($_) || $_,
 520             grep !$seen{ $_ }++, map $_->address,
 521             map Email::Address->parse( $entity->head->get( $_ ) ),
 522             qw(To Cc Bcc);
 523
 524         my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
 525         binmode $tmp_fh, ':raw';
 526
 527         my ($handles, $handle_list) = _make_gpg_handles(stdout => $tmp_fh);
 528         my %handle = %$handle_list;
 529         $handles->options( 'stdout'  )->{'direct'} = 1;
 530         $gnupg->passphrase( $args{'Passphrase'} ) if $args{'Sign'};
 531
 532         eval {
 533             local $SIG{'CHLD'} = 'DEFAULT';
 534             my $pid = safe_run_child { $args{'Sign'}
 535                 ? $gnupg->sign_and_encrypt( handles => $handles )
 536                 : $gnupg->encrypt( handles => $handles ) };
 537             $entity->make_multipart( 'mixed', Force => 1 );
 538             {
 539                 local $SIG{'PIPE'} = 'IGNORE';
 540                 $entity->parts(0)->print( $handle{'stdin'} );
 541                 close $handle{'stdin'};
 542             }
 543             waitpid $pid, 0;
 544         };
 545
 546         $res{'exit_code'} = $?;
 547         foreach ( qw(stderr logger status) ) {
 548             $res{$_} = do { local $/; readline $handle{$_} };
 549             delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 550             close $handle{$_};
 551         }
 552         $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 553         $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
 554         $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 555         if ( $@ || $? ) {
 556             $res{'message'} = $@? $@: "gpg exited with error code ". ($? >> 8);
 557             return %res;
 558         }
 559
 560         my $protocol = 'application/pgp-encrypted';
 561         $entity->parts([]);
 562         $entity->head->mime_attr( 'Content-Type' => 'multipart/encrypted' );
 563         $entity->head->mime_attr( 'Content-Type.protocol' => $protocol );
 564         $entity->attach(
 565             Type        => $protocol,
 566             Disposition => 'inline',
 567             Data        => ['Version: 1',''],
 568             Encoding    => '7bit',
 569         );
 570         $entity->attach(
 571             Type        => 'application/octet-stream',
 572             Disposition => 'inline',
 573             Path        => $tmp_fn,
 574             Filename    => '',
 575             Encoding    => '7bit',
 576         );
 577         $entity->parts(-1)->bodyhandle->{'_dirty_hack_to_save_a_ref_tmp_fh'} = $tmp_fh;
 578     }
 579     return %res;
 580 }
 581
 582 sub SignEncryptInline {
 583     my %args = ( @_ );
 584
 585     my $entity = $args{'Entity'};
 586
 587     my %res;
 588     $entity->make_singlepart;
 589     if ( $entity->is_multipart ) {
 590         foreach ( $entity->parts ) {
 591             %res = SignEncryptInline( @_, Entity => $_ );
 592             return %res if $res{'exit_code'};
 593         }
 594         return %res;
 595     }
 596
 597     return _SignEncryptTextInline( @_ )
 598         if $entity->effective_type =~ /^text\//i;
 599
 600     return _SignEncryptAttachmentInline( @_ );
 601 }
 602
 603 sub _SignEncryptTextInline {
 604     my %args = (
 605         Entity => undef,
 606
 607         Sign => 1,
 608         Signer => undef,
 609         Passphrase => undef,
 610
 611         Encrypt => 1,
 612         Recipients => undef,
 613
 614         @_
 615     );
 616     return unless $args{'Sign'} || $args{'Encrypt'};
 617
 618     my $gnupg = new GnuPG::Interface;
 619     my %opt = RT->Config->Get('GnuPGOptions');
 620
 621     # handling passphrase in GnupGOptions
 622     $args{'Passphrase'} = delete $opt{'passphrase'}
 623         if !defined($args{'Passphrase'});
 624
 625     $opt{'digest-algo'} ||= 'SHA1';
 626     $opt{'default_key'} = $args{'Signer'}
 627         if $args{'Sign'} && $args{'Signer'};
 628     $gnupg->options->hash_init(
 629         _PrepareGnuPGOptions( %opt ),
 630         armor => 1,
 631         meta_interactive => 0,
 632     );
 633
 634     if ( $args{'Sign'} && !defined $args{'Passphrase'} ) {
 635         $args{'Passphrase'} = GetPassphrase( Address => $args{'Signer'} );
 636     }
 637
 638     if ( $args{'Encrypt'} ) {
 639         $gnupg->options->push_recipients( $_ ) foreach
 640             map UseKeyForEncryption($_) || $_,
 641             @{ $args{'Recipients'} || [] };
 642     }
 643
 644     my %res;
 645
 646     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
 647     binmode $tmp_fh, ':raw';
 648
 649     my ($handles, $handle_list) = _make_gpg_handles(stdout => $tmp_fh);
 650     my %handle = %$handle_list;
 651
 652     $handles->options( 'stdout'  )->{'direct'} = 1;
 653     $gnupg->passphrase( $args{'Passphrase'} ) if $args{'Sign'};
 654
 655     my $entity = $args{'Entity'};
 656     eval {
 657         local $SIG{'CHLD'} = 'DEFAULT';
 658         my $method = $args{'Sign'} && $args{'Encrypt'}
 659             ? 'sign_and_encrypt'
 660             : ($args{'Sign'}? 'clearsign': 'encrypt');
 661         my $pid = safe_run_child { $gnupg->$method( handles => $handles ) };
 662         {
 663             local $SIG{'PIPE'} = 'IGNORE';
 664             $entity->bodyhandle->print( $handle{'stdin'} );
 665             close $handle{'stdin'};
 666         }
 667         waitpid $pid, 0;
 668     };
 669     $res{'exit_code'} = $?;
 670     my $err = $@;
 671
 672     foreach ( qw(stderr logger status) ) {
 673         $res{$_} = do { local $/; readline $handle{$_} };
 674         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 675         close $handle{$_};
 676     }
 677     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 678     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
 679     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 680     if ( $err || $res{'exit_code'} ) {
 681         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
 682         return %res;
 683     }
 684
 685     $entity->bodyhandle( new MIME::Body::File $tmp_fn );
 686     $entity->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
 687
 688     return %res;
 689 }
 690
 691 sub _SignEncryptAttachmentInline {
 692     my %args = (
 693         Entity => undef,
 694
 695         Sign => 1,
 696         Signer => undef,
 697         Passphrase => undef,
 698
 699         Encrypt => 1,
 700         Recipients => undef,
 701
 702         @_
 703     );
 704     return unless $args{'Sign'} || $args{'Encrypt'};
 705
 706     my $gnupg = new GnuPG::Interface;
 707     my %opt = RT->Config->Get('GnuPGOptions');
 708
 709     # handling passphrase in GnupGOptions
 710     $args{'Passphrase'} = delete $opt{'passphrase'}
 711         if !defined($args{'Passphrase'});
 712
 713     $opt{'digest-algo'} ||= 'SHA1';
 714     $opt{'default_key'} = $args{'Signer'}
 715         if $args{'Sign'} && $args{'Signer'};
 716     $gnupg->options->hash_init(
 717         _PrepareGnuPGOptions( %opt ),
 718         armor => 1,
 719         meta_interactive => 0,
 720     );
 721
 722     if ( $args{'Sign'} && !defined $args{'Passphrase'} ) {
 723         $args{'Passphrase'} = GetPassphrase( Address => $args{'Signer'} );
 724     }
 725
 726     my $entity = $args{'Entity'};
 727     if ( $args{'Encrypt'} ) {
 728         $gnupg->options->push_recipients( $_ ) foreach
 729             map UseKeyForEncryption($_) || $_,
 730             @{ $args{'Recipients'} || [] };
 731     }
 732
 733     my %res;
 734
 735     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
 736     binmode $tmp_fh, ':raw';
 737
 738     my ($handles, $handle_list) = _make_gpg_handles(stdout => $tmp_fh);
 739     my %handle = %$handle_list;
 740     $handles->options( 'stdout'  )->{'direct'} = 1;
 741     $gnupg->passphrase( $args{'Passphrase'} ) if $args{'Sign'};
 742
 743     eval {
 744         local $SIG{'CHLD'} = 'DEFAULT';
 745         my $method = $args{'Sign'} && $args{'Encrypt'}
 746             ? 'sign_and_encrypt'
 747             : ($args{'Sign'}? 'detach_sign': 'encrypt');
 748         my $pid = safe_run_child { $gnupg->$method( handles => $handles ) };
 749         {
 750             local $SIG{'PIPE'} = 'IGNORE';
 751             $entity->bodyhandle->print( $handle{'stdin'} );
 752             close $handle{'stdin'};
 753         }
 754         waitpid $pid, 0;
 755     };
 756     $res{'exit_code'} = $?;
 757     my $err = $@;
 758
 759     foreach ( qw(stderr logger status) ) {
 760         $res{$_} = do { local $/; readline $handle{$_} };
 761         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 762         close $handle{$_};
 763     }
 764     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 765     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
 766     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 767     if ( $err || $res{'exit_code'} ) {
 768         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
 769         return %res;
 770     }
 771
 772     my $filename = $entity->head->recommended_filename || 'no_name';
 773     if ( $args{'Sign'} && !$args{'Encrypt'} ) {
 774         $entity->make_multipart;
 775         $entity->attach(
 776             Type     => 'application/octet-stream',
 777             Path     => $tmp_fn,
 778             Filename => "$filename.sig",
 779             Disposition => 'attachment',
 780         );
 781     } else {
 782         $entity->bodyhandle( new MIME::Body::File $tmp_fn );
 783         $entity->effective_type('application/octet-stream');
 784         $entity->head->mime_attr( $_ => "$filename.pgp" )
 785             foreach (qw(Content-Type.name Content-Disposition.filename));
 786
 787     }
 788     $entity->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
 789
 790     return %res;
 791 }
 792
 793 sub SignEncryptContent {
 794     my %args = (
 795         Content => undef,
 796
 797         Sign => 1,
 798         Signer => undef,
 799         Passphrase => undef,
 800
 801         Encrypt => 1,
 802         Recipients => undef,
 803
 804         @_
 805     );
 806     return unless $args{'Sign'} || $args{'Encrypt'};
 807
 808     my $gnupg = new GnuPG::Interface;
 809     my %opt = RT->Config->Get('GnuPGOptions');
 810
 811     # handling passphrase in GnupGOptions
 812     $args{'Passphrase'} = delete $opt{'passphrase'}
 813         if !defined($args{'Passphrase'});
 814
 815     $opt{'digest-algo'} ||= 'SHA1';
 816     $opt{'default_key'} = $args{'Signer'}
 817         if $args{'Sign'} && $args{'Signer'};
 818     $gnupg->options->hash_init(
 819         _PrepareGnuPGOptions( %opt ),
 820         armor => 1,
 821         meta_interactive => 0,
 822     );
 823
 824     if ( $args{'Sign'} && !defined $args{'Passphrase'} ) {
 825         $args{'Passphrase'} = GetPassphrase( Address => $args{'Signer'} );
 826     }
 827
 828     if ( $args{'Encrypt'} ) {
 829         $gnupg->options->push_recipients( $_ ) foreach
 830             map UseKeyForEncryption($_) || $_,
 831             @{ $args{'Recipients'} || [] };
 832     }
 833
 834     my %res;
 835
 836     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
 837     binmode $tmp_fh, ':raw';
 838
 839     my ($handles, $handle_list) = _make_gpg_handles(stdout => $tmp_fh);
 840     my %handle = %$handle_list;
 841     $handles->options( 'stdout'  )->{'direct'} = 1;
 842     $gnupg->passphrase( $args{'Passphrase'} ) if $args{'Sign'};
 843
 844     eval {
 845         local $SIG{'CHLD'} = 'DEFAULT';
 846         my $method = $args{'Sign'} && $args{'Encrypt'}
 847             ? 'sign_and_encrypt'
 848             : ($args{'Sign'}? 'clearsign': 'encrypt');
 849         my $pid = safe_run_child { $gnupg->$method( handles => $handles ) };
 850         {
 851             local $SIG{'PIPE'} = 'IGNORE';
 852             $handle{'stdin'}->print( ${ $args{'Content'} } );
 853             close $handle{'stdin'};
 854         }
 855         waitpid $pid, 0;
 856     };
 857     $res{'exit_code'} = $?;
 858     my $err = $@;
 859
 860     foreach ( qw(stderr logger status) ) {
 861         $res{$_} = do { local $/; readline $handle{$_} };
 862         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 863         close $handle{$_};
 864     }
 865     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 866     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
 867     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 868     if ( $err || $res{'exit_code'} ) {
 869         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
 870         return %res;
 871     }
 872
 873     ${ $args{'Content'} } = '';
 874     seek $tmp_fh, 0, 0;
 875     while (1) {
 876         my $status = read $tmp_fh, my $buf, 4*1024;
 877         unless ( defined $status ) {
 878             $RT::Logger->crit( "couldn't read message: $!" );
 879         } elsif ( !$status ) {
 880             last;
 881         }
 882         ${ $args{'Content'} } .= $buf;
 883     }
 884
 885     return %res;
 886 }
 887
 888 sub FindProtectedParts {
 889     my %args = ( Entity => undef, CheckBody => 1, @_ );
 890     my $entity = $args{'Entity'};
 891
 892     # inline PGP block, only in singlepart
 893     unless ( $entity->is_multipart ) {
 894         my $io = $entity->open('r');
 895         unless ( $io ) {
 896             $RT::Logger->warning( "Entity of type ". $entity->effective_type ." has no body" );
 897             return ();
 898         }
 899
 900         # Deal with "partitioned" PGP mail, which (contrary to common
 901         # sense) unnecessarily applies a base64 transfer encoding to PGP
 902         # mail (whose content is already base64-encoded).
 903         if ( $entity->bodyhandle->is_encoded and $entity->head->mime_encoding ) {
 904             pipe( my ($read_decoded, $write_decoded) );
 905             my $decoder = MIME::Decoder->new( $entity->head->mime_encoding );
 906             if ($decoder) {
 907                 eval { $decoder->decode($io, $write_decoded) };
 908                 $io = $read_decoded;
 909             }
 910         }
 911
 912         while ( defined($_ = $io->getline) ) {
 913             next unless /^-----BEGIN PGP (SIGNED )?MESSAGE-----/;
 914             my $type = $1? 'signed': 'encrypted';
 915             $RT::Logger->debug("Found $type inline part");
 916             return {
 917                 Type    => $type,
 918                 Format  => 'Inline',
 919                 Data  => $entity,
 920             };
 921         }
 922         $io->close;
 923         return ();
 924     }
 925
 926     # RFC3156, multipart/{signed,encrypted}
 927     if ( ( my $type = $entity->effective_type ) =~ /^multipart\/(?:encrypted|signed)$/ ) {
 928         unless ( $entity->parts == 2 ) {
 929             $RT::Logger->error( "Encrypted or signed entity must has two subparts. Skipped" );
 930             return ();
 931         }
 932
 933         my $protocol = $entity->head->mime_attr( 'Content-Type.protocol' );
 934         unless ( $protocol ) {
 935             $RT::Logger->error( "Entity is '$type', but has no protocol defined. Skipped" );
 936             return ();
 937         }
 938
 939         if ( $type eq 'multipart/encrypted' ) {
 940             unless ( $protocol eq 'application/pgp-encrypted' ) {
 941                 $RT::Logger->info( "Skipping protocol '$protocol', only 'application/pgp-encrypted' is supported" );
 942                 return ();
 943             }
 944             $RT::Logger->debug("Found encrypted according to RFC3156 part");
 945             return {
 946                 Type    => 'encrypted',
 947                 Format  => 'RFC3156',
 948                 Top   => $entity,
 949                 Data  => $entity->parts(1),
 950                 Info    => $entity->parts(0),
 951             };
 952         } else {
 953             unless ( $protocol eq 'application/pgp-signature' ) {
 954                 $RT::Logger->info( "Skipping protocol '$protocol', only 'application/pgp-signature' is supported" );
 955                 return ();
 956             }
 957             $RT::Logger->debug("Found signed according to RFC3156 part");
 958             return {
 959                 Type      => 'signed',
 960                 Format    => 'RFC3156',
 961                 Top     => $entity,
 962                 Data    => $entity->parts(0),
 963                 Signature => $entity->parts(1),
 964             };
 965         }
 966     }
 967
 968     # attachments signed with signature in another part
 969     my @file_indices;
 970     foreach my $i ( 0 .. $entity->parts - 1 ) {
 971         my $part = $entity->parts($i);
 972
 973         # we can not associate a signature within an attachment
 974         # without file names
 975         my $fname = $part->head->recommended_filename;
 976         next unless $fname;
 977
 978         if ( $part->effective_type eq 'application/pgp-signature' ) {
 979             push @file_indices, $i;
 980         }
 981         elsif ( $fname =~ /\.sig$/i && $part->effective_type eq 'application/octet-stream' ) {
 982             push @file_indices, $i;
 983         }
 984     }
 985
 986     my (@res, %skip);
 987     foreach my $i ( @file_indices ) {
 988         my $sig_part = $entity->parts($i);
 989         $skip{"$sig_part"}++;
 990         my $sig_name = $sig_part->head->recommended_filename;
 991         my ($file_name) = $sig_name =~ /^(.*?)(?:\.sig)?$/;
 992
 993         my ($data_part_idx) =
 994             grep $file_name eq ($entity->parts($_)->head->recommended_filename||''),
 995             grep $sig_part  ne  $entity->parts($_),
 996                 0 .. $entity->parts - 1;
 997         unless ( defined $data_part_idx ) {
 998             $RT::Logger->error("Found $sig_name attachment, but didn't find $file_name");
 999             next;
1000         }
1001         my $data_part_in = $entity->parts($data_part_idx);
1002
1003         $skip{"$data_part_in"}++;
1004         $RT::Logger->debug("Found signature (in '$sig_name') of attachment '$file_name'");
1005         push @res, {
1006             Type      => 'signed',
1007             Format    => 'Attachment',
1008             Top       => $entity,
1009             Data      => $data_part_in,
1010             Signature => $sig_part,
1011         };
1012     }
1013
1014     # attachments with inline encryption
1015     my @encrypted_indices =
1016         grep {($entity->parts($_)->head->recommended_filename || '') =~ /\.pgp$/}
1017             0 .. $entity->parts - 1;
1018
1019     foreach my $i ( @encrypted_indices ) {
1020         my $part = $entity->parts($i);
1021         $skip{"$part"}++;
1022         $RT::Logger->debug("Found encrypted attachment '". $part->head->recommended_filename ."'");
1023         push @res, {
1024             Type      => 'encrypted',
1025             Format    => 'Attachment',
1026             Top     => $entity,
1027             Data    => $part,
1028         };
1029     }
1030
1031     push @res, FindProtectedParts( Entity => $_ )
1032         foreach grep !$skip{"$_"}, $entity->parts;
1033
1034     return @res;
1035 }
1036
1037 =head2 VerifyDecrypt Entity => undef, [ Detach => 1, Passphrase => undef, SetStatus => 1 ]
1038
1039 =cut
1040
1041 sub VerifyDecrypt {
1042     my %args = (
1043         Entity    => undef,
1044         Detach    => 1,
1045         SetStatus => 1,
1046         AddStatus => 0,
1047         @_
1048     );
1049     my @protected = FindProtectedParts( Entity => $args{'Entity'} );
1050     my @res;
1051     # XXX: detaching may brake nested signatures
1052     foreach my $item( grep $_->{'Type'} eq 'signed', @protected ) {
1053         my $status_on;
1054         if ( $item->{'Format'} eq 'RFC3156' ) {
1055             push @res, { VerifyRFC3156( %$item, SetStatus => $args{'SetStatus'} ) };
1056             if ( $args{'Detach'} ) {
1057                 $item->{'Top'}->parts( [ $item->{'Data'} ] );
1058                 $item->{'Top'}->make_singlepart;
1059             }
1060             $status_on = $item->{'Top'};
1061         } elsif ( $item->{'Format'} eq 'Inline' ) {
1062             push @res, { VerifyInline( %$item ) };
1063             $status_on = $item->{'Data'};
1064         } elsif ( $item->{'Format'} eq 'Attachment' ) {
1065             push @res, { VerifyAttachment( %$item ) };
1066             if ( $args{'Detach'} ) {
1067                 $item->{'Top'}->parts( [
1068                     grep "$_" ne $item->{'Signature'}, $item->{'Top'}->parts
1069                 ] );
1070                 $item->{'Top'}->make_singlepart;
1071             }
1072             $status_on = $item->{'Data'};
1073         }
1074         if ( $args{'SetStatus'} || $args{'AddStatus'} ) {
1075             my $method = $args{'AddStatus'} ? 'add' : 'set';
1076             # Let the header be modified so continuations are handled
1077             my $modify = $status_on->head->modify;
1078             $status_on->head->modify(1);
1079             $status_on->head->$method(
1080                 'X-RT-GnuPG-Status' => $res[-1]->{'status'}
1081             );
1082             $status_on->head->modify($modify);
1083         }
1084     }
1085     foreach my $item( grep $_->{'Type'} eq 'encrypted', @protected ) {
1086         my $status_on;
1087         if ( $item->{'Format'} eq 'RFC3156' ) {
1088             push @res, { DecryptRFC3156( %$item ) };
1089             $status_on = $item->{'Top'};
1090         } elsif ( $item->{'Format'} eq 'Inline' ) {
1091             push @res, { DecryptInline( %$item ) };
1092             $status_on = $item->{'Data'};
1093         } elsif ( $item->{'Format'} eq 'Attachment' ) {
1094             push @res, { DecryptAttachment( %$item ) };
1095             $status_on = $item->{'Data'};
1096         }
1097         if ( $args{'SetStatus'} || $args{'AddStatus'} ) {
1098             my $method = $args{'AddStatus'} ? 'add' : 'set';
1099             # Let the header be modified so continuations are handled
1100             my $modify = $status_on->head->modify;
1101             $status_on->head->modify(1);
1102             $status_on->head->$method(
1103                 'X-RT-GnuPG-Status' => $res[-1]->{'status'}
1104             );
1105             $status_on->head->modify($modify);
1106         }
1107     }
1108     return @res;
1109 }
1110
1111 sub VerifyInline { return DecryptInline( @_ ) }
1112
1113 sub VerifyAttachment {
1114     my %args = ( Data => undef, Signature => undef, Top => undef, @_ );
1115
1116     my $gnupg = new GnuPG::Interface;
1117     my %opt = RT->Config->Get('GnuPGOptions');
1118     $opt{'digest-algo'} ||= 'SHA1';
1119     $gnupg->options->hash_init(
1120         _PrepareGnuPGOptions( %opt ),
1121         meta_interactive => 0,
1122     );
1123
1124     foreach ( $args{'Data'}, $args{'Signature'} ) {
1125         next unless $_->bodyhandle->is_encoded;
1126
1127         require RT::EmailParser;
1128         RT::EmailParser->_DecodeBody($_);
1129     }
1130
1131     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1132     binmode $tmp_fh, ':raw';
1133     $args{'Data'}->bodyhandle->print( $tmp_fh );
1134     $tmp_fh->flush;
1135
1136     my ($handles, $handle_list) = _make_gpg_handles();
1137     my %handle = %$handle_list;
1138
1139     my %res;
1140     eval {
1141         local $SIG{'CHLD'} = 'DEFAULT';
1142         my $pid = safe_run_child { $gnupg->verify(
1143             handles => $handles, command_args => [ '-', $tmp_fn ]
1144         ) };
1145         {
1146             local $SIG{'PIPE'} = 'IGNORE';
1147             $args{'Signature'}->bodyhandle->print( $handle{'stdin'} );
1148             close $handle{'stdin'};
1149         }
1150         waitpid $pid, 0;
1151     };
1152     $res{'exit_code'} = $?;
1153     foreach ( qw(stderr logger status) ) {
1154         $res{$_} = do { local $/; readline $handle{$_} };
1155         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1156         close $handle{$_};
1157     }
1158     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1159     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
1160     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1161     if ( $@ || $? ) {
1162         $res{'message'} = $@? $@: "gpg exitted with error code ". ($? >> 8);
1163     }
1164     return %res;
1165 }
1166
1167 sub VerifyRFC3156 {
1168     my %args = ( Data => undef, Signature => undef, Top => undef, @_ );
1169
1170     my $gnupg = new GnuPG::Interface;
1171     my %opt = RT->Config->Get('GnuPGOptions');
1172     $opt{'digest-algo'} ||= 'SHA1';
1173     $gnupg->options->hash_init(
1174         _PrepareGnuPGOptions( %opt ),
1175         meta_interactive => 0,
1176     );
1177
1178     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1179     binmode $tmp_fh, ':raw:eol(CRLF?)';
1180     $args{'Data'}->print( $tmp_fh );
1181     $tmp_fh->flush;
1182
1183     my ($handles, $handle_list) = _make_gpg_handles();
1184     my %handle = %$handle_list;
1185
1186     my %res;
1187     eval {
1188         local $SIG{'CHLD'} = 'DEFAULT';
1189         my $pid = safe_run_child { $gnupg->verify(
1190             handles => $handles, command_args => [ '-', $tmp_fn ]
1191         ) };
1192         {
1193             local $SIG{'PIPE'} = 'IGNORE';
1194             $args{'Signature'}->bodyhandle->print( $handle{'stdin'} );
1195             close $handle{'stdin'};
1196         }
1197         waitpid $pid, 0;
1198     };
1199     $res{'exit_code'} = $?;
1200     foreach ( qw(stderr logger status) ) {
1201         $res{$_} = do { local $/; readline $handle{$_} };
1202         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1203         close $handle{$_};
1204     }
1205     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1206     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
1207     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1208     if ( $@ || $? ) {
1209         $res{'message'} = $@? $@: "gpg exitted with error code ". ($? >> 8);
1210     }
1211     return %res;
1212 }
1213
1214 sub DecryptRFC3156 {
1215     my %args = (
1216         Data => undef,
1217         Info => undef,
1218         Top => undef,
1219         Passphrase => undef,
1220         @_
1221     );
1222
1223     my $gnupg = new GnuPG::Interface;
1224     my %opt = RT->Config->Get('GnuPGOptions');
1225
1226     # handling passphrase in GnupGOptions
1227     $args{'Passphrase'} = delete $opt{'passphrase'}
1228         if !defined($args{'Passphrase'});
1229
1230     $opt{'digest-algo'} ||= 'SHA1';
1231     $gnupg->options->hash_init(
1232         _PrepareGnuPGOptions( %opt ),
1233         meta_interactive => 0,
1234     );
1235
1236     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1237         require RT::EmailParser;
1238         RT::EmailParser->_DecodeBody($args{'Data'});
1239     }
1240
1241     $args{'Passphrase'} = GetPassphrase()
1242         unless defined $args{'Passphrase'};
1243
1244     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1245     binmode $tmp_fh, ':raw';
1246
1247     my ($handles, $handle_list) = _make_gpg_handles(stdout => $tmp_fh);
1248     my %handle = %$handle_list;
1249     $handles->options( 'stdout' )->{'direct'} = 1;
1250
1251     my %res;
1252     eval {
1253         local $SIG{'CHLD'} = 'DEFAULT';
1254         $gnupg->passphrase( $args{'Passphrase'} );
1255         my $pid = safe_run_child { $gnupg->decrypt( handles => $handles ) };
1256         {
1257             local $SIG{'PIPE'} = 'IGNORE';
1258             $args{'Data'}->bodyhandle->print( $handle{'stdin'} );
1259             close $handle{'stdin'}
1260         }
1261
1262         waitpid $pid, 0;
1263     };
1264     $res{'exit_code'} = $?;
1265     foreach ( qw(stderr logger status) ) {
1266         $res{$_} = do { local $/; readline $handle{$_} };
1267         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1268         close $handle{$_};
1269     }
1270     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1271     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
1272     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1273
1274     # if the decryption is fine but the signature is bad, then without this
1275     # status check we lose the decrypted text
1276     # XXX: add argument to the function to control this check
1277     if ( $res{'status'} !~ /DECRYPTION_OKAY/ ) {
1278         if ( $@ || $? ) {
1279             $res{'message'} = $@? $@: "gpg exitted with error code ". ($? >> 8);
1280             return %res;
1281         }
1282     }
1283
1284     seek $tmp_fh, 0, 0;
1285     my $parser = new RT::EmailParser;
1286     my $decrypted = $parser->ParseMIMEEntityFromFileHandle( $tmp_fh, 0 );
1287     $decrypted->{'__store_link_to_object_to_avoid_early_cleanup'} = $parser;
1288     $args{'Top'}->parts( [] );
1289     $args{'Top'}->add_part( $decrypted );
1290     $args{'Top'}->make_singlepart;
1291     return %res;
1292 }
1293
1294 sub DecryptInline {
1295     my %args = (
1296         Data => undef,
1297         Passphrase => undef,
1298         @_
1299     );
1300
1301     my $gnupg = new GnuPG::Interface;
1302     my %opt = RT->Config->Get('GnuPGOptions');
1303
1304     # handling passphrase in GnuPGOptions
1305     $args{'Passphrase'} = delete $opt{'passphrase'}
1306         if !defined($args{'Passphrase'});
1307
1308     $opt{'digest-algo'} ||= 'SHA1';
1309     $gnupg->options->hash_init(
1310         _PrepareGnuPGOptions( %opt ),
1311         meta_interactive => 0,
1312     );
1313
1314     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1315         require RT::EmailParser;
1316         RT::EmailParser->_DecodeBody($args{'Data'});
1317     }
1318
1319     $args{'Passphrase'} = GetPassphrase()
1320         unless defined $args{'Passphrase'};
1321
1322     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1323     binmode $tmp_fh, ':raw';
1324
1325     my $io = $args{'Data'}->open('r');
1326     unless ( $io ) {
1327         die "Entity has no body, never should happen";
1328     }
1329
1330     my %res;
1331
1332     my ($had_literal, $in_block) = ('', 0);
1333     my ($block_fh, $block_fn) = File::Temp::tempfile( UNLINK => 1 );
1334     binmode $block_fh, ':raw';
1335
1336     while ( defined(my $str = $io->getline) ) {
1337         if ( $in_block && $str =~ /^-----END PGP (?:MESSAGE|SIGNATURE)-----/ ) {
1338             print $block_fh $str;
1339             $in_block--;
1340             next if $in_block > 0;
1341
1342             seek $block_fh, 0, 0;
1343
1344             my ($res_fh, $res_fn);
1345             ($res_fh, $res_fn, %res) = _DecryptInlineBlock(
1346                 %args,
1347                 GnuPG => $gnupg,
1348                 BlockHandle => $block_fh,
1349             );
1350             return %res unless $res_fh;
1351
1352             print $tmp_fh "-----BEGIN OF PGP PROTECTED PART-----\n" if $had_literal;
1353             while (my $buf = <$res_fh> ) {
1354                 print $tmp_fh $buf;
1355             }
1356             print $tmp_fh "-----END OF PART-----\n" if $had_literal;
1357
1358             ($block_fh, $block_fn) = File::Temp::tempfile( UNLINK => 1 );
1359             binmode $block_fh, ':raw';
1360             $in_block = 0;
1361         }
1362         elsif ( $str =~ /^-----BEGIN PGP (SIGNED )?MESSAGE-----/ ) {
1363             $in_block++;
1364             print $block_fh $str;
1365         }
1366         elsif ( $in_block ) {
1367             print $block_fh $str;
1368         }
1369         else {
1370             print $tmp_fh $str;
1371             $had_literal = 1 if /\S/s;
1372         }
1373     }
1374     $io->close;
1375
1376     if ( $in_block ) {
1377         # we're still in a block, this not bad not good. let's try to
1378         # decrypt what we have, it can be just missing -----END PGP...
1379         seek $block_fh, 0, 0;
1380
1381         my ($res_fh, $res_fn);
1382         ($res_fh, $res_fn, %res) = _DecryptInlineBlock(
1383             %args,
1384             GnuPG => $gnupg,
1385             BlockHandle => $block_fh,
1386         );
1387         return %res unless $res_fh;
1388
1389         print $tmp_fh "-----BEGIN OF PGP PROTECTED PART-----\n" if $had_literal;
1390         while (my $buf = <$res_fh> ) {
1391             print $tmp_fh $buf;
1392         }
1393         print $tmp_fh "-----END OF PART-----\n" if $had_literal;
1394     }
1395
1396     seek $tmp_fh, 0, 0;
1397     $args{'Data'}->bodyhandle( new MIME::Body::File $tmp_fn );
1398     $args{'Data'}->{'__store_tmp_handle_to_avoid_early_cleanup'} = $tmp_fh;
1399     return %res;
1400 }
1401
1402 sub _DecryptInlineBlock {
1403     my %args = (
1404         GnuPG => undef,
1405         BlockHandle => undef,
1406         Passphrase => undef,
1407         @_
1408     );
1409     my $gnupg = $args{'GnuPG'};
1410
1411     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1412     binmode $tmp_fh, ':raw';
1413
1414     my ($handles, $handle_list) = _make_gpg_handles(
1415             stdin => $args{'BlockHandle'},
1416             stdout => $tmp_fh);
1417     my %handle = %$handle_list;
1418     $handles->options( 'stdout' )->{'direct'} = 1;
1419     $handles->options( 'stdin' )->{'direct'} = 1;
1420
1421     my %res;
1422     eval {
1423         local $SIG{'CHLD'} = 'DEFAULT';
1424         $gnupg->passphrase( $args{'Passphrase'} );
1425         my $pid = safe_run_child { $gnupg->decrypt( handles => $handles ) };
1426         waitpid $pid, 0;
1427     };
1428     $res{'exit_code'} = $?;
1429     foreach ( qw(stderr logger status) ) {
1430         $res{$_} = do { local $/; readline $handle{$_} };
1431         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1432         close $handle{$_};
1433     }
1434     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1435     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
1436     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1437
1438     # if the decryption is fine but the signature is bad, then without this
1439     # status check we lose the decrypted text
1440     # XXX: add argument to the function to control this check
1441     if ( $res{'status'} !~ /DECRYPTION_OKAY/ ) {
1442         if ( $@ || $? ) {
1443             $res{'message'} = $@? $@: "gpg exitted with error code ". ($? >> 8);
1444             return (undef, undef, %res);
1445         }
1446     }
1447
1448     seek $tmp_fh, 0, 0;
1449     return ($tmp_fh, $tmp_fn, %res);
1450 }
1451
1452 sub DecryptAttachment {
1453     my %args = (
1454         Top  => undef,
1455         Data => undef,
1456         Passphrase => undef,
1457         @_
1458     );
1459
1460     my $gnupg = new GnuPG::Interface;
1461     my %opt = RT->Config->Get('GnuPGOptions');
1462
1463     # handling passphrase in GnuPGOptions
1464     $args{'Passphrase'} = delete $opt{'passphrase'}
1465         if !defined($args{'Passphrase'});
1466
1467     $opt{'digest-algo'} ||= 'SHA1';
1468     $gnupg->options->hash_init(
1469         _PrepareGnuPGOptions( %opt ),
1470         meta_interactive => 0,
1471     );
1472
1473     if ( $args{'Data'}->bodyhandle->is_encoded ) {
1474         require RT::EmailParser;
1475         RT::EmailParser->_DecodeBody($args{'Data'});
1476     }
1477
1478     $args{'Passphrase'} = GetPassphrase()
1479         unless defined $args{'Passphrase'};
1480
1481     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1482     binmode $tmp_fh, ':raw';
1483     $args{'Data'}->bodyhandle->print( $tmp_fh );
1484     seek $tmp_fh, 0, 0;
1485
1486     my ($res_fh, $res_fn, %res) = _DecryptInlineBlock(
1487         %args,
1488         GnuPG => $gnupg,
1489         BlockHandle => $tmp_fh,
1490     );
1491     return %res unless $res_fh;
1492
1493     $args{'Data'}->bodyhandle( new MIME::Body::File $res_fn );
1494     $args{'Data'}->{'__store_tmp_handle_to_avoid_early_cleanup'} = $res_fh;
1495
1496     my $filename = $args{'Data'}->head->recommended_filename;
1497     $filename =~ s/\.pgp$//i;
1498     $args{'Data'}->head->mime_attr( $_ => $filename )
1499         foreach (qw(Content-Type.name Content-Disposition.filename));
1500
1501     return %res;
1502 }
1503
1504 sub DecryptContent {
1505     my %args = (
1506         Content => undef,
1507         Passphrase => undef,
1508         @_
1509     );
1510
1511     my $gnupg = new GnuPG::Interface;
1512     my %opt = RT->Config->Get('GnuPGOptions');
1513
1514     # handling passphrase in GnupGOptions
1515     $args{'Passphrase'} = delete $opt{'passphrase'}
1516         if !defined($args{'Passphrase'});
1517
1518     $opt{'digest-algo'} ||= 'SHA1';
1519     $gnupg->options->hash_init(
1520         _PrepareGnuPGOptions( %opt ),
1521         meta_interactive => 0,
1522     );
1523
1524     $args{'Passphrase'} = GetPassphrase()
1525         unless defined $args{'Passphrase'};
1526
1527     my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
1528     binmode $tmp_fh, ':raw';
1529
1530     my ($handles, $handle_list) = _make_gpg_handles(
1531             stdout => $tmp_fh);
1532     my %handle = %$handle_list;
1533     $handles->options( 'stdout' )->{'direct'} = 1;
1534
1535     my %res;
1536     eval {
1537         local $SIG{'CHLD'} = 'DEFAULT';
1538         $gnupg->passphrase( $args{'Passphrase'} );
1539         my $pid = safe_run_child { $gnupg->decrypt( handles => $handles ) };
1540         {
1541             local $SIG{'PIPE'} = 'IGNORE';
1542             print { $handle{'stdin'} } ${ $args{'Content'} };
1543             close $handle{'stdin'};
1544         }
1545
1546         waitpid $pid, 0;
1547     };
1548     $res{'exit_code'} = $?;
1549     foreach ( qw(stderr logger status) ) {
1550         $res{$_} = do { local $/; readline $handle{$_} };
1551         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1552         close $handle{$_};
1553     }
1554     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1555     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
1556     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1557
1558     # if the decryption is fine but the signature is bad, then without this
1559     # status check we lose the decrypted text
1560     # XXX: add argument to the function to control this check
1561     if ( $res{'status'} !~ /DECRYPTION_OKAY/ ) {
1562         if ( $@ || $? ) {
1563             $res{'message'} = $@? $@: "gpg exitted with error code ". ($? >> 8);
1564             return %res;
1565         }
1566     }
1567
1568     ${ $args{'Content'} } = '';
1569     seek $tmp_fh, 0, 0;
1570     while (1) {
1571         my $status = read $tmp_fh, my $buf, 4*1024;
1572         unless ( defined $status ) {
1573             $RT::Logger->crit( "couldn't read message: $!" );
1574         } elsif ( !$status ) {
1575             last;
1576         }
1577         ${ $args{'Content'} } .= $buf;
1578     }
1579
1580     return %res;
1581 }
1582
1583 =head2 GetPassphrase [ Address => undef ]
1584
1585 Returns passphrase, called whenever it's required with Address as a named argument.
1586
1587 =cut
1588
1589 sub GetPassphrase {
1590     my %args = ( Address => undef, @_ );
1591     return 'test';
1592 }
1593
1594 =head2 ParseStatus
1595
1596 Takes a string containing output of gnupg status stream. Parses it and returns
1597 array of hashes. Each element of array is a hash ref and represents line or
1598 group of lines in the status message.
1599
1600 All hashes have Operation, Status and Message elements.
1601
1602 =over
1603
1604 =item Operation
1605
1606 Classification of operations gnupg performs. Now we have support
1607 for Sign, Encrypt, Decrypt, Verify, PassphraseCheck, RecipientsCheck and Data
1608 values.
1609
1610 =item Status
1611
1612 Informs about success. Value is 'DONE' on success, other values means that
1613 an operation failed, for example 'ERROR', 'BAD', 'MISSING' and may be other.
1614
1615 =item Message
1616
1617 User friendly message.
1618
1619 =back
1620
1621 This parser is based on information from GnuPG distribution, see also
1622 F<docs/design_docs/gnupg_details_on_output_formats> in the RT distribution.
1623
1624 =cut
1625
1626 my %REASON_CODE_TO_TEXT = (
1627     NODATA => {
1628         1 => "No armored data",
1629         2 => "Expected a packet, but did not found one",
1630         3 => "Invalid packet found",
1631         4 => "Signature expected, but not found",
1632     },
1633     INV_RECP => {
1634         0 => "No specific reason given",
1635         1 => "Not Found",
1636         2 => "Ambigious specification",
1637         3 => "Wrong key usage",
1638         4 => "Key revoked",
1639         5 => "Key expired",
1640         6 => "No CRL known",
1641         7 => "CRL too old",
1642         8 => "Policy mismatch",
1643         9 => "Not a secret key",
1644         10 => "Key not trusted",
1645     },
1646     ERRSIG => {
1647         0 => 'not specified',
1648         4 => 'unknown algorithm',
1649         9 => 'missing public key',
1650     },
1651 );
1652
1653 sub ReasonCodeToText {
1654     my $keyword = shift;
1655     my $code = shift;
1656     return $REASON_CODE_TO_TEXT{ $keyword }{ $code }
1657         if exists $REASON_CODE_TO_TEXT{ $keyword }{ $code };
1658     return 'unknown';
1659 }
1660
1661 my %simple_keyword = (
1662     NO_RECP => {
1663         Operation => 'RecipientsCheck',
1664         Status    => 'ERROR',
1665         Message   => 'No recipients',
1666     },
1667     UNEXPECTED => {
1668         Operation => 'Data',
1669         Status    => 'ERROR',
1670         Message   => 'Unexpected data has been encountered',
1671     },
1672     BADARMOR => {
1673         Operation => 'Data',
1674         Status    => 'ERROR',
1675         Message   => 'The ASCII armor is corrupted',
1676     },
1677 );
1678
1679 # keywords we parse
1680 my %parse_keyword = map { $_ => 1 } qw(
1681     USERID_HINT
1682     SIG_CREATED GOODSIG BADSIG ERRSIG
1683     END_ENCRYPTION
1684     DECRYPTION_FAILED DECRYPTION_OKAY
1685     BAD_PASSPHRASE GOOD_PASSPHRASE
1686     NO_SECKEY NO_PUBKEY
1687     NO_RECP INV_RECP NODATA UNEXPECTED
1688 );
1689
1690 # keywords we ignore without any messages as we parse them using other
1691 # keywords as starting point or just ignore as they are useless for us
1692 my %ignore_keyword = map { $_ => 1 } qw(
1693     NEED_PASSPHRASE MISSING_PASSPHRASE BEGIN_SIGNING PLAINTEXT PLAINTEXT_LENGTH
1694     BEGIN_ENCRYPTION SIG_ID VALIDSIG
1695     ENC_TO BEGIN_DECRYPTION END_DECRYPTION GOODMDC
1696     TRUST_UNDEFINED TRUST_NEVER TRUST_MARGINAL TRUST_FULLY TRUST_ULTIMATE
1697     DECRYPTION_INFO
1698 );
1699
1700 sub ParseStatus {
1701     my $status = shift;
1702     return () unless $status;
1703
1704     my @status;
1705     while ( $status =~ /\[GNUPG:\]\s*(.*?)(?=\[GNUPG:\]|\z)/igms ) {
1706         push @status, $1; $status[-1] =~ s/\s+/ /g; $status[-1] =~ s/\s+$//;
1707     }
1708     $status = join "\n", @status;
1709     study $status;
1710
1711     my @res;
1712     my (%user_hint, $latest_user_main_key);
1713     for ( my $i = 0; $i < @status; $i++ ) {
1714         my $line = $status[$i];
1715         my ($keyword, $args) = ($line =~ /^(\S+)\s*(.*)$/s);
1716         if ( $simple_keyword{ $keyword } ) {
1717             push @res, $simple_keyword{ $keyword };
1718             $res[-1]->{'Keyword'} = $keyword;
1719             next;
1720         }
1721         unless ( $parse_keyword{ $keyword } ) {
1722             $RT::Logger->warning("Skipped $keyword") unless $ignore_keyword{ $keyword };
1723             next;
1724         }
1725
1726         if ( $keyword eq 'USERID_HINT' ) {
1727             my %tmp = _ParseUserHint($status, $line);
1728             $latest_user_main_key = $tmp{'MainKey'};
1729             if ( $user_hint{ $tmp{'MainKey'} } ) {
1730                 while ( my ($k, $v) = each %tmp ) {
1731                     $user_hint{ $tmp{'MainKey'} }->{$k} = $v;
1732                 }
1733             } else {
1734                 $user_hint{ $tmp{'MainKey'} } = \%tmp;
1735             }
1736             next;
1737         }
1738         elsif ( $keyword eq 'BAD_PASSPHRASE' || $keyword eq 'GOOD_PASSPHRASE' ) {
1739             my $key_id = $args;
1740             my %res = (
1741                 Operation => 'PassphraseCheck',
1742                 Status    => $keyword eq 'BAD_PASSPHRASE'? 'BAD' : 'DONE',
1743                 Key       => $key_id,
1744             );
1745             $res{'Status'} = 'MISSING' if $status[ $i - 1 ] =~ /^MISSING_PASSPHRASE/;
1746             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1747                 next unless $line =~ /^NEED_PASSPHRASE\s+(\S+)\s+(\S+)\s+(\S+)/;
1748                 next if $key_id && $2 ne $key_id;
1749                 @res{'MainKey', 'Key', 'KeyType'} = ($1, $2, $3);
1750                 last;
1751             }
1752             $res{'Message'} = ucfirst( lc( $res{'Status'} eq 'DONE'? 'GOOD': $res{'Status'} ) ) .' passphrase';
1753             $res{'User'} = ( $user_hint{ $res{'MainKey'} } ||= {} ) if $res{'MainKey'};
1754             if ( exists $res{'User'}->{'EmailAddress'} ) {
1755                 $res{'Message'} .= ' for '. $res{'User'}->{'EmailAddress'};
1756             } else {
1757                 $res{'Message'} .= " for '0x$key_id'";
1758             }
1759             push @res, \%res;
1760         }
1761         elsif ( $keyword eq 'END_ENCRYPTION' ) {
1762             my %res = (
1763                 Operation => 'Encrypt',
1764                 Status    => 'DONE',
1765                 Message   => 'Data has been encrypted',
1766             );
1767             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1768                 next unless $line =~ /^BEGIN_ENCRYPTION\s+(\S+)\s+(\S+)/;
1769                 @res{'MdcMethod', 'SymAlgo'} = ($1, $2);
1770                 last;
1771             }
1772             push @res, \%res;
1773         }
1774         elsif ( $keyword eq 'DECRYPTION_FAILED' || $keyword eq 'DECRYPTION_OKAY' ) {
1775             my %res = ( Operation => 'Decrypt' );
1776             @res{'Status', 'Message'} =
1777                 $keyword eq 'DECRYPTION_FAILED'
1778                 ? ('ERROR', 'Decryption failed')
1779                 : ('DONE',  'Decryption process succeeded');
1780
1781             foreach my $line ( reverse @status[ 0 .. $i-1 ] ) {
1782                 next unless $line =~ /^ENC_TO\s+(\S+)\s+(\S+)\s+(\S+)/;
1783                 my ($key, $alg, $key_length) = ($1, $2, $3);
1784
1785                 my %encrypted_to = (
1786                     Message   => "The message is encrypted to '0x$key'",
1787                     User      => ( $user_hint{ $key } ||= {} ),
1788                     Key       => $key,
1789                     KeyLength => $key_length,
1790                     Algorithm => $alg,
1791                 );
1792
1793                 push @{ $res{'EncryptedTo'} ||= [] }, \%encrypted_to;
1794             }
1795
1796             push @res, \%res;
1797         }
1798         elsif ( $keyword eq 'NO_SECKEY' || $keyword eq 'NO_PUBKEY' ) {
1799             my ($key) = split /\s+/, $args;
1800             my $type = $keyword eq 'NO_SECKEY'? 'secret': 'public';
1801             my %res = (
1802                 Operation => 'KeyCheck',
1803                 Status    => 'MISSING',
1804                 Message   => ucfirst( $type ) ." key '0x$key' is not available",
1805                 Key       => $key,
1806                 KeyType   => $type,
1807             );
1808             $res{'User'} = ( $user_hint{ $key } ||= {} );
1809             $res{'User'}{ ucfirst( $type ). 'KeyMissing' } = 1;
1810             push @res, \%res;
1811         }
1812         # GOODSIG, BADSIG, VALIDSIG, TRUST_*
1813         elsif ( $keyword eq 'GOODSIG' ) {
1814             my %res = (
1815                 Operation  => 'Verify',
1816                 Status     => 'DONE',
1817                 Message    => 'The signature is good',
1818             );
1819             @res{qw(Key UserString)} = split /\s+/, $args, 2;
1820             $res{'Message'} .= ', signed by '. $res{'UserString'};
1821
1822             foreach my $line ( @status[ $i .. $#status ] ) {
1823                 next unless $line =~ /^TRUST_(\S+)/;
1824                 $res{'Trust'} = $1;
1825                 last;
1826             }
1827             $res{'Message'} .= ', trust level is '. lc( $res{'Trust'} || 'unknown');
1828
1829             foreach my $line ( @status[ $i .. $#status ] ) {
1830                 next unless $line =~ /^VALIDSIG\s+(.*)/;
1831                 @res{ qw(
1832                     Fingerprint
1833                     CreationDate
1834                     Timestamp
1835                     ExpireTimestamp
1836                     Version
1837                     Reserved
1838                     PubkeyAlgo
1839                     HashAlgo
1840                     Class
1841                     PKFingerprint
1842                     Other
1843                 ) } = split /\s+/, $1, 10;
1844                 last;
1845             }
1846             push @res, \%res;
1847         }
1848         elsif ( $keyword eq 'BADSIG' ) {
1849             my %res = (
1850                 Operation  => 'Verify',
1851                 Status     => 'BAD',
1852                 Message    => 'The signature has not been verified okay',
1853             );
1854             @res{qw(Key UserString)} = split /\s+/, $args, 2;
1855             push @res, \%res;
1856         }
1857         elsif ( $keyword eq 'ERRSIG' ) {
1858             my %res = (
1859                 Operation => 'Verify',
1860                 Status    => 'ERROR',
1861                 Message   => 'Not possible to check the signature',
1862             );
1863             @res{qw(Key PubkeyAlgo HashAlgo Class Timestamp ReasonCode Other)}
1864                 = split /\s+/, $args, 7;
1865
1866             $res{'Reason'} = ReasonCodeToText( $keyword, $res{'ReasonCode'} );
1867             $res{'Message'} .= ", the reason is ". $res{'Reason'};
1868
1869             push @res, \%res;
1870         }
1871         elsif ( $keyword eq 'SIG_CREATED' ) {
1872             # SIG_CREATED <type> <pubkey algo> <hash algo> <class> <timestamp> <key fpr>
1873             my @props = split /\s+/, $args;
1874             push @res, {
1875                 Operation      => 'Sign',
1876                 Status         => 'DONE',
1877                 Message        => "Signed message",
1878                 Type           => $props[0],
1879                 PubKeyAlgo     => $props[1],
1880                 HashKeyAlgo    => $props[2],
1881                 Class          => $props[3],
1882                 Timestamp      => $props[4],
1883                 KeyFingerprint => $props[5],
1884                 User           => $user_hint{ $latest_user_main_key },
1885             };
1886             $res[-1]->{Message} .= ' by '. $user_hint{ $latest_user_main_key }->{'EmailAddress'}
1887                 if $user_hint{ $latest_user_main_key };
1888         }
1889         elsif ( $keyword eq 'INV_RECP' ) {
1890             my ($rcode, $recipient) = split /\s+/, $args, 2;
1891             my $reason = ReasonCodeToText( $keyword, $rcode );
1892             push @res, {
1893                 Operation  => 'RecipientsCheck',
1894                 Status     => 'ERROR',
1895                 Message    => "Recipient '$recipient' is unusable, the reason is '$reason'",
1896                 Recipient  => $recipient,
1897                 ReasonCode => $rcode,
1898                 Reason     => $reason,
1899             };
1900         }
1901         elsif ( $keyword eq 'NODATA' ) {
1902             my $rcode = (split /\s+/, $args)[0];
1903             my $reason = ReasonCodeToText( $keyword, $rcode );
1904             push @res, {
1905                 Operation  => 'Data',
1906                 Status     => 'ERROR',
1907                 Message    => "No data has been found. The reason is '$reason'",
1908                 ReasonCode => $rcode,
1909                 Reason     => $reason,
1910             };
1911         }
1912         else {
1913             $RT::Logger->warning("Keyword $keyword is unknown");
1914             next;
1915         }
1916         $res[-1]{'Keyword'} = $keyword if @res && !$res[-1]{'Keyword'};
1917     }
1918     return @res;
1919 }
1920
1921 sub _ParseUserHint {
1922     my ($status, $hint) = (@_);
1923     my ($main_key_id, $user_str) = ($hint =~ /^USERID_HINT\s+(\S+)\s+(.*)$/);
1924     return () unless $main_key_id;
1925     return (
1926         MainKey      => $main_key_id,
1927         String       => $user_str,
1928         EmailAddress => (map $_->address, Email::Address->parse( $user_str ))[0],
1929     );
1930 }
1931
1932 sub _PrepareGnuPGOptions {
1933     my %opt = @_;
1934     my %res = map { lc $_ => $opt{ $_ } } grep $supported_opt{ lc $_ }, keys %opt;
1935     $res{'extra_args'} ||= [];
1936     foreach my $o ( grep !$supported_opt{ lc $_ }, keys %opt ) {
1937         push @{ $res{'extra_args'} }, '--'. lc $o;
1938         push @{ $res{'extra_args'} }, $opt{ $o }
1939             if defined $opt{ $o };
1940     }
1941     return %res;
1942 }
1943
1944 { my %key;
1945 # no args -> clear
1946 # one arg -> return preferred key
1947 # many -> set
1948 sub UseKeyForEncryption {
1949     unless ( @_ ) {
1950         %key = ();
1951     } elsif ( @_ > 1 ) {
1952         %key = (%key, @_);
1953         $key{ lc($_) } = delete $key{ $_ } foreach grep lc ne $_, keys %key;
1954     } else {
1955         return $key{ $_[0] };
1956     }
1957     return ();
1958 } }
1959
1960 =head2 UseKeyForSigning
1961
1962 Returns or sets identifier of the key that should be used for signing.
1963
1964 Returns the current value when called without arguments.
1965
1966 Sets new value when called with one argument and unsets if it's undef.
1967
1968 =cut
1969
1970 { my $key;
1971 sub UseKeyForSigning {
1972     if ( @_ ) {
1973         $key = $_[0];
1974     }
1975     return $key;
1976 } }
1977
1978 =head2 GetKeysForEncryption
1979
1980 Takes identifier and returns keys suitable for encryption.
1981
1982 B<Note> that keys for which trust level is not set are
1983 also listed.
1984
1985 =cut
1986
1987 sub GetKeysForEncryption {
1988     my $key_id = shift;
1989     my %res = GetKeysInfo( $key_id, 'public', @_ );
1990     return %res if $res{'exit_code'};
1991     return %res unless $res{'info'};
1992
1993     foreach my $key ( splice @{ $res{'info'} } ) {
1994         # skip disabled keys
1995         next if $key->{'Capabilities'} =~ /D/;
1996         # skip keys not suitable for encryption
1997         next unless $key->{'Capabilities'} =~ /e/i;
1998         # skip disabled, expired, revoke and keys with no trust,
1999         # but leave keys with unknown trust level
2000         next if $key->{'TrustLevel'} < 0;
2001
2002         push @{ $res{'info'} }, $key;
2003     }
2004     delete $res{'info'} unless @{ $res{'info'} };
2005     return %res;
2006 }
2007
2008 sub GetKeysForSigning {
2009     my $key_id = shift;
2010     return GetKeysInfo( $key_id, 'private', @_ );
2011 }
2012
2013 sub CheckRecipients {
2014     my @recipients = (@_);
2015
2016     my ($status, @issues) = (1, ());
2017
2018     my %seen;
2019     foreach my $address ( grep !$seen{ lc $_ }++, map $_->address, @recipients ) {
2020         my %res = GetKeysForEncryption( $address );
2021         if ( $res{'info'} && @{ $res{'info'} } == 1 && $res{'info'}[0]{'TrustLevel'} > 0 ) {
2022             # good, one suitable and trusted key
2023             next;
2024         }
2025         my $user = RT::User->new( $RT::SystemUser );
2026         $user->LoadByEmail( $address );
2027         # it's possible that we have no User record with the email
2028         $user = undef unless $user->id;
2029
2030         if ( my $fpr = UseKeyForEncryption( $address ) ) {
2031             if ( $res{'info'} && @{ $res{'info'} } ) {
2032                 next if
2033                     grep lc $_->{'Fingerprint'} eq lc $fpr,
2034                     grep $_->{'TrustLevel'} > 0,
2035                     @{ $res{'info'} };
2036             }
2037
2038             $status = 0;
2039             my %issue = (
2040                 EmailAddress => $address,
2041                 $user? (User => $user) : (),
2042                 Keys => undef,
2043             );
2044             $issue{'Message'} = "Selected key either is not trusted or doesn't exist anymore."; #loc
2045             push @issues, \%issue;
2046             next;
2047         }
2048
2049         my $prefered_key;
2050         $prefered_key = $user->PreferredKey if $user;
2051         #XXX: prefered key is not yet implemented...
2052
2053         # classify errors
2054         $status = 0;
2055         my %issue = (
2056             EmailAddress => $address,
2057             $user? (User => $user) : (),
2058             Keys => undef,
2059         );
2060
2061         unless ( $res{'info'} && @{ $res{'info'} } ) {
2062             # no key
2063             $issue{'Message'} = "There is no key suitable for encryption."; #loc
2064         }
2065         elsif ( @{ $res{'info'} } == 1 && !$res{'info'}[0]{'TrustLevel'} ) {
2066             # trust is not set
2067             $issue{'Message'} = "There is one suitable key, but trust level is not set."; #loc
2068         }
2069         else {
2070             # multiple keys
2071             $issue{'Message'} = "There are several keys suitable for encryption."; #loc
2072         }
2073         push @issues, \%issue;
2074     }
2075     return ($status, @issues);
2076 }
2077
2078 sub GetPublicKeyInfo {
2079     return GetKeyInfo( shift, 'public', @_ );
2080 }
2081
2082 sub GetPrivateKeyInfo {
2083     return GetKeyInfo( shift, 'private', @_ );
2084 }
2085
2086 sub GetKeyInfo {
2087     my %res = GetKeysInfo(@_);
2088     $res{'info'} = $res{'info'}->[0];
2089     return %res;
2090 }
2091
2092 sub GetKeysInfo {
2093     my $email = shift;
2094     my $type = shift || 'public';
2095     my $force = shift;
2096
2097     unless ( $email ) {
2098         return (exit_code => 0) unless $force;
2099     }
2100
2101     my $gnupg = new GnuPG::Interface;
2102     my %opt = RT->Config->Get('GnuPGOptions');
2103     $opt{'digest-algo'} ||= 'SHA1';
2104     $opt{'with-colons'} = undef; # parseable format
2105     $opt{'fingerprint'} = undef; # show fingerprint
2106     $opt{'fixed-list-mode'} = undef; # don't merge uid with keys
2107     $gnupg->options->hash_init(
2108         _PrepareGnuPGOptions( %opt ),
2109         armor => 1,
2110         meta_interactive => 0,
2111     );
2112
2113     my %res;
2114
2115     my ($handles, $handle_list) = _make_gpg_handles();
2116     my %handle = %$handle_list;
2117
2118     eval {
2119         local $SIG{'CHLD'} = 'DEFAULT';
2120         my $method = $type eq 'private'? 'list_secret_keys': 'list_public_keys';
2121         my $pid = safe_run_child { $gnupg->$method( handles => $handles, $email
2122                                                         ? (command_args => [ "--", $email])
2123                                                         : () ) };
2124         close $handle{'stdin'};
2125         waitpid $pid, 0;
2126     };
2127
2128     my @info = readline $handle{'stdout'};
2129     close $handle{'stdout'};
2130
2131     $res{'exit_code'} = $?;
2132     foreach ( qw(stderr logger status) ) {
2133         $res{$_} = do { local $/; readline $handle{$_} };
2134         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
2135         close $handle{$_};
2136     }
2137     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
2138     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
2139     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
2140     if ( $@ || $? ) {
2141         $res{'message'} = $@? $@: "gpg exitted with error code ". ($? >> 8);
2142         return %res;
2143     }
2144
2145     @info = ParseKeysInfo( @info );
2146     $res{'info'} = \@info;
2147     return %res;
2148 }
2149
2150 sub ParseKeysInfo {
2151     my @lines = @_;
2152
2153     my %gpg_opt = RT->Config->Get('GnuPGOptions');
2154
2155     my @res = ();
2156     foreach my $line( @lines ) {
2157         chomp $line;
2158         my $tag;
2159         ($tag, $line) = split /:/, $line, 2;
2160         if ( $tag eq 'pub' ) {
2161             my %info;
2162             @info{ qw(
2163                 TrustChar KeyLength Algorithm Key
2164                 Created Expire Empty OwnerTrustChar
2165                 Empty Empty Capabilities Other
2166             ) } = split /:/, $line, 12;
2167
2168             # workaround gnupg's wierd behaviour, --list-keys command report calculated trust levels
2169             # for any model except 'always', so you can change models and see changes, but not for 'always'
2170             # we try to handle it in a simple way - we set ultimate trust for any key with trust
2171             # level >= 0 if trust model is 'always'
2172             my $always_trust;
2173             $always_trust = 1 if exists $gpg_opt{'always-trust'};
2174             $always_trust = 1 if exists $gpg_opt{'trust-model'} && $gpg_opt{'trust-model'} eq 'always';
2175             @info{qw(Trust TrustTerse TrustLevel)} =
2176                 _ConvertTrustChar( $info{'TrustChar'} );
2177             if ( $always_trust && $info{'TrustLevel'} >= 0 ) {
2178                 @info{qw(Trust TrustTerse TrustLevel)} =
2179                     _ConvertTrustChar( 'u' );
2180             }
2181
2182             @info{qw(OwnerTrust OwnerTrustTerse OwnerTrustLevel)} =
2183                 _ConvertTrustChar( $info{'OwnerTrustChar'} );
2184             $info{ $_ } = _ParseDate( $info{ $_ } )
2185                 foreach qw(Created Expire);
2186             push @res, \%info;
2187         }
2188         elsif ( $tag eq 'sec' ) {
2189             my %info;
2190             @info{ qw(
2191                 Empty KeyLength Algorithm Key
2192                 Created Expire Empty OwnerTrustChar
2193                 Empty Empty Capabilities Other
2194             ) } = split /:/, $line, 12;
2195             @info{qw(OwnerTrust OwnerTrustTerse OwnerTrustLevel)} =
2196                 _ConvertTrustChar( $info{'OwnerTrustChar'} );
2197             $info{ $_ } = _ParseDate( $info{ $_ } )
2198                 foreach qw(Created Expire);
2199             push @res, \%info;
2200         }
2201         elsif ( $tag eq 'uid' ) {
2202             my %info;
2203             @info{ qw(Trust Created Expire String) }
2204                 = (split /:/, $line)[0,4,5,8];
2205             $info{ $_ } = _ParseDate( $info{ $_ } )
2206                 foreach qw(Created Expire);
2207             push @{ $res[-1]{'User'} ||= [] }, \%info;
2208         }
2209         elsif ( $tag eq 'fpr' ) {
2210             $res[-1]{'Fingerprint'} = (split /:/, $line, 10)[8];
2211         }
2212     }
2213     return @res;
2214 }
2215
2216 {
2217     my %verbose = (
2218         # deprecated
2219         d   => [
2220             "The key has been disabled", #loc
2221             "key disabled", #loc
2222             "-2"
2223         ],
2224
2225         r   => [
2226             "The key has been revoked", #loc
2227             "key revoked", #loc
2228             -3,
2229         ],
2230
2231         e   => [ "The key has expired", #loc
2232             "key expired", #loc
2233             '-4',
2234         ],
2235
2236         n   => [ "Don't trust this key at all", #loc
2237             'none', #loc
2238             -1,
2239         ],
2240
2241         #gpupg docs says that '-' and 'q' may safely be treated as the same value
2242         '-' => [
2243             'Unknown (no trust value assigned)', #loc
2244             'not set',
2245             0,
2246         ],
2247         q   => [
2248             'Unknown (no trust value assigned)', #loc
2249             'not set',
2250             0,
2251         ],
2252         o   => [
2253             'Unknown (this value is new to the system)', #loc
2254             'unknown',
2255             0,
2256         ],
2257
2258         m   => [
2259             "There is marginal trust in this key", #loc
2260             'marginal', #loc
2261             1,
2262         ],
2263         f   => [
2264             "The key is fully trusted", #loc
2265             'full', #loc
2266             2,
2267         ],
2268         u   => [
2269             "The key is ultimately trusted", #loc
2270             'ultimate', #loc
2271             3,
2272         ],
2273     );
2274
2275     sub _ConvertTrustChar {
2276         my $value = shift;
2277         return @{ $verbose{'-'} } unless $value;
2278         $value = substr $value, 0, 1;
2279         return @{ $verbose{ $value } || $verbose{'o'} };
2280     }
2281 }
2282
2283 sub _ParseDate {
2284     my $value = shift;
2285     # never
2286     return $value unless $value;
2287
2288     require RT::Date;
2289     my $obj = RT::Date->new( $RT::SystemUser );
2290     # unix time
2291     if ( $value =~ /^\d+$/ ) {
2292         $obj->Set( Value => $value );
2293     } else {
2294         $obj->Set( Format => 'unknown', Value => $value, Timezone => 'utc' );
2295     }
2296     return $obj;
2297 }
2298
2299 sub DeleteKey {
2300     my $key = shift;
2301
2302     my $gnupg = new GnuPG::Interface;
2303     my %opt = RT->Config->Get('GnuPGOptions');
2304     $gnupg->options->hash_init(
2305         _PrepareGnuPGOptions( %opt ),
2306         meta_interactive => 0,
2307     );
2308
2309     my ($handles, $handle_list) = _make_gpg_handles();
2310     my %handle = %$handle_list;
2311
2312     eval {
2313         local $SIG{'CHLD'} = 'DEFAULT';
2314         local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
2315         my $pid = safe_run_child { $gnupg->wrap_call(
2316             handles => $handles,
2317             commands => ['--delete-secret-and-public-key'],
2318             command_args => ["--", $key],
2319         ) };
2320         close $handle{'stdin'};
2321         while ( my $str = readline $handle{'status'} ) {
2322             if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL delete_key\..*/ ) {
2323                 print { $handle{'command'} } "y\n";
2324             }
2325         }
2326         waitpid $pid, 0;
2327     };
2328     my $err = $@;
2329     close $handle{'stdout'};
2330
2331     my %res;
2332     $res{'exit_code'} = $?;
2333     foreach ( qw(stderr logger status) ) {
2334         $res{$_} = do { local $/; readline $handle{$_} };
2335         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
2336         close $handle{$_};
2337     }
2338     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
2339     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
2340     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
2341     if ( $err || $res{'exit_code'} ) {
2342         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
2343     }
2344     return %res;
2345 }
2346
2347 sub ImportKey {
2348     my $key = shift;
2349
2350     my $gnupg = new GnuPG::Interface;
2351     my %opt = RT->Config->Get('GnuPGOptions');
2352     $gnupg->options->hash_init(
2353         _PrepareGnuPGOptions( %opt ),
2354         meta_interactive => 0,
2355     );
2356
2357     my ($handles, $handle_list) = _make_gpg_handles();
2358     my %handle = %$handle_list;
2359
2360     eval {
2361         local $SIG{'CHLD'} = 'DEFAULT';
2362         local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
2363         my $pid = safe_run_child { $gnupg->wrap_call(
2364             handles => $handles,
2365             commands => ['--import'],
2366         ) };
2367         print { $handle{'stdin'} } $key;
2368         close $handle{'stdin'};
2369         waitpid $pid, 0;
2370     };
2371     my $err = $@;
2372     close $handle{'stdout'};
2373
2374     my %res;
2375     $res{'exit_code'} = $?;
2376     foreach ( qw(stderr logger status) ) {
2377         $res{$_} = do { local $/; readline $handle{$_} };
2378         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
2379         close $handle{$_};
2380     }
2381     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
2382     $RT::Logger->warning( $res{'stderr'} ) if $res{'stderr'};
2383     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
2384     if ( $err || $res{'exit_code'} ) {
2385         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
2386     }
2387     return %res;
2388 }
2389
2390 =head2 KEY
2391
2392 Signs a small message with the key, to make sure the key exists and
2393 we have a useable passphrase. The first argument MUST be a key identifier
2394 of the signer: either email address, key id or finger print.
2395
2396 Returns a true value if all went well.
2397
2398 =cut
2399
2400 sub DrySign {
2401     my $from = shift;
2402
2403     my $mime = MIME::Entity->build(
2404         Type    => "text/plain",
2405         From    => 'nobody@localhost',
2406         To      => 'nobody@localhost',
2407         Subject => "dry sign",
2408         Data    => ['t'],
2409     );
2410
2411     my %res = SignEncrypt(
2412         Sign    => 1,
2413         Encrypt => 0,
2414         Entity  => $mime,
2415         Signer  => $from,
2416     );
2417
2418     return $res{exit_code} == 0;
2419 }
2420
2421 1;
2422
2423 =head2 Probe
2424
2425 This routine returns true if RT's GnuPG support is configured and working
2426 properly (and false otherwise).
2427
2428
2429 =cut
2430
2431
2432 sub Probe {
2433     my $gnupg = new GnuPG::Interface;
2434     my %opt = RT->Config->Get('GnuPGOptions');
2435     $gnupg->options->hash_init(
2436         _PrepareGnuPGOptions( %opt ),
2437         armor => 1,
2438         meta_interactive => 0,
2439     );
2440
2441     my ($handles, $handle_list) = _make_gpg_handles();
2442     my %handle = %$handle_list;
2443
2444     local $@;
2445     eval {
2446         local $SIG{'CHLD'} = 'DEFAULT';
2447         my $pid = safe_run_child { $gnupg->wrap_call( commands => ['--version' ], handles => $handles ) };
2448         close $handle{'stdin'};
2449         waitpid $pid, 0;
2450     };
2451     if ( $@ ) {
2452         $RT::Logger->debug(
2453             "Probe for GPG failed."
2454             ." Couldn't run `gpg --version`: ". $@
2455         );
2456         return 0;
2457     }
2458
2459 # on some systems gpg exits with code 2, but still 100% functional,
2460 # it's general error system error or incorrect command, command is correct,
2461 # but there is no way to get actuall error
2462     if ( $? && ($? >> 8) != 2 ) {
2463         my $msg = "Probe for GPG failed."
2464             ." Process exitted with code ". ($? >> 8)
2465             . ($? & 127 ? (" as recieved signal ". ($? & 127)) : '')
2466             . ".";
2467         foreach ( qw(stderr logger status) ) {
2468             my $tmp = do { local $/; readline $handle{$_} };
2469             next unless $tmp && $tmp =~ /\S/s;
2470             close $handle{$_};
2471             $msg .= "\n$_:\n$tmp\n";
2472         }
2473         $RT::Logger->debug( $msg );
2474         return 0;
2475     }
2476     return 1;
2477 }
2478
2479
2480 sub _make_gpg_handles {
2481     my %handle_map = (@_);
2482     $handle_map{$_} = IO::Handle->new
2483         foreach grep !defined $handle_map{$_},
2484         qw(stdin stdout stderr logger status command);
2485
2486     my $handles = GnuPG::Handles->new(%handle_map);
2487     return ($handles, \%handle_map);
2488 }
2489
2490 RT::Base->_ImportOverlays();
2491
2492 # helper package to avoid using temp file
2493 package IO::Handle::CRLF;
2494
2495 use base qw(IO::Handle);
2496
2497 sub print {
2498     my ($self, @args) = (@_);
2499     s/\r*\n/\x0D\x0A/g foreach @args;
2500     return $self->SUPER::print( @args );
2501 }
2502
2503 1;