0ad2fb238afbe1881bd75e50e3c026f23f4b7768
[usit-rt.git] / lib / RT / Dashboard / Mailer.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 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
64 sub MailDashboards {
65     my $self = shift;
66     my %args = (
67         All    => 0,
68         DryRun => 0,
69         Time   => time,
70         @_,
71     );
72
73     $RT::Logger->debug("Using time $args{Time} for dashboard generation");
74
75     my $from = $self->GetFrom();
76     $RT::Logger->debug("Sending email from $from");
77
78     # look through each user for her subscriptions
79     my $Users = RT::Users->new(RT->SystemUser);
80     $Users->LimitToPrivileged;
81
82     while (defined(my $user = $Users->Next)) {
83         if ($user->PrincipalObj->Disabled) {
84             $RT::Logger->debug("Skipping over " . $user->Name . " due to having a disabled account.");
85             next;
86         }
87
88         my ($hour, $dow, $dom) = HourDowDomIn($args{Time}, $user->Timezone || RT->Config->Get('Timezone'));
89         $hour .= ':00';
90         $RT::Logger->debug("Checking ".$user->Name."'s subscriptions: hour $hour, dow $dow, dom $dom");
91
92         my $currentuser = RT::CurrentUser->new;
93         $currentuser->LoadByName($user->Name);
94
95         # look through this user's subscriptions, are any supposed to be generated
96         # right now?
97         for my $subscription ($user->Attributes->Named('Subscription')) {
98             next unless $self->IsSubscriptionReady(
99                 %args,
100                 Subscription => $subscription,
101                 User         => $user,
102                 LocalTime    => [$hour, $dow, $dom],
103             );
104
105             my $email = $subscription->SubValue('Recipient')
106                      || $user->EmailAddress;
107
108             eval {
109                 $self->SendDashboard(
110                     %args,
111                     CurrentUser  => $currentuser,
112                     Email        => $email,
113                     Subscription => $subscription,
114                     From         => $from,
115                 )
116             };
117             if ( $@ ) {
118                 $RT::Logger->error("Caught exception: $@");
119             }
120             else {
121                 my $counter = $subscription->SubValue('Counter') || 0;
122                 $subscription->SetSubValues(Counter => $counter + 1)
123                     unless $args{DryRun};
124             }
125         }
126     }
127 }
128
129 sub IsSubscriptionReady {
130     my $self = shift;
131     my %args = (
132         All          => 0,
133         Subscription => undef,
134         User         => undef,
135         LocalTime    => [0, 0, 0],
136         @_,
137     );
138
139     return 1 if $args{All};
140
141     my $subscription  = $args{Subscription};
142
143     my $counter       = $subscription->SubValue('Counter') || 0;
144
145     my $sub_frequency = $subscription->SubValue('Frequency');
146     my $sub_hour      = $subscription->SubValue('Hour');
147     my $sub_dow       = $subscription->SubValue('Dow');
148     my $sub_dom       = $subscription->SubValue('Dom');
149     my $sub_fow       = $subscription->SubValue('Fow');
150
151     my ($hour, $dow, $dom) = @{ $args{LocalTime} };
152
153     $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");
154
155     return 0 if $sub_frequency eq 'never';
156
157     # correct hour?
158     return 0 if $sub_hour ne $hour;
159
160     # all we need is the correct hour for daily dashboards
161     return 1 if $sub_frequency eq 'daily';
162
163     if ($sub_frequency eq 'weekly') {
164         # correct day of week?
165         return 0 if $sub_dow ne $dow;
166
167         # does it match the "every N weeks" clause?
168         $sub_fow = 1 if !$sub_fow;
169
170         return 1 if $counter % $sub_fow == 0;
171
172         $subscription->SetSubValues(Counter => $counter + 1)
173             unless $args{DryRun};
174         return 0;
175     }
176
177     # if monthly, correct day of month?
178     if ($sub_frequency eq 'monthly') {
179         return $sub_dom == $dom;
180     }
181
182     # monday through friday
183     if ($sub_frequency eq 'm-f') {
184         return 0 if $dow eq 'Sunday' || $dow eq 'Saturday';
185         return 1;
186     }
187
188     $RT::Logger->debug("Invalid subscription frequency $sub_frequency for " . $args{User}->Name);
189
190     # unknown frequency type, bail out
191     return 0;
192 }
193
194 sub GetFrom {
195     RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
196 }
197
198 sub SendDashboard {
199     my $self = shift;
200     my %args = (
201         CurrentUser  => undef,
202         Email        => undef,
203         Subscription => undef,
204         DryRun       => 0,
205         @_,
206     );
207
208     my $currentuser  = $args{CurrentUser};
209     my $subscription = $args{Subscription};
210
211     my $rows = $subscription->SubValue('Rows');
212
213     my $DashboardId = $subscription->SubValue('DashboardId');
214
215     my $dashboard = RT::Dashboard->new($currentuser);
216     my ($ok, $msg) = $dashboard->LoadById($DashboardId);
217
218     # failed to load dashboard. perhaps it was deleted or it changed privacy
219     if (!$ok) {
220         $RT::Logger->warning("Unable to load dashboard $DashboardId of subscription ".$subscription->Id." for user ".$currentuser->Name.": $msg");
221         return $self->ObsoleteSubscription(
222             %args,
223             Subscription => $subscription,
224         );
225     }
226
227     $RT::Logger->debug('Generating dashboard "'.$dashboard->Name.'" for user "'.$currentuser->Name.'":');
228
229     if ($args{DryRun}) {
230         print << "SUMMARY";
231     Dashboard: @{[ $dashboard->Name ]}
232     User:   @{[ $currentuser->Name ]} <$args{Email}>
233 SUMMARY
234         return;
235     }
236
237     local $HTML::Mason::Commands::session{CurrentUser} = $currentuser;
238     local $HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new;
239
240     my $content = RunComponent(
241         '/Dashboards/Render.html',
242         id      => $dashboard->Id,
243         Preview => 0,
244     );
245
246     if ( RT->Config->Get('EmailDashboardRemove') ) {
247         for ( RT->Config->Get('EmailDashboardRemove') ) {
248             $content =~ s/$_//g;
249         }
250     }
251
252     $content = ScrubContent($content);
253
254     $RT::Logger->debug("Got ".length($content)." characters of output.");
255
256     $content = HTML::RewriteAttributes::Links->rewrite(
257         $content,
258         RT->Config->Get('WebURL') . 'Dashboards/Render.html',
259     );
260
261     $self->EmailDashboard(
262         %args,
263         Dashboard => $dashboard,
264         Content   => $content,
265     );
266 }
267
268 sub ObsoleteSubscription {
269     my $self = shift;
270     my %args = (
271         From         => undef,
272         To           => undef,
273         Subscription => undef,
274         CurrentUser  => undef,
275         @_,
276     );
277
278     my $subscription = $args{Subscription};
279
280     my $ok = RT::Interface::Email::SendEmailUsingTemplate(
281         From      => $args{From},
282         To        => $args{Email},
283         Template  => 'Error: Missing dashboard',
284         Arguments => {
285             SubscriptionObj => $subscription,
286         },
287         ExtraHeaders => {
288             'X-RT-Dashboard-Subscription-Id' => $subscription->Id,
289             'X-RT-Dashboard-Id' => $subscription->SubValue('DashboardId'),
290         },
291     );
292
293     # only delete the subscription if the email looks like it went through
294     if ($ok) {
295         my ($deleted, $msg) = $subscription->Delete();
296         if ($deleted) {
297             $RT::Logger->debug("Deleted an obsolete subscription: $msg");
298         }
299         else {
300             $RT::Logger->warning("Unable to delete an obsolete subscription: $msg");
301         }
302     }
303     else {
304         $RT::Logger->warning("Unable to notify ".$args{CurrentUser}->Name." of an obsolete subscription");
305     }
306 }
307
308 sub EmailDashboard {
309     my $self = shift;
310     my %args = (
311         CurrentUser  => undef,
312         Email        => undef,
313         Dashboard    => undef,
314         Subscription => undef,
315         Content      => undef,
316         @_,
317     );
318
319     my $subscription = $args{Subscription};
320     my $dashboard    = $args{Dashboard};
321     my $currentuser  = $args{CurrentUser};
322     my $email        = $args{Email};
323
324     my $frequency    = $subscription->SubValue('Frequency');
325
326     my %frequency_lookup = (
327         'm-f'     => 'Weekday', # loc
328         'daily'   => 'Daily',   # loc
329         'weekly'  => 'Weekly',  # loc
330         'monthly' => 'Monthly', # loc
331         'never'   => 'Never',   # loc
332     );
333
334     my $frequency_display = $frequency_lookup{$frequency}
335                          || $frequency;
336
337     my $subject = sprintf '[%s] ' .  RT->Config->Get('DashboardSubject'),
338         RT->Config->Get('rtname'),
339         $currentuser->loc($frequency_display),
340         $dashboard->Name;
341
342     my $entity = $self->BuildEmail(
343         %args,
344         To      => $email,
345         Subject => $subject,
346     );
347
348     $entity->head->replace('X-RT-Dashboard-Id', $dashboard->Id);
349     $entity->head->replace('X-RT-Dashboard-Subscription-Id', $subscription->Id);
350
351     $RT::Logger->debug('Mailing dashboard "'.$dashboard->Name.'" to user '.$currentuser->Name." <$email>");
352
353     my $ok = RT::Interface::Email::SendEmail(
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             $cid_of{$uri} = time() . $$ . int(rand(1e6));
385             my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
386
387             # downgrade non-text strings, because all strings are utf8 by
388             # default, which is wrong for non-text strings.
389             if ( $mimetype !~ m{text/} ) {
390                 utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
391             }
392
393             push @parts, MIME::Entity->build(
394                 Top          => 0,
395                 Data         => $data,
396                 Type         => $mimetype,
397                 Encoding     => $encoding,
398                 Disposition  => 'inline',
399                 Name         => $filename,
400                 'Content-Id' => $cid_of{$uri},
401             );
402
403             return "cid:$cid_of{$uri}";
404         },
405         inline_css => sub {
406             my $uri = shift;
407             my ($content) = GetResource($uri);
408             return $content;
409         },
410         inline_imports => 1,
411     );
412
413     my $entity = MIME::Entity->build(
414         From    => $args{From},
415         To      => $args{To},
416         Subject => $args{Subject},
417         Type    => "multipart/mixed",
418     );
419
420     $entity->attach(
421         Data        => Encode::encode_utf8($content),
422         Type        => 'text/html',
423         Charset     => 'UTF-8',
424         Disposition => 'inline',
425     );
426
427     for my $part (@parts) {
428         $entity->add_part($part);
429     }
430
431     return $entity;
432 }
433
434 {
435     my $mason;
436     my $outbuf = '';
437     my $data_dir = '';
438
439     sub _mason {
440         unless ($mason) {
441             $RT::Logger->debug("Creating Mason object.");
442
443             # user may not have permissions on the data directory, so create a
444             # new one
445             $data_dir = tempdir(CLEANUP => 1);
446
447             $mason = HTML::Mason::Interp->new(
448                 RT::Interface::Web::Handler->DefaultHandlerArgs,
449                 out_method => \$outbuf,
450                 autohandler_name => '', # disable forced login and more
451                 data_dir => $data_dir,
452             );
453             $mason->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
454             $mason->set_escape( u => \&RT::Interface::Web::EscapeURI  );
455             $mason->set_escape( j => \&RT::Interface::Web::EscapeJS   );
456         }
457         return $mason;
458     }
459
460     sub RunComponent {
461         _mason->exec(@_);
462         my $ret = $outbuf;
463         $outbuf = '';
464         return $ret;
465     }
466 }
467
468 {
469     my $scrubber;
470
471     sub _scrubber {
472         unless ($scrubber) {
473             $scrubber = HTML::Scrubber->new;
474             # Allow everything by default, except JS attributes ...
475             $scrubber->default(
476                 1 => {
477                     '*' => 1,
478                     map { ("on$_" => 0) }
479                          qw(blur change click dblclick error focus keydown keypress keyup load
480                             mousedown mousemove mouseout mouseover mouseup reset select submit unload)
481                 }
482             );
483             # ... and <script>s
484             $scrubber->deny('script');
485         }
486         return $scrubber;
487     }
488
489     sub ScrubContent {
490         my $content = shift;
491         return _scrubber->scrub($content);
492     }
493 }
494
495 {
496     my %cache;
497
498     sub HourDowDomIn {
499         my $now = shift;
500         my $tz  = shift;
501
502         my $key = "$now $tz";
503         return @{$cache{$key}} if exists $cache{$key};
504
505         my ($hour, $dow, $dom);
506
507         {
508             local $ENV{'TZ'} = $tz;
509             ## Using POSIX::tzset fixes a bug where the TZ environment variable
510             ## is cached.
511             tzset();
512             (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
513         }
514         tzset(); # return back previous value
515
516         $hour = "0$hour"
517             if length($hour) == 1;
518         $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];
519
520         return @{$cache{$key}} = ($hour, $dow, $dom);
521     }
522 }
523
524 sub GetResource {
525     my $uri = URI->new(shift);
526     my ($content, $filename, $mimetype, $encoding);
527
528     $RT::Logger->debug("Getting resource $uri");
529
530     # strip out the equivalent of WebURL, so we start at the correct /
531     my $path = $uri->path;
532     my $webpath = RT->Config->Get('WebPath');
533     $path =~ s/^\Q$webpath//;
534
535     # add a leading / if needed
536     $path = "/$path"
537         unless $path =~ m{^/};
538
539     $HTML::Mason::Commands::r->path_info($path);
540
541     # grab the query arguments
542     my %args;
543     for (split /&/, ($uri->query||'')) {
544         my ($k, $v) = /^(.*?)=(.*)$/
545             or die "Unable to parse query parameter '$_'";
546
547         for ($k, $v) { s/%(..)/chr hex $1/ge }
548
549         # no value yet, simple key=value
550         if (!exists $args{$k}) {
551             $args{$k} = $v;
552         }
553         # already have key=value, need to upgrade it to key=[value1, value2]
554         elsif (!ref($args{$k})) {
555             $args{$k} = [$args{$k}, $v];
556         }
557         # already key=[value1, value2], just add the new value
558         else {
559             push @{ $args{$k} }, $v;
560         }
561     }
562
563     $RT::Logger->debug("Running component '$path'");
564     $content = RunComponent($path, %args);
565
566     # guess at the filename from the component name
567     $filename = $1 if $path =~ m{^.*/(.*?)$};
568
569     # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
570     ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
571
572     my $content_type = $HTML::Mason::Commands::r->content_type;
573     if ($content_type) {
574         $mimetype = $content_type;
575
576         # strip down to just a MIME type
577         $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
578     }
579
580     #If all else fails then some conservative and general-purpose defaults are:
581     $mimetype ||= 'application/octet-stream';
582     $encoding ||= 'base64';
583
584     $RT::Logger->debug("Resource $uri: length=".length($content)." filename='$filename' mimetype='$mimetype', encoding='$encoding'");
585
586     return ($content, $filename, $mimetype, $encoding);
587 }
588
589
590 {
591     package RT::Dashboard::FakeRequest;
592     sub new { bless {}, shift }
593     sub header_out { return undef }
594     sub headers_out { wantarray ? () : {} }
595     sub err_headers_out { wantarray ? () : {} }
596     sub content_type {
597         my $self = shift;
598         $self->{content_type} = shift if @_;
599         return $self->{content_type};
600     }
601     sub path_info {
602         my $self = shift;
603         $self->{path_info} = shift if @_;
604         return $self->{path_info};
605     }
606 }
607
608 RT::Base->_ImportOverlays();
609
610 1;
611