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