Email.pm 55.2 KB
Newer Older
1
# BEGIN BPS TAGGED BLOCK {{{
Jesse Vincent's avatar
Jesse Vincent committed
2
#
3
# COPYRIGHT:
Jesse Vincent's avatar
Jesse Vincent committed
4
#
5
# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
Kevin Falcone's avatar
Kevin Falcone committed
6
#                                          <sales@bestpractical.com>
Jesse Vincent's avatar
Jesse Vincent committed
7
#
8
# (Except where explicitly superseded by other copyright notices)
Jesse Vincent's avatar
Jesse Vincent committed
9
10
#
#
11
# LICENSE:
Jesse Vincent's avatar
Jesse Vincent committed
12
#
13
14
15
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
16
# from www.gnu.org.
Jesse Vincent's avatar
Jesse Vincent committed
17
#
18
19
20
21
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
Jesse Vincent's avatar
Jesse Vincent committed
22
#
23
24
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
Jesse Vincent's avatar
Jesse Vincent committed
25
26
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 or visit their web page on the internet at
Ruslan Zakirov's avatar
Ruslan Zakirov committed
27
# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
Jesse Vincent's avatar
Jesse Vincent committed
28
29
#
#
30
# CONTRIBUTION SUBMISSION POLICY:
Jesse Vincent's avatar
Jesse Vincent committed
31
#
32
33
34
35
36
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of
# the GNU General Public License and is only of importance to you if
# you choose to contribute your changes and enhancements to the
# community by submitting them to Best Practical Solutions, LLC.)
Jesse Vincent's avatar
Jesse Vincent committed
37
#
38
39
40
41
42
43
44
45
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with
# Request Tracker, to Best Practical Solutions, LLC, you confirm that
# you are the copyright holder for those contributions and you grant
# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
# royalty-free, perpetual, license to use, copy, create derivative
# works based on those contributions, and sublicense and distribute
# those contributions and any derivatives thereof.
Jesse Vincent's avatar
Jesse Vincent committed
46
#
47
# END BPS TAGGED BLOCK }}}
48

49
package RT::Interface::Email;
Tobias Brox's avatar
Tobias Brox committed
50

51
use strict;
Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
52
53
use warnings;

Emmanuel Lacour's avatar
Emmanuel Lacour committed
54
use Email::Address;
55
use MIME::Entity;
56
use RT::EmailParser;
57
use File::Temp;
58
use Mail::Mailer ();
59
use Text::ParseWords qw/shellwords/;
Tobias Brox's avatar
Tobias Brox committed
60

61
BEGIN {
62
63
    use base 'Exporter';
    use vars qw ( @EXPORT_OK);
64

65
66
    # your exported package globals go here,
    # as well as any optionally exported functions
67
68
69
70
71
72
73
74
75
76
77
78
79
    @EXPORT_OK = qw(
        &CreateUser
        &GetMessageContent
        &CheckForLoops
        &CheckForSuspiciousSender
        &CheckForAutoGenerated
        &CheckForBounce
        &MailError
        &ParseCcAddressesFromHead
        &ParseSenderAddressFromHead
        &ParseErrorsToAddressFromHead
        &ParseAddressFromHeader
        &Gateway);
80

81
}
82

83
=head1 NAME
84

Alex Vandiver's avatar
Alex Vandiver committed
85
  RT::Interface::Email - helper functions for parsing email sent to RT
Tobias Brox's avatar
Tobias Brox committed
86

87
=head1 SYNOPSIS
Tobias Brox's avatar
Tobias Brox committed
88

89
90
  use lib "!!RT_LIB_PATH!!";
  use lib "!!RT_ETC_PATH!!";
Tobias Brox's avatar
Tobias Brox committed
91

92
  use RT::Interface::Email  qw(Gateway CreateUser);
Jesse Vincent's avatar
Jesse Vincent committed
93

94
=head1 DESCRIPTION
95

Tobias Brox's avatar
Tobias Brox committed
96

Jesse Vincent's avatar
Jesse Vincent committed
97
98


99
=head1 METHODS
100

Ruslan Zakirov's avatar
Ruslan Zakirov committed
101
102
=head2 CheckForLoops HEAD

Ruslan Zakirov's avatar
Ruslan Zakirov committed
103
104
105
Takes a HEAD object of L<MIME::Head> class and returns true if the
message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
field of the head for test.
106

Ruslan Zakirov's avatar
Ruslan Zakirov committed
107
=cut
108

109
sub CheckForLoops {
110
    my $head = shift;
111

112
    # If this instance of RT sent it our, we don't want to take it in
113
    my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" );
114
115
116
    chomp ($RTLoop); # remove that newline
    if ( $RTLoop eq RT->Config->Get('rtname') ) {
        return 1;
117
    }
118

119
120
    # TODO: We might not trap the case where RT instance A sends a mail
    # to RT instance B which sends a mail to ...
121
    return undef;
122
123
}

Ruslan Zakirov's avatar
Ruslan Zakirov committed
124
125
=head2 CheckForSuspiciousSender HEAD

Ruslan Zakirov's avatar
Ruslan Zakirov committed
126
127
Takes a HEAD object of L<MIME::Head> class and returns true if sender
is suspicious. Suspicious means mailer daemon.
128

Ruslan Zakirov's avatar
Ruslan Zakirov committed
129
130
131
See also L</ParseSenderAddressFromHead>.

=cut
132

133
134
sub CheckForSuspiciousSender {
    my $head = shift;
135

136
    #if it's from a postmaster or mailer daemon, it's likely a bounce.
137

138
139
140
141
142
    #TODO: better algorithms needed here - there is no standards for
    #bounces, so it's very difficult to separate them from anything
    #else.  At the other hand, the Return-To address is only ment to be
    #used as an error channel, we might want to put up a separate
    #Return-To address which is treated differently.
143

144
145
    #TODO: search through the whole email and find the right Ticket ID.

146
147
    my ( $From, $junk ) = ParseSenderAddressFromHead($head);

Jim Brandt's avatar
Jim Brandt committed
148
149
150
    # If unparseable (non-ASCII), $From can come back undef
    return undef if not defined $From;

151
    if (   ( $From =~ /^mailer-daemon\@/i )
Alex Vandiver's avatar
Alex Vandiver committed
152
153
        or ( $From =~ /^postmaster\@/i )
        or ( $From eq "" ))
154
155
156
    {
        return (1);

157
    }
158

Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
159
    return undef;
160
161
}

Ruslan Zakirov's avatar
Ruslan Zakirov committed
162
163
=head2 CheckForAutoGenerated HEAD

164
165
166
Takes a HEAD object of L<MIME::Head> class and returns true if message is
autogenerated. Checks C<Precedence>, C<Auto-Submitted>, and
C<X-FC-Machinegenerated> fields of the head in tests.
Ruslan Zakirov's avatar
Ruslan Zakirov committed
167
168

=cut
169
170
171

sub CheckForAutoGenerated {
    my $head = shift;
172

173
    if (grep { /^(bulk|junk)/i } $head->get_all("Precedence")) {
174
        return (1);
175
    }
176

177
178
179
180
181
182
183
    # Per RFC3834, any Auto-Submitted header which is not "no" means
    # it is auto-generated.
    my $AutoSubmitted = $head->get("Auto-Submitted") || "";
    if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
        return (1);
    }

Jesse Vincent's avatar
Jesse Vincent committed
184
185
    # First Class mailer uses this as a clue.
    my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
186
    if ( $FCJunk =~ /^true/i ) {
Jesse Vincent's avatar
Jesse Vincent committed
187
        return (1);
188
    }
Jesse Vincent's avatar
Jesse Vincent committed
189
190

    return (0);
191
192
193
}


Jesse Vincent's avatar
Jesse Vincent committed
194
195
sub CheckForBounce {
    my $head = shift;
196
197
198

    my $ReturnPath = $head->get("Return-path") || "";
    return ( $ReturnPath =~ /<>/ );
Jesse Vincent's avatar
Jesse Vincent committed
199
200
}

Alex Vandiver's avatar
Alex Vandiver committed
201

Ruslan Zakirov's avatar
Ruslan Zakirov committed
202
203
204
205
206
207
208
209
=head2 MailError PARAM HASH

Sends an error message. Takes a param hash:

=over 4

=item From - sender's address, by default is 'CorrespondAddress';

Emmanuel Lacour's avatar
Emmanuel Lacour committed
210
=item To - recipient, by default is 'OwnerEmail';
Ruslan Zakirov's avatar
Ruslan Zakirov committed
211
212
213
214
215
216
217
218
219
220
221
222

=item Bcc - optional Bcc recipients;

=item Subject - subject of the message, default is 'There has been an error';

=item Explanation - main content of the error, default value is 'Unexplained error';

=item MIMEObj - optional MIME entity that's attached to the error mail, as well we
add 'In-Reply-To' field to the error that points to this message.

=item Attach - optional text that attached to the error as 'message/rfc822' part.

223
224
=item LogLevel - log level under which we should write the subject and
explanation message into the log, by default we log it as critical.
Ruslan Zakirov's avatar
Ruslan Zakirov committed
225
226
227
228

=back

=cut
229

230
sub MailError {
231
    my %args = (
Ruslan Zakirov's avatar
Ruslan Zakirov committed
232
        To          => RT->Config->Get('OwnerEmail'),
233
        Bcc         => undef,
Ruslan Zakirov's avatar
Ruslan Zakirov committed
234
        From        => RT->Config->Get('CorrespondAddress'),
235
236
237
238
239
240
241
242
243
244
        Subject     => 'There has been an error',
        Explanation => 'Unexplained error',
        MIMEObj     => undef,
        Attach      => undef,
        LogLevel    => 'crit',
        @_
    );

    $RT::Logger->log(
        level   => $args{'LogLevel'},
245
        message => "$args{Subject}: $args{'Explanation'}",
Ruslan Zakirov's avatar
Ruslan Zakirov committed
246
    ) if $args{'LogLevel'};
247

248
    # the colons are necessary to make ->build include non-standard headers
249
250
    my %entity_args = (
        Type                    => "multipart/mixed",
251
252
253
254
255
        From                    => Encode::encode( "UTF-8", $args{'From'} ),
        Bcc                     => Encode::encode( "UTF-8", $args{'Bcc'} ),
        To                      => Encode::encode( "UTF-8", $args{'To'} ),
        Subject                 => EncodeToMIME( String => $args{'Subject'} ),
        'X-RT-Loop-Prevention:' => Encode::encode( "UTF-8", RT->Config->Get('rtname') ),
256
    );
257
258
259

    # only set precedence if the sysadmin wants us to
    if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
260
261
        $entity_args{'Precedence:'} =
            Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') );
262
263
264
    }

    my $entity = MIME::Entity->build(%entity_args);
265
    SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
266

267
268
269
270
271
    $entity->attach(
        Type    => "text/plain",
        Charset => "UTF-8",
        Data    => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ),
    );
272

Ruslan Zakirov's avatar
Ruslan Zakirov committed
273
274
275
    if ( $args{'MIMEObj'} ) {
        $args{'MIMEObj'}->sync_headers;
        $entity->add_part( $args{'MIMEObj'} );
276
    }
277
278

    if ( $args{'Attach'} ) {
279
        $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' );
280
281
282

    }

Ruslan Zakirov's avatar
Ruslan Zakirov committed
283
    SendEmail( Entity => $entity, Bounce => 1 );
Alex Vandiver's avatar
Alex Vandiver committed
284
285
286
}


Ruslan Zakirov's avatar
Ruslan Zakirov committed
287
=head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
Alex Vandiver's avatar
Alex Vandiver committed
288
289

Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
Ruslan Zakirov's avatar
Ruslan Zakirov committed
290
RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
Alex Vandiver's avatar
Alex Vandiver committed
291
true value, the message will be marked as an autogenerated error, if
292
possible. Sets Date field of the head to now if it's not set.
Alex Vandiver's avatar
Alex Vandiver committed
293

294
295
296
If the C<X-RT-Squelch> header is set to any true value, the mail will
not be sent. One use is to let extensions easily cancel outgoing mail.

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
Ticket and Transaction arguments are optional. If Transaction is
specified and Ticket is not then ticket of the transaction is
used, but only if the transaction belongs to a ticket.

Returns 1 on success, 0 on error or -1 if message has no recipients
and hasn't been sent.

=head3 Signing and Encrypting

This function as well signs and/or encrypts the message according to
headers of a transaction's attachment or properties of a ticket's queue.
To get full access to the configuration Ticket and/or Transaction
arguments must be provided, but you can force behaviour using Sign
and/or Encrypt arguments.

The following precedence of arguments are used to figure out if
the message should be encrypted and/or signed:

* if Sign or Encrypt argument is defined then its value is used
Alex Vandiver's avatar
Alex Vandiver committed
316

317
318
319
320
* else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
header field then it's value is used

* else properties of a queue of the Ticket are used.
Ruslan Zakirov's avatar
Ruslan Zakirov committed
321

Alex Vandiver's avatar
Alex Vandiver committed
322
323
=cut

324
325
326
327
328
sub WillSignEncrypt {
    my %args = @_;
    my $attachment = delete $args{Attachment};
    my $ticket     = delete $args{Ticket};

329
    if ( not RT->Config->Get('Crypt')->{'Enable'} ) {
330
331
332
333
        $args{Sign} = $args{Encrypt} = 0;
        return wantarray ? %args : 0;
    }

334
335
336
337
338
    for my $argument ( qw(Sign Encrypt) ) {
        next if defined $args{ $argument };

        if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) {
            $args{$argument} = $attachment->GetHeader("X-RT-$argument");
339
340
341
342
343
344
345
346
        } elsif ( $ticket and $argument eq "Encrypt" ) {
            $args{Encrypt} = $ticket->QueueObj->Encrypt();
        } elsif ( $ticket and $argument eq "Sign" ) {
            # Note that $queue->Sign is UI-only, and that all
            # UI-generated messages explicitly set the X-RT-Crypt header
            # to 0 or 1; thus this path is only taken for messages
            # generated _not_ via the web UI.
            $args{Sign} = $ticket->QueueObj->SignAuto();
347
348
349
350
351
352
        }
    }

    return wantarray ? %args : ($args{Sign} || $args{Encrypt});
}

Alex Vandiver's avatar
Alex Vandiver committed
353
354
sub SendEmail {
    my (%args) = (
355
356
357
358
        Entity => undef,
        Bounce => 0,
        Ticket => undef,
        Transaction => undef,
Ruslan Zakirov's avatar
Ruslan Zakirov committed
359
360
        @_,
    );
361
362
363
364

    my $TicketObj = $args{'Ticket'};
    my $TransactionObj = $args{'Transaction'};

365
366
    unless ( $args{'Entity'} ) {
        $RT::Logger->crit( "Could not send mail without 'Entity' object" );
Ruslan Zakirov's avatar
Ruslan Zakirov committed
367
368
        return 0;
    }
369

370
    my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
371
372
373
374
375
376
377
    chomp $msgid;
    
    # If we don't have any recipients to send to, don't send a message;
    unless ( $args{'Entity'}->head->get('To')
        || $args{'Entity'}->head->get('Cc')
        || $args{'Entity'}->head->get('Bcc') )
    {
378
        $RT::Logger->info( $msgid . " No recipients found. Not sending." );
379
380
381
        return -1;
    }

382
383
384
385
386
    if ($args{'Entity'}->head->get('X-RT-Squelch')) {
        $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
        return -1;
    }

387
388
389
    if (my $precedence = RT->Config->Get('DefaultMailPrecedence')
        and !$args{'Entity'}->head->get("Precedence")
    ) {
390
        $args{'Entity'}->head->replace( 'Precedence', Encode::encode("UTF-8",$precedence) );
391
392
    }

393
394
    if ( $TransactionObj && !$TicketObj
        && $TransactionObj->ObjectType eq 'RT::Ticket' )
395
    {
396
        $TicketObj = $TransactionObj->Object;
397
398
    }

399
400
    my $head = $args{'Entity'}->head;
    unless ( $head->get('Date') ) {
401
402
403
        require RT::Date;
        my $date = RT::Date->new( RT->SystemUser );
        $date->SetToNow;
404
        $head->replace( 'Date', Encode::encode("UTF-8",$date->RFC2822( Timezone => 'server' ) ) );
405
406
407
    }
    unless ( $head->get('MIME-Version') ) {
        # We should never have to set the MIME-Version header
408
        $head->replace( 'MIME-Version', '1.0' );
409
410
411
    }
    unless ( $head->get('Content-Transfer-Encoding') ) {
        # fsck.com #5959: Since RT sends 8bit mail, we should say so.
412
        $head->replace( 'Content-Transfer-Encoding', '8bit' );
413
414
    }

415
    if ( RT->Config->Get('Crypt')->{'Enable'} ) {
416
417
418
419
420
421
        %args = WillSignEncrypt(
            %args,
            Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
            Ticket     => $TicketObj,
        );
        my $res = SignEncrypt( %args );
422
        return $res unless $res > 0;
423
424
    }

Ruslan Zakirov's avatar
Ruslan Zakirov committed
425
426
    my $mail_command = RT->Config->Get('MailCommand');

427
428
429
    # if it is a sub routine, we just return it;
    return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );

Ruslan Zakirov's avatar
Ruslan Zakirov committed
430
    if ( $mail_command eq 'sendmailpipe' ) {
Alex Vandiver's avatar
Alex Vandiver committed
431
        my $path = RT->Config->Get('SendmailPath');
432
        my @args = shellwords(RT->Config->Get('SendmailArguments'));
433
        push @args, "-t" unless grep {$_ eq "-t"} @args;
434

435
436
        # SetOutgoingMailFrom and bounces conflict, since they both want -f
        if ( $args{'Bounce'} ) {
437
            push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
438
439
440
        } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) {
            my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
            my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
Shawn M Moore's avatar
Tidy    
Shawn M Moore committed
441
442
443

            if ($TicketObj) {
                my $QueueName = $TicketObj->QueueObj->Name;
444
                my $QueueAddressOverride = $Overrides->{$QueueName};
Shawn M Moore's avatar
Tidy    
Shawn M Moore committed
445
446
447
448

                if ($QueueAddressOverride) {
                    $OutgoingMailAddress = $QueueAddressOverride;
                } else {
449
450
                    $OutgoingMailAddress ||= $TicketObj->QueueObj->CorrespondAddress
                                             || RT->Config->Get('CorrespondAddress');
Shawn M Moore's avatar
Tidy    
Shawn M Moore committed
451
                }
452
            }
453
454
            elsif ($Overrides->{'Default'}) {
                $OutgoingMailAddress = $Overrides->{'Default'};
455
            }
Shawn M Moore's avatar
Shawn M Moore committed
456

457
            push @args, "-f", $OutgoingMailAddress
Shawn M Moore's avatar
Tidy    
Shawn M Moore committed
458
459
                if $OutgoingMailAddress;
        }
460

Shawn M Moore's avatar
Tidy    
Shawn M Moore committed
461
        # VERP
462
        if ( $TransactionObj and
Ruslan Zakirov's avatar
Ruslan Zakirov committed
463
             my $prefix = RT->Config->Get('VERPPrefix') and
464
465
             my $domain = RT->Config->Get('VERPDomain') )
        {
466
            my $from = $TransactionObj->CreatorObj->EmailAddress;
467
468
            $from =~ s/@/=/g;
            $from =~ s/\s//g;
469
            push @args, "-f", "$prefix$from\@$domain";
470
471
        }

Alex Vandiver's avatar
Alex Vandiver committed
472
473
474
475
476
        eval {
            # don't ignore CHLD signal to get proper exit code
            local $SIG{'CHLD'} = 'DEFAULT';

            # if something wrong with $mail->print we will get PIPE signal, handle it
Ruslan Zakirov's avatar
Ruslan Zakirov committed
477
            local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
478
479
480
481
482
483

            require IPC::Open2;
            my ($mail, $stdout);
            my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args )
                or die "couldn't execute program: $!";

484
            $args{'Entity'}->print($mail);
485
            close $mail or die "close pipe failed: $!";
Alex Vandiver's avatar
Alex Vandiver committed
486

487
488
            waitpid($pid, 0);
            if ($?) {
Alex Vandiver's avatar
Alex Vandiver committed
489
490
                # sendmail exit statuses mostly errors with data not software
                # TODO: status parsing: core dump, exit on signal or EX_*
491
                my $msg = "$msgid: `$path @args` exited with code ". ($?>>8);
Ruslan Zakirov's avatar
Ruslan Zakirov committed
492
493
                $msg = ", interrupted by signal ". ($?&127) if $?&127;
                $RT::Logger->error( $msg );
494
                die $msg;
Alex Vandiver's avatar
Alex Vandiver committed
495
496
            }
        };
Ruslan Zakirov's avatar
Ruslan Zakirov committed
497
        if ( $@ ) {
498
            $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ );
sunnavy's avatar
sunnavy committed
499
500
501
            if ( $TicketObj ) {
                _RecordSendEmailFailure( $TicketObj );
            }
Alex Vandiver's avatar
Alex Vandiver committed
502
503
            return 0;
        }
504
505
    }
    else {
Ruslan Zakirov's avatar
Ruslan Zakirov committed
506
        local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
Alex Vandiver's avatar
Alex Vandiver committed
507

Ruslan Zakirov's avatar
Ruslan Zakirov committed
508
509
510
        my @mailer_args = ($mail_command);
        if ( $mail_command eq 'sendmail' ) {
            $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
511
512
            push @mailer_args, grep {$_ ne "-t"}
                split(/\s+/, RT->Config->Get('SendmailArguments'));
513
514
515
516
517
518
        } elsif ( $mail_command eq 'testfile' ) {
            unless ($Mail::Mailer::testfile::config{outfile}) {
                $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
                $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
            }
        } else {
Alex Vandiver's avatar
Alex Vandiver committed
519
520
521
            push @mailer_args, RT->Config->Get('MailParams');
        }

522
        unless ( $args{'Entity'}->send( @mailer_args ) ) {
523
            $RT::Logger->crit( "$msgid: Could not send mail." );
sunnavy's avatar
sunnavy committed
524
525
526
            if ( $TicketObj ) {
                _RecordSendEmailFailure( $TicketObj );
            }
Ruslan Zakirov's avatar
Ruslan Zakirov committed
527
            return 0;
Alex Vandiver's avatar
Alex Vandiver committed
528
        }
529
    }
Alex Vandiver's avatar
Alex Vandiver committed
530
    return 1;
531
532
}

533
=head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
Ruslan Zakirov's avatar
Ruslan Zakirov committed
534

Ruslan Zakirov's avatar
Ruslan Zakirov committed
535
536
537
538
539
Loads a template. Parses it using arguments if it's not empty.
Returns a tuple (L<RT::Template> object, error message).

Note that even if a template object is returned MIMEObj method
may return undef for empty templates.
Ruslan Zakirov's avatar
Ruslan Zakirov committed
540
541
542

=cut

543
sub PrepareEmailUsingTemplate {
Ruslan Zakirov's avatar
Ruslan Zakirov committed
544
545
546
547
548
549
    my %args = (
        Template => '',
        Arguments => {},
        @_
    );

550
    my $template = RT::Template->new( RT->SystemUser );
Ruslan Zakirov's avatar
Ruslan Zakirov committed
551
552
    $template->LoadGlobalTemplate( $args{'Template'} );
    unless ( $template->id ) {
Ruslan Zakirov's avatar
Ruslan Zakirov committed
553
        return (undef, "Couldn't load template '". $args{'Template'} ."'");
Ruslan Zakirov's avatar
Ruslan Zakirov committed
554
    }
Ruslan Zakirov's avatar
Ruslan Zakirov committed
555
556
557
558
    return $template if $template->IsEmpty;

    my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
    return (undef, $msg) unless $status;
Ruslan Zakirov's avatar
Ruslan Zakirov committed
559

Ruslan Zakirov's avatar
Ruslan Zakirov committed
560
    return $template;
561
562
}

563
=head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
564
565
566
567
568
569
570
571
572
573
574
575

Sends email using a template, takes name of template, arguments for it and recipients.

=cut

sub SendEmailUsingTemplate {
    my %args = (
        Template => '',
        Arguments => {},
        To => undef,
        Cc => undef,
        Bcc => undef,
576
        From => RT->Config->Get('CorrespondAddress'),
577
        InReplyTo => undef,
578
        ExtraHeaders => {},
579
580
581
        @_
    );

Ruslan Zakirov's avatar
Ruslan Zakirov committed
582
583
    my ($template, $msg) = PrepareEmailUsingTemplate( %args );
    return (0, $msg) unless $template;
Ruslan Zakirov's avatar
Ruslan Zakirov committed
584

Ruslan Zakirov's avatar
Ruslan Zakirov committed
585
586
587
588
589
590
    my $mail = $template->MIMEObj;
    unless ( $mail ) {
        $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
        return -1;
    }

591
    $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ $_ } ) )
592
        foreach grep defined $args{$_}, qw(To Cc Bcc From);
Ruslan Zakirov's avatar
Ruslan Zakirov committed
593

594
    $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) )
595
596
        foreach keys %{ $args{ExtraHeaders} };

597
    SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
598

Ruslan Zakirov's avatar
Ruslan Zakirov committed
599
    return SendEmail( Entity => $mail );
Ruslan Zakirov's avatar
Ruslan Zakirov committed
600
601
}

602
=head2 GetForwardFrom Ticket => undef, Transaction => undef
603

604
Resolve the From field to use in forward mail
605
606
607

=cut

608
609
610
611
sub GetForwardFrom {
    my %args   = ( Ticket => undef, Transaction => undef, @_ );
    my $txn    = $args{Transaction};
    my $ticket = $args{Ticket} || $txn->Object;
612

613
614
    if ( RT->Config->Get('ForwardFromUser') ) {
        return ( $txn || $ticket )->CurrentUser->EmailAddress;
615
    }
616
617
618
    else {
        return $ticket->QueueObj->CorrespondAddress
          || RT->Config->Get('CorrespondAddress');
Ruslan Zakirov's avatar
Ruslan Zakirov committed
619
    }
620
}
621

622
=head2 GetForwardAttachments Ticket => undef, Transaction => undef
623

624
Resolve the Attachments to forward
625
626
627

=cut

628
sub GetForwardAttachments {
629
630
631
632
    my %args   = ( Ticket => undef, Transaction => undef, @_ );
    my $txn    = $args{Transaction};
    my $ticket = $args{Ticket} || $txn->Object;

633
634
635
    my $attachments = RT::Attachments->new( $ticket->CurrentUser );
    if ($txn) {
        $attachments->Limit( FIELD => 'TransactionId', VALUE => $txn->id );
636
637
    }
    else {
638
639
640
641
642
643
644
645
646
        my $txns = $ticket->Transactions;
        $txns->Limit(
            FIELD => 'Type',
            VALUE => $_,
        ) for qw(Create Correspond);

        while ( my $txn = $txns->Next ) {
            $attachments->Limit( FIELD => 'TransactionId', VALUE => $txn->id );
        }
647
    }
648
    return $attachments;
649
650
}

651

652
653
=head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0

654
655
Signs and encrypts message using L<RT::Crypt>, but as well handle errors
with users' keys.
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674

If a recipient has no key or has other problems with it, then the
unction sends a error to him using 'Error: public key' template.
Also, notifies RT's owner using template 'Error to RT owner: public key'
to inform that there are problems with users' keys. Then we filter
all bad recipients and retry.

Returns 1 on success, 0 on error and -1 if all recipients are bad and
had been filtered out.

=cut

sub SignEncrypt {
    my %args = (
        Entity => undef,
        Sign => 0,
        Encrypt => 0,
        @_
    );
Ruslan Zakirov's avatar
typo    
Ruslan Zakirov committed
675
    return 1 unless $args{'Sign'} || $args{'Encrypt'};
676

677
    my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
678
679
680
    chomp $msgid;

    $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
Ruslan Zakirov's avatar
typo    
Ruslan Zakirov committed
681
    $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
682

683
    my %res = RT::Crypt->SignEncrypt( %args );
684
685
    return 1 unless $res{'exit_code'};

686
687
688
    my @status = RT::Crypt->ParseStatus(
        Protocol => $res{'Protocol'}, Status => $res{'status'},
    );
689
690
691

    my @bad_recipients;
    foreach my $line ( @status ) {
692
693
694
        # if the passphrase fails, either you have a bad passphrase
        # or gpg-agent has died.  That should get caught in Create and
        # Update, but at least throw an error here
695
        if (($line->{'Operation'}||'') eq 'PassphraseCheck'
696
697
698
699
            && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
            $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
            return 0;
        }
700
701
702
703
704
705
706
        next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
        next if $line->{'Status'} eq 'DONE';
        $RT::Logger->error( $line->{'Message'} );
        push @bad_recipients, $line;
    }
    return 0 unless @bad_recipients;

Emmanuel Lacour's avatar
Emmanuel Lacour committed
707
    $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
        foreach @bad_recipients;

    foreach my $recipient ( @bad_recipients ) {
        my $status = SendEmailUsingTemplate(
            To        => $recipient->{'AddressObj'}->address,
            Template  => 'Error: public key',
            Arguments => {
                %$recipient,
                TicketObj      => $args{'Ticket'},
                TransactionObj => $args{'Transaction'},
            },
        );
        unless ( $status ) {
            $RT::Logger->error("Couldn't send 'Error: public key'");
        }
    }

    my $status = SendEmailUsingTemplate(
        To        => RT->Config->Get('OwnerEmail'),
        Template  => 'Error to RT owner: public key',
        Arguments => {
            BadRecipients  => \@bad_recipients,
            TicketObj      => $args{'Ticket'},
            TransactionObj => $args{'Transaction'},
        },
    );
    unless ( $status ) {
        $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
    }

    DeleteRecipientsFromHead(
        $args{'Entity'}->head,
        map $_->{'AddressObj'}->address, @bad_recipients
    );

    unless ( $args{'Entity'}->head->get('To')
          || $args{'Entity'}->head->get('Cc')
          || $args{'Entity'}->head->get('Bcc') )
    {
747
        $RT::Logger->debug("$msgid No recipients that have public key, not sending");
748
749
750
751
        return -1;
    }

    # redo without broken recipients
752
    %res = RT::Crypt->SignEncrypt( %args );
753
754
755
756
757
    return 0 if $res{'exit_code'};

    return 1;
}

758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
use MIME::Words ();

=head2 EncodeToMIME

Takes a hash with a String and a Charset. Returns the string encoded
according to RFC2047, using B (base64 based) encoding.

String must be a perl string, octets are returned.

If Charset is not provided then $EmailOutputEncoding config option
is used, or "latin-1" if that is not set.

=cut

sub EncodeToMIME {
    my %args = (
        String => undef,
        Charset  => undef,
        @_
    );
    my $value = $args{'String'};
    return $value unless $value; # 0 is perfect ascii
    my $charset  = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
    my $encoding = 'B';

    # using RFC2047 notation, sec 2.
    # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="

    # An 'encoded-word' may not be more than 75 characters long
    #
    # MIME encoding increases 4/3*(number of bytes), and always in multiples
    # of 4. Thus we have to find the best available value of bytes available
    # for each chunk.
    #
    # First we get the integer max which max*4/3 would fit on space.
    # Then we find the greater multiple of 3 lower or equal than $max.
    my $max = int(
        (   ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
            * 3
        ) / 4
    );
    $max = int( $max / 3 ) * 3;

    chomp $value;

    if ( $max <= 0 ) {

        # gives an error...
        $RT::Logger->crit("Can't encode! Charset or encoding too big.");
        return ($value);
    }

810
    return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s;
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834

    $value =~ s/\s+$//;

    # we need perl string to split thing char by char
    Encode::_utf8_on($value) unless Encode::is_utf8($value);

    my ( $tmp, @chunks ) = ( '', () );
    while ( length $value ) {
        my $char = substr( $value, 0, 1, '' );
        my $octets = Encode::encode( $charset, $char );
        if ( length($tmp) + length($octets) > $max ) {
            push @chunks, $tmp;
            $tmp = '';
        }
        $tmp .= $octets;
    }
    push @chunks, $tmp if length $tmp;

    # encode an join chuncks
    $value = join "\n ",
        map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
        @chunks;
    return ($value);
}
835

836
sub CreateUser {
837
    my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
838

839
    my $NewUser = RT::User->new( RT->SystemUser );
Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
840

841
842
    my ( $Val, $Message ) = $NewUser->Create(
        Name => ( $Username || $Address ),
Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
843
844
845
846
847
848
        EmailAddress => $Address,
        RealName     => $Name,
        Password     => undef,
        Privileged   => 0,
        Comments     => 'Autocreated on ticket submission',
    );
849

850
    unless ($Val) {
851

852
853
854
855
        # Deal with the race condition of two account creations at once
        if ($Username) {
            $NewUser->LoadByName($Username);
        }
856

Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
857
        unless ( $NewUser->Id ) {
858
859
            $NewUser->LoadByEmail($Address);
        }
860
861
862
863
864
865
866
867

        unless ( $NewUser->Id ) {
            MailError(
                To          => $ErrorsTo,
                Subject     => "User could not be created",
                Explanation =>
                    "User creation failed in mailgateway: $Message",
                MIMEObj  => $entity,
Ruslan Zakirov's avatar
Ruslan Zakirov committed
868
                LogLevel => 'crit',
869
            );
870
871
        }
    }
872

873
    #Load the new user object
874
    my $CurrentUser = RT::CurrentUser->new;
Ruslan Zakirov's avatar
minor    
Ruslan Zakirov committed
875
    $CurrentUser->LoadByEmail( $Address );
876

877
878
879
880
881
882
883
884
885
886
887
    unless ( $CurrentUser->id ) {
        $RT::Logger->warning(
            "Couldn't load user '$Address'." . "giving up" );
        MailError(
            To          => $ErrorsTo,
            Subject     => "User could not be loaded",
            Explanation =>
                "User  '$Address' could not be loaded in the mail gateway",
            MIMEObj  => $entity,
            LogLevel => 'crit'
        );
888
    }
889

890
891
    return $CurrentUser;
}
892

Alex Vandiver's avatar
Alex Vandiver committed
893

894

Ruslan Zakirov's avatar
Ruslan Zakirov committed
895
=head2 ParseCcAddressesFromHead HASH
896

Ruslan Zakirov's avatar
Ruslan Zakirov committed
897
898
Takes a hash containing QueueObj, Head and CurrentUser objects.
Returns a list of all email addresses in the To and Cc
899
headers b<except> the current Queue's email addresses, the CurrentUser's
900
email address  and anything that the configuration sub RT::IsRTAddress matches.
901

902
=cut
903

904
sub ParseCcAddressesFromHead {
905
906
907
908
909
910
911
    my %args = (
        Head        => undef,
        QueueObj    => undef,
        CurrentUser => undef,
        @_
    );

912
913
914
915
916
917
    my $current_address = lc $args{'CurrentUser'}->EmailAddress;
    my $user = $args{'CurrentUser'}->UserObj;

    return
        grep $_ ne $current_address && !RT::EmailParser->IsRTAddress( $_ ),
        map lc $user->CanonicalizeEmailAddress( $_->address ),
918
919
        map RT::EmailParser->CleanupAddresses( Email::Address->parse(
              Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ),
Ruslan Zakirov's avatar
Ruslan Zakirov committed
920
        qw(To Cc);
921
922
923
924
}



Ruslan Zakirov's avatar
Ruslan Zakirov committed
925
=head2 ParseSenderAddressFromHead HEAD
926

927
Takes a MIME::Header object. Returns (user@host, friendly name, errors)
928
929
930
where the first two values are the From (evaluated in order of
Reply-To:, From:, Sender).

931
932
933
934
A list of error messages may be returned even when a Sender value is
found, since it could be a parse error for another (checked earlier)
sender field. In this case, the errors aren't fatal, but may be useful
to investigate the parse failure.
935
936
937
938
939

=cut

sub ParseSenderAddressFromHead {
    my $head = shift;
940
    my @sender_headers = ('Reply-To', 'From', 'Sender');
941
    my @errors;  # Accumulate any errors
942

943
    #Figure out who's sending this message.
944
    foreach my $header ( @sender_headers ) {
945
        my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next;
946
947
        my ($addr, $name) = ParseAddressFromHeader( $addr_line );
        # only return if the address is not empty
948
        return ($addr, $name, @errors) if $addr;
949
950

        chomp $addr_line;
951
        push @errors, "$header: $addr_line";
952
    }
953

954
    return (undef, undef, @errors);
955
}
956

Ruslan Zakirov's avatar
Ruslan Zakirov committed
957
=head2 ParseErrorsToAddressFromHead HEAD
958
959

Takes a MIME::Header object. Return a single value : user@host
Jesse Vincent's avatar
Jesse Vincent committed
960
961
of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
From:, Sender)
962
963
964
965
966

=cut

sub ParseErrorsToAddressFromHead {
    my $head = shift;
967

968
969
    #Figure out who's sending this message.

970
    foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
971
972

        # If there's a header of that name
973
        my $headerobj = Encode::decode( "UTF-8", $head->get($header) );
974
975
976
977
978
979
        if ($headerobj) {
            my ( $addr, $name ) = ParseAddressFromHeader($headerobj);

            # If it's got actual useful content...
            return ($addr) if ($addr);
        }
980
981
    }
}
982

983

984

985
986
=head2 ParseAddressFromHeader ADDRESS

Ruslan Zakirov's avatar
Ruslan Zakirov committed
987
Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
988
989
990

=cut

991
sub ParseAddressFromHeader {
992
    my $Addr = shift;