Master to 4.2.8
[usit-rt.git] / lib / RT / Dashboard / Mailer.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
16 # from www.gnu.org.
17 #
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 # General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
37 #
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 package RT::Dashboard::Mailer;
50 use strict;
51 use warnings;
52
53 use HTML::Mason;
54 use HTML::RewriteAttributes::Links;
55 use HTML::RewriteAttributes::Resources;
56 use MIME::Types;
57 use POSIX 'tzset';
58 use RT::Dashboard;
59 use RT::Interface::Web::Handler;
60 use RT::Interface::Web;
61 use File::Temp 'tempdir';
62 use HTML::Scrubber;
63 use URI::QueryParam;
64
65 sub MailDashboards {
66     my $self = shift;
67     my %args = (
68         All    => 0,
69         DryRun => 0,
70         Time   => time,
71         @_,
72     );
73
74     $RT::Logger->debug("Using time $args{Time} for dashboard generation");
75
76     my $from = $self->GetFrom();
77     $RT::Logger->debug("Sending email from $from");
78
79     # look through each user for her subscriptions
80     my $Users = RT::Users->new(RT->SystemUser);
81     $Users->LimitToPrivileged;
82
83     while (defined(my $user = $Users->Next)) {
84         if ($user->PrincipalObj->Disabled) {
85             $RT::Logger->debug("Skipping over " . $user->Name . " due to having a disabled account.");
86             next;
87         }
88
89         my ($hour, $dow, $dom) = HourDowDomIn($args{Time}, $user->Timezone || RT->Config->Get('Timezone'));
90         $hour .= ':00';
91         $RT::Logger->debug("Checking ".$user->Name."'s subscriptions: hour $hour, dow $dow, dom $dom");
92
93         my $currentuser = RT::CurrentUser->new;
94         $currentuser->LoadByName($user->Name);
95
96         # look through this user's subscriptions, are any supposed to be generated
97         # right now?
98         for my $subscription ($user->Attributes->Named('Subscription')) {
99             next unless $self->IsSubscriptionReady(
100                 %args,
101                 Subscription => $subscription,
102                 User         => $user,
103                 LocalTime    => [$hour, $dow, $dom],
104             );
105
106             my $email = $subscription->SubValue('Recipient')
107                      || $user->EmailAddress;
108
109             eval {
110                 $self->SendDashboard(
111                     %args,
112                     CurrentUser  => $currentuser,
113                     Email        => $email,
114                     Subscription => $subscription,
115                     From         => $from,
116                 )
117             };
118             if ( $@ ) {
119                 $RT::Logger->error("Caught exception: $@");
120             }
121             else {
122                 my $counter = $subscription->SubValue('Counter') || 0;
123                 $subscription->SetSubValues(Counter => $counter + 1)
124                     unless $args{DryRun};
125             }
126         }
127     }
128 }
129
130 sub IsSubscriptionReady {
131     my $self = shift;
132     my %args = (
133         All          => 0,
134         Subscription => undef,
135         User         => undef,
136         LocalTime    => [0, 0, 0],
137         @_,
138     );
139
140     return 1 if $args{All};
141
142     my $subscription  = $args{Subscription};
143
144     my $counter       = $subscription->SubValue('Counter') || 0;
145
146     my $sub_frequency = $subscription->SubValue('Frequency');
147     my $sub_hour      = $subscription->SubValue('Hour');
148     my $sub_dow       = $subscription->SubValue('Dow');
149     my $sub_dom       = $subscription->SubValue('Dom');
150     my $sub_fow       = $subscription->SubValue('Fow') || 1;
151
152     my ($hour, $dow, $dom) = @{ $args{LocalTime} };
153
154     $RT::Logger->debug("Checking against subscription " . $subscription->Id . " for " . $args{User}->Name . " with frequency $sub_frequency, hour $sub_hour, dow $sub_dow, dom $sub_dom, fow $sub_fow, counter $counter");
155
156     return 0 if $sub_frequency eq 'never';
157
158     # correct hour?
159     return 0 if $sub_hour ne $hour;
160
161     # all we need is the correct hour for daily dashboards
162     return 1 if $sub_frequency eq 'daily';
163
164     if ($sub_frequency eq 'weekly') {
165         # correct day of week?
166         return 0 if $sub_dow ne $dow;
167
168         # does it match the "every N weeks" clause?
169         return 1 if $counter % $sub_fow == 0;
170
171         $subscription->SetSubValues(Counter => $counter + 1)
172             unless $args{DryRun};
173         return 0;
174     }
175
176     # if monthly, correct day of month?
177     if ($sub_frequency eq 'monthly') {
178         return $sub_dom == $dom;
179     }
180
181     # monday through friday
182     if ($sub_frequency eq 'm-f') {
183         return 0 if $dow eq 'Sunday' || $dow eq 'Saturday';
184         return 1;
185     }
186
187     $RT::Logger->debug("Invalid subscription frequency $sub_frequency for " . $args{User}->Name);
188
189     # unknown frequency type, bail out
190     return 0;
191 }
192
193 sub GetFrom {
194     RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
195 }
196
197 sub SendDashboard {
198     my $self = shift;
199     my %args = (
200         CurrentUser  => undef,
201         Email        => undef,
202         Subscription => undef,
203         DryRun       => 0,
204         @_,
205     );
206
207     my $currentuser  = $args{CurrentUser};
208     my $subscription = $args{Subscription};
209
210     my $rows = $subscription->SubValue('Rows');
211
212     my $DashboardId = $subscription->SubValue('DashboardId');
213
214     my $dashboard = RT::Dashboard->new($currentuser);
215     my ($ok, $msg) = $dashboard->LoadById($DashboardId);
216
217     # failed to load dashboard. perhaps it was deleted or it changed privacy
218     if (!$ok) {
219         $RT::Logger->warning("Unable to load dashboard $DashboardId of subscription ".$subscription->Id." for user ".$currentuser->Name.": $msg");
220         return $self->ObsoleteSubscription(
221             %args,
222             Subscription => $subscription,
223         );
224     }
225
226     $RT::Logger->debug('Generating dashboard "'.$dashboard->Name.'" for user "'.$currentuser->Name.'":');
227
228     if ($args{DryRun}) {
229         print << "SUMMARY";
230     Dashboard: @{[ $dashboard->Name ]}
231     User:   @{[ $currentuser->Name ]} <$args{Email}>
232 SUMMARY
233         return;
234     }
235
236     local $HTML::Mason::Commands::session{CurrentUser} = $currentuser;
237     local $HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new;
238
239     my $content = RunComponent(
240         '/Dashboards/Render.html',
241         id      => $dashboard->Id,
242         Preview => 0,
243     );
244
245     if ( RT->Config->Get('EmailDashboardRemove') ) {
246         for ( RT->Config->Get('EmailDashboardRemove') ) {
247             $content =~ s/$_//g;
248         }
249     }
250
251     $content = ScrubContent($content);
252
253     $RT::Logger->debug("Got ".length($content)." characters of output.");
254
255     $content = HTML::RewriteAttributes::Links->rewrite(
256         $content,
257         RT->Config->Get('WebURL') . 'Dashboards/Render.html',
258     );
259
260     $self->EmailDashboard(
261         %args,
262         Dashboard => $dashboard,
263         Content   => $content,
264     );
265 }
266
267 sub ObsoleteSubscription {
268     my $self = shift;
269     my %args = (
270         From         => undef,
271         To           => undef,
272         Subscription => undef,
273         CurrentUser  => undef,
274         @_,
275     );
276
277     my $subscription = $args{Subscription};
278
279     my $ok = RT::Interface::Email::SendEmailUsingTemplate(
280         From      => $args{From},
281         To        => $args{Email},
282         Template  => 'Error: Missing dashboard',
283         Arguments => {
284             SubscriptionObj => $subscription,
285         },
286         ExtraHeaders => {
287             'X-RT-Dashboard-Subscription-Id' => $subscription->Id,
288             'X-RT-Dashboard-Id' => $subscription->SubValue('DashboardId'),
289         },
290     );
291
292     # only delete the subscription if the email looks like it went through
293     if ($ok) {
294         my ($deleted, $msg) = $subscription->Delete();
295         if ($deleted) {
296             $RT::Logger->debug("Deleted an obsolete subscription: $msg");
297         }
298         else {
299             $RT::Logger->warning("Unable to delete an obsolete subscription: $msg");
300         }
301     }
302     else {
303         $RT::Logger->warning("Unable to notify ".$args{CurrentUser}->Name." of an obsolete subscription");
304     }
305 }
306
307 sub EmailDashboard {
308     my $self = shift;
309     my %args = (
310         CurrentUser  => undef,
311         Email        => undef,
312         Dashboard    => undef,
313         Subscription => undef,
314         Content      => undef,
315         @_,
316     );
317
318     my $subscription = $args{Subscription};
319     my $dashboard    = $args{Dashboard};
320     my $currentuser  = $args{CurrentUser};
321     my $email        = $args{Email};
322
323     my $frequency    = $subscription->SubValue('Frequency');
324
325     my %frequency_lookup = (
326         'm-f'     => 'Weekday', # loc
327         'daily'   => 'Daily',   # loc
328         'weekly'  => 'Weekly',  # loc
329         'monthly' => 'Monthly', # loc
330         'never'   => 'Never',   # loc
331     );
332
333     my $frequency_display = $frequency_lookup{$frequency}
334                          || $frequency;
335
336     my $subject = sprintf '[%s] ' .  RT->Config->Get('DashboardSubject'),
337         RT->Config->Get('rtname'),
338         $currentuser->loc($frequency_display),
339         $dashboard->Name;
340
341     my $entity = $self->BuildEmail(
342         %args,
343         To      => $email,
344         Subject => $subject,
345     );
346
347     $entity->head->replace('X-RT-Dashboard-Id', $dashboard->Id);
348     $entity->head->replace('X-RT-Dashboard-Subscription-Id', $subscription->Id);
349
350     $RT::Logger->debug('Mailing dashboard "'.$dashboard->Name.'" to user '.$currentuser->Name." <$email>");
351
352     my $ok = RT::Interface::Email::SendEmail(
353         %{ RT->Config->Get('Crypt')->{'Dashboards'} || {} },
354         Entity => $entity,
355     );
356
357     if (!$ok) {
358         $RT::Logger->error("Failed to email dashboard to user ".$currentuser->Name." <$email>");
359         return;
360     }
361
362     $RT::Logger->debug("Done sending dashboard to ".$currentuser->Name." <$email>");
363 }
364
365 sub BuildEmail {
366     my $self = shift;
367     my %args = (
368         Content => undef,
369         From    => undef,
370         To      => undef,
371         Subject => undef,
372         @_,
373     );
374
375     my @parts;
376     my %cid_of;
377
378     my $content = HTML::RewriteAttributes::Resources->rewrite($args{Content}, sub {
379             my $uri = shift;
380
381             # already attached this object
382             return "cid:$cid_of{$uri}" if $cid_of{$uri};
383
384             my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
385             return $uri unless defined $data;
386
387             $cid_of{$uri} = time() . $$ . int(rand(1e6));
388
389             # Encode textual data in UTF-8, and downgrade (treat
390             # codepoints as codepoints, and ensure the UTF-8 flag is
391             # off) everything else.
392             my @extra;
393             if ( $mimetype =~ m{text/} ) {
394                 $data = Encode::encode( "UTF-8", $data );
395                 @extra = ( Charset => "UTF-8" );
396             } else {
397                 utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
398             }
399
400             push @parts, MIME::Entity->build(
401                 Top          => 0,
402                 Data         => $data,
403                 Type         => $mimetype,
404                 Encoding     => $encoding,
405                 Disposition  => 'inline',
406                 Name         => RT::Interface::Email::EncodeToMIME( String => $filename ),
407                 'Content-Id' => $cid_of{$uri},
408                 @extra,
409             );
410
411             return "cid:$cid_of{$uri}";
412         },
413         inline_css => sub {
414             my $uri = shift;
415             my ($content) = GetResource($uri);
416             return defined $content ? $content : "";
417         },
418         inline_imports => 1,
419     );
420
421     my $entity = MIME::Entity->build(
422         From    => Encode::encode("UTF-8", $args{From}),
423         To      => Encode::encode("UTF-8", $args{To}),
424         Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
425         Type    => "multipart/mixed",
426     );
427
428     $entity->attach(
429         Type        => 'text/html',
430         Charset     => 'UTF-8',
431         Data        => Encode::encode("UTF-8", $content),
432         Disposition => 'inline',
433         Encoding    => "base64",
434     );
435
436     for my $part (@parts) {
437         $entity->add_part($part);
438     }
439
440     $entity->make_singlepart;
441
442     return $entity;
443 }
444
445 {
446     my $mason;
447     my $outbuf = '';
448     my $data_dir = '';
449
450     sub _mason {
451         unless ($mason) {
452             $RT::Logger->debug("Creating Mason object.");
453
454             # user may not have permissions on the data directory, so create a
455             # new one
456             $data_dir = tempdir(CLEANUP => 1);
457
458             $mason = HTML::Mason::Interp->new(
459                 RT::Interface::Web::Handler->DefaultHandlerArgs,
460                 out_method => \$outbuf,
461                 autohandler_name => '', # disable forced login and more
462                 data_dir => $data_dir,
463             );
464             $mason->set_escape( h => \&RT::Interface::Web::EscapeHTML );
465             $mason->set_escape( u => \&RT::Interface::Web::EscapeURI  );
466             $mason->set_escape( j => \&RT::Interface::Web::EscapeJS   );
467         }
468         return $mason;
469     }
470
471     sub RunComponent {
472         _mason->exec(@_);
473         my $ret = $outbuf;
474         $outbuf = '';
475         return $ret;
476     }
477 }
478
479 {
480     my $scrubber;
481
482     sub _scrubber {
483         unless ($scrubber) {
484             $scrubber = HTML::Scrubber->new;
485             # Allow everything by default, except JS attributes ...
486             $scrubber->default(
487                 1 => {
488                     '*' => 1,
489                     map { ("on$_" => 0) }
490                          qw(blur change click dblclick error focus keydown keypress keyup load
491                             mousedown mousemove mouseout mouseover mouseup reset select submit unload)
492                 }
493             );
494             # ... and <script>s
495             $scrubber->deny('script');
496         }
497         return $scrubber;
498     }
499
500     sub ScrubContent {
501         my $content = shift;
502         return _scrubber->scrub($content);
503     }
504 }
505
506 {
507     my %cache;
508
509     sub HourDowDomIn {
510         my $now = shift;
511         my $tz  = shift;
512
513         my $key = "$now $tz";
514         return @{$cache{$key}} if exists $cache{$key};
515
516         my ($hour, $dow, $dom);
517
518         {
519             local $ENV{'TZ'} = $tz;
520             ## Using POSIX::tzset fixes a bug where the TZ environment variable
521             ## is cached.
522             tzset();
523             (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
524         }
525         tzset(); # return back previous value
526
527         $hour = "0$hour"
528             if length($hour) == 1;
529         $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];
530
531         return @{$cache{$key}} = ($hour, $dow, $dom);
532     }
533 }
534
535 sub GetResource {
536     my $uri = URI->new(shift);
537     my ($content, $content_type, $filename, $mimetype, $encoding);
538
539     # Avoid trying to inline any remote URIs.  We absolutified all URIs
540     # using WebURL in SendDashboard() above, so choose the simpler match on
541     # that rather than testing a bunch of URI accessors.
542     my $WebURL = RT->Config->Get("WebURL");
543     return unless $uri =~ /^\Q$WebURL/;
544
545     $RT::Logger->debug("Getting resource $uri");
546
547     # strip out the equivalent of WebURL, so we start at the correct /
548     my $path = $uri->path;
549     my $webpath = RT->Config->Get('WebPath');
550     $path =~ s/^\Q$webpath//;
551
552     # add a leading / if needed
553     $path = "/$path"
554         unless $path =~ m{^/};
555
556     # Try the static handler first for non-Mason CSS, JS, etc.
557     my $res = RT::Interface::Web::Handler->GetStatic($path);
558     if ($res->is_success) {
559         RT->Logger->debug("Fetched '$path' from the static handler");
560         $content      = $res->decoded_content;
561         $content_type = $res->headers->content_type;
562     } else {
563         # Try it through Mason instead...
564         $HTML::Mason::Commands::r->path_info($path);
565
566         # grab the query arguments
567         my %args = map { $_ => [ map {Encode::decode("UTF-8",$_)}
568                                      $uri->query_param($_) ] } $uri->query_param;
569         # Convert empty and single element arrayrefs to a non-ref scalar
570         @$_ < 2 and $_ = $_->[0]
571             for values %args;
572
573         $RT::Logger->debug("Running component '$path'");
574         $content = RunComponent($path, %args);
575
576         $content_type = $HTML::Mason::Commands::r->content_type;
577     }
578
579     # guess at the filename from the component name
580     $filename = $1 if $path =~ m{^.*/(.*?)$};
581
582     # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
583     ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
584
585     if ($content_type) {
586         $mimetype = $content_type;
587
588         # strip down to just a MIME type
589         $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
590     }
591
592     #If all else fails then some conservative and general-purpose defaults are:
593     $mimetype ||= 'application/octet-stream';
594     $encoding ||= 'base64';
595
596     $RT::Logger->debug("Resource $uri: length=".length($content)." filename='$filename' mimetype='$mimetype', encoding='$encoding'");
597
598     return ($content, $filename, $mimetype, $encoding);
599 }
600
601
602 {
603     package RT::Dashboard::FakeRequest;
604     sub new { bless {}, shift }
605     sub header_out { return undef }
606     sub headers_out { wantarray ? () : {} }
607     sub err_headers_out { wantarray ? () : {} }
608     sub content_type {
609         my $self = shift;
610         $self->{content_type} = shift if @_;
611         return $self->{content_type};
612     }
613     sub path_info {
614         my $self = shift;
615         $self->{path_info} = shift if @_;
616         return $self->{path_info};
617     }
618 }
619
620 RT::Base->_ImportOverlays();
621
622 1;
623