Putting 4.2.0 on top of 4.0.17
[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 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');
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         $sub_fow = 1 if !$sub_fow;
170
171         return 1 if $counter % $sub_fow == 0;
172
173         $subscription->SetSubValues(Counter => $counter + 1)
174             unless $args{DryRun};
175         return 0;
176     }
177
178     # if monthly, correct day of month?
179     if ($sub_frequency eq 'monthly') {
180         return $sub_dom == $dom;
181     }
182
183     # monday through friday
184     if ($sub_frequency eq 'm-f') {
185         return 0 if $dow eq 'Sunday' || $dow eq 'Saturday';
186         return 1;
187     }
188
189     $RT::Logger->debug("Invalid subscription frequency $sub_frequency for " . $args{User}->Name);
190
191     # unknown frequency type, bail out
192     return 0;
193 }
194
195 sub GetFrom {
196     RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
197 }
198
199 sub SendDashboard {
200     my $self = shift;
201     my %args = (
202         CurrentUser  => undef,
203         Email        => undef,
204         Subscription => undef,
205         DryRun       => 0,
206         @_,
207     );
208
209     my $currentuser  = $args{CurrentUser};
210     my $subscription = $args{Subscription};
211
212     my $rows = $subscription->SubValue('Rows');
213
214     my $DashboardId = $subscription->SubValue('DashboardId');
215
216     my $dashboard = RT::Dashboard->new($currentuser);
217     my ($ok, $msg) = $dashboard->LoadById($DashboardId);
218
219     # failed to load dashboard. perhaps it was deleted or it changed privacy
220     if (!$ok) {
221         $RT::Logger->warning("Unable to load dashboard $DashboardId of subscription ".$subscription->Id." for user ".$currentuser->Name.": $msg");
222         return $self->ObsoleteSubscription(
223             %args,
224             Subscription => $subscription,
225         );
226     }
227
228     $RT::Logger->debug('Generating dashboard "'.$dashboard->Name.'" for user "'.$currentuser->Name.'":');
229
230     if ($args{DryRun}) {
231         print << "SUMMARY";
232     Dashboard: @{[ $dashboard->Name ]}
233     User:   @{[ $currentuser->Name ]} <$args{Email}>
234 SUMMARY
235         return;
236     }
237
238     local $HTML::Mason::Commands::session{CurrentUser} = $currentuser;
239     local $HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new;
240
241     my $content = RunComponent(
242         '/Dashboards/Render.html',
243         id      => $dashboard->Id,
244         Preview => 0,
245     );
246
247     if ( RT->Config->Get('EmailDashboardRemove') ) {
248         for ( RT->Config->Get('EmailDashboardRemove') ) {
249             $content =~ s/$_//g;
250         }
251     }
252
253     $content = ScrubContent($content);
254
255     $RT::Logger->debug("Got ".length($content)." characters of output.");
256
257     $content = HTML::RewriteAttributes::Links->rewrite(
258         $content,
259         RT->Config->Get('WebURL') . 'Dashboards/Render.html',
260     );
261
262     $self->EmailDashboard(
263         %args,
264         Dashboard => $dashboard,
265         Content   => $content,
266     );
267 }
268
269 sub ObsoleteSubscription {
270     my $self = shift;
271     my %args = (
272         From         => undef,
273         To           => undef,
274         Subscription => undef,
275         CurrentUser  => undef,
276         @_,
277     );
278
279     my $subscription = $args{Subscription};
280
281     my $ok = RT::Interface::Email::SendEmailUsingTemplate(
282         From      => $args{From},
283         To        => $args{Email},
284         Template  => 'Error: Missing dashboard',
285         Arguments => {
286             SubscriptionObj => $subscription,
287         },
288         ExtraHeaders => {
289             'X-RT-Dashboard-Subscription-Id' => $subscription->Id,
290             'X-RT-Dashboard-Id' => $subscription->SubValue('DashboardId'),
291         },
292     );
293
294     # only delete the subscription if the email looks like it went through
295     if ($ok) {
296         my ($deleted, $msg) = $subscription->Delete();
297         if ($deleted) {
298             $RT::Logger->debug("Deleted an obsolete subscription: $msg");
299         }
300         else {
301             $RT::Logger->warning("Unable to delete an obsolete subscription: $msg");
302         }
303     }
304     else {
305         $RT::Logger->warning("Unable to notify ".$args{CurrentUser}->Name." of an obsolete subscription");
306     }
307 }
308
309 sub EmailDashboard {
310     my $self = shift;
311     my %args = (
312         CurrentUser  => undef,
313         Email        => undef,
314         Dashboard    => undef,
315         Subscription => undef,
316         Content      => undef,
317         @_,
318     );
319
320     my $subscription = $args{Subscription};
321     my $dashboard    = $args{Dashboard};
322     my $currentuser  = $args{CurrentUser};
323     my $email        = $args{Email};
324
325     my $frequency    = $subscription->SubValue('Frequency');
326
327     my %frequency_lookup = (
328         'm-f'     => 'Weekday', # loc
329         'daily'   => 'Daily',   # loc
330         'weekly'  => 'Weekly',  # loc
331         'monthly' => 'Monthly', # loc
332         'never'   => 'Never',   # loc
333     );
334
335     my $frequency_display = $frequency_lookup{$frequency}
336                          || $frequency;
337
338     my $subject = sprintf '[%s] ' .  RT->Config->Get('DashboardSubject'),
339         RT->Config->Get('rtname'),
340         $currentuser->loc($frequency_display),
341         $dashboard->Name;
342
343     my $entity = $self->BuildEmail(
344         %args,
345         To      => $email,
346         Subject => $subject,
347     );
348
349     $entity->head->replace('X-RT-Dashboard-Id', $dashboard->Id);
350     $entity->head->replace('X-RT-Dashboard-Subscription-Id', $subscription->Id);
351
352     $RT::Logger->debug('Mailing dashboard "'.$dashboard->Name.'" to user '.$currentuser->Name." <$email>");
353
354     my $ok = RT::Interface::Email::SendEmail(
355         %{ RT->Config->Get('Crypt')->{'Dashboards'} || {} },
356         Entity => $entity,
357     );
358
359     if (!$ok) {
360         $RT::Logger->error("Failed to email dashboard to user ".$currentuser->Name." <$email>");
361         return;
362     }
363
364     $RT::Logger->debug("Done sending dashboard to ".$currentuser->Name." <$email>");
365 }
366
367 sub BuildEmail {
368     my $self = shift;
369     my %args = (
370         Content => undef,
371         From    => undef,
372         To      => undef,
373         Subject => undef,
374         @_,
375     );
376
377     my @parts;
378     my %cid_of;
379
380     my $content = HTML::RewriteAttributes::Resources->rewrite($args{Content}, sub {
381             my $uri = shift;
382
383             # already attached this object
384             return "cid:$cid_of{$uri}" if $cid_of{$uri};
385
386             my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
387             return $uri unless defined $data;
388
389             $cid_of{$uri} = time() . $$ . int(rand(1e6));
390
391             # downgrade non-text strings, because all strings are utf8 by
392             # default, which is wrong for non-text strings.
393             if ( $mimetype !~ m{text/} ) {
394                 utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
395             }
396
397             push @parts, MIME::Entity->build(
398                 Top          => 0,
399                 Data         => $data,
400                 Type         => $mimetype,
401                 Encoding     => $encoding,
402                 Disposition  => 'inline',
403                 Name         => RT::Interface::Email::EncodeToMIME( String => $filename ),
404                 'Content-Id' => $cid_of{$uri},
405             );
406
407             return "cid:$cid_of{$uri}";
408         },
409         inline_css => sub {
410             my $uri = shift;
411             my ($content) = GetResource($uri);
412             return defined $content ? $content : "";
413         },
414         inline_imports => 1,
415     );
416
417     my $entity = MIME::Entity->build(
418         From    => Encode::encode_utf8($args{From}),
419         To      => Encode::encode_utf8($args{To}),
420         Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
421         Type    => "multipart/mixed",
422     );
423
424     $entity->attach(
425         Data        => Encode::encode_utf8($content),
426         Type        => 'text/html',
427         Charset     => 'UTF-8',
428         Disposition => 'inline',
429     );
430
431     for my $part (@parts) {
432         $entity->add_part($part);
433     }
434
435     return $entity;
436 }
437
438 {
439     my $mason;
440     my $outbuf = '';
441     my $data_dir = '';
442
443     sub _mason {
444         unless ($mason) {
445             $RT::Logger->debug("Creating Mason object.");
446
447             # user may not have permissions on the data directory, so create a
448             # new one
449             $data_dir = tempdir(CLEANUP => 1);
450
451             $mason = HTML::Mason::Interp->new(
452                 RT::Interface::Web::Handler->DefaultHandlerArgs,
453                 out_method => \$outbuf,
454                 autohandler_name => '', # disable forced login and more
455                 data_dir => $data_dir,
456             );
457             $mason->set_escape( h => \&RT::Interface::Web::EscapeHTML );
458             $mason->set_escape( u => \&RT::Interface::Web::EscapeURI  );
459             $mason->set_escape( j => \&RT::Interface::Web::EscapeJS   );
460         }
461         return $mason;
462     }
463
464     sub RunComponent {
465         _mason->exec(@_);
466         my $ret = $outbuf;
467         $outbuf = '';
468         return $ret;
469     }
470 }
471
472 {
473     my $scrubber;
474
475     sub _scrubber {
476         unless ($scrubber) {
477             $scrubber = HTML::Scrubber->new;
478             # Allow everything by default, except JS attributes ...
479             $scrubber->default(
480                 1 => {
481                     '*' => 1,
482                     map { ("on$_" => 0) }
483                          qw(blur change click dblclick error focus keydown keypress keyup load
484                             mousedown mousemove mouseout mouseover mouseup reset select submit unload)
485                 }
486             );
487             # ... and <script>s
488             $scrubber->deny('script');
489         }
490         return $scrubber;
491     }
492
493     sub ScrubContent {
494         my $content = shift;
495         return _scrubber->scrub($content);
496     }
497 }
498
499 {
500     my %cache;
501
502     sub HourDowDomIn {
503         my $now = shift;
504         my $tz  = shift;
505
506         my $key = "$now $tz";
507         return @{$cache{$key}} if exists $cache{$key};
508
509         my ($hour, $dow, $dom);
510
511         {
512             local $ENV{'TZ'} = $tz;
513             ## Using POSIX::tzset fixes a bug where the TZ environment variable
514             ## is cached.
515             tzset();
516             (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
517         }
518         tzset(); # return back previous value
519
520         $hour = "0$hour"
521             if length($hour) == 1;
522         $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];
523
524         return @{$cache{$key}} = ($hour, $dow, $dom);
525     }
526 }
527
528 sub GetResource {
529     my $uri = URI->new(shift);
530     my ($content, $content_type, $filename, $mimetype, $encoding);
531
532     # Avoid trying to inline any remote URIs.  We absolutified all URIs
533     # using WebURL in SendDashboard() above, so choose the simpler match on
534     # that rather than testing a bunch of URI accessors.
535     my $WebURL = RT->Config->Get("WebURL");
536     return unless $uri =~ /^\Q$WebURL/;
537
538     $RT::Logger->debug("Getting resource $uri");
539
540     # strip out the equivalent of WebURL, so we start at the correct /
541     my $path = $uri->path;
542     my $webpath = RT->Config->Get('WebPath');
543     $path =~ s/^\Q$webpath//;
544
545     # add a leading / if needed
546     $path = "/$path"
547         unless $path =~ m{^/};
548
549     # Try the static handler first for non-Mason CSS, JS, etc.
550     my $res = RT::Interface::Web::Handler->GetStatic($path);
551     if ($res->is_success) {
552         RT->Logger->debug("Fetched '$path' from the static handler");
553         $content      = $res->decoded_content;
554         $content_type = $res->headers->content_type;
555     } else {
556         # Try it through Mason instead...
557         $HTML::Mason::Commands::r->path_info($path);
558
559         # grab the query arguments
560         my %args = map { $_ => [ $uri->query_param($_) ] } $uri->query_param;
561         # Convert empty and single element arrayrefs to a non-ref scalar
562         @$_ < 2 and $_ = $_->[0]
563             for values %args;
564
565         $RT::Logger->debug("Running component '$path'");
566         $content = RunComponent($path, %args);
567
568         $content_type = $HTML::Mason::Commands::r->content_type;
569     }
570
571     # guess at the filename from the component name
572     $filename = $1 if $path =~ m{^.*/(.*?)$};
573
574     # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
575     ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
576
577     if ($content_type) {
578         $mimetype = $content_type;
579
580         # strip down to just a MIME type
581         $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
582     }
583
584     #If all else fails then some conservative and general-purpose defaults are:
585     $mimetype ||= 'application/octet-stream';
586     $encoding ||= 'base64';
587
588     $RT::Logger->debug("Resource $uri: length=".length($content)." filename='$filename' mimetype='$mimetype', encoding='$encoding'");
589
590     return ($content, $filename, $mimetype, $encoding);
591 }
592
593
594 {
595     package RT::Dashboard::FakeRequest;
596     sub new { bless {}, shift }
597     sub header_out { return undef }
598     sub headers_out { wantarray ? () : {} }
599     sub err_headers_out { wantarray ? () : {} }
600     sub content_type {
601         my $self = shift;
602         $self->{content_type} = shift if @_;
603         return $self->{content_type};
604     }
605     sub path_info {
606         my $self = shift;
607         $self->{path_info} = shift if @_;
608         return $self->{path_info};
609     }
610 }
611
612 RT::Base->_ImportOverlays();
613
614 1;
615