Upgrade to 4.0.13
[usit-rt.git] / lib / RT / Dashboard / Mailer.pm
CommitLineData
84fb5b46
MKG
1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
403d7b0b 5# This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
84fb5b46
MKG
6# <sales@bestpractical.com>
7#
8# (Except where explicitly superseded by other copyright notices)
9#
10#
11# LICENSE:
12#
13# This work is made available to you under the terms of Version 2 of
14# the GNU General Public License. A copy of that license should have
15# been provided with this software, but in any event can be snarfed
16# from www.gnu.org.
17#
18# This work is distributed in the hope that it will be useful, but
19# WITHOUT ANY WARRANTY; without even the implied warranty of
20# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21# General Public License for more details.
22#
23# You should have received a copy of the GNU General Public License
24# along with this program; if not, write to the Free Software
25# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26# 02110-1301 or visit their web page on the internet at
27# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28#
29#
30# CONTRIBUTION SUBMISSION POLICY:
31#
32# (The following paragraph is not intended to limit the rights granted
33# to you to modify and distribute this software under the terms of
34# the GNU General Public License and is only of importance to you if
35# you choose to contribute your changes and enhancements to the
36# community by submitting them to Best Practical Solutions, LLC.)
37#
38# By intentionally submitting any modifications, corrections or
39# derivatives to this work, or any other work intended for use with
40# Request Tracker, to Best Practical Solutions, LLC, you confirm that
41# you are the copyright holder for those contributions and you grant
42# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43# royalty-free, perpetual, license to use, copy, create derivative
44# works based on those contributions, and sublicense and distribute
45# those contributions and any derivatives thereof.
46#
47# END BPS TAGGED BLOCK }}}
48
49package RT::Dashboard::Mailer;
50use strict;
51use warnings;
52
53use HTML::Mason;
54use HTML::RewriteAttributes::Links;
55use HTML::RewriteAttributes::Resources;
56use MIME::Types;
57use POSIX 'tzset';
58use RT::Dashboard;
59use RT::Interface::Web::Handler;
60use RT::Interface::Web;
61use File::Temp 'tempdir';
403d7b0b 62use HTML::Scrubber;
84fb5b46
MKG
63
64sub 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
129sub 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
194sub GetFrom {
195 RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
196}
197
198sub 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}>
233SUMMARY
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
403d7b0b
MKG
252 $content = ScrubContent($content);
253
84fb5b46
MKG
254 $RT::Logger->debug("Got ".length($content)." characters of output.");
255
256 $content = HTML::RewriteAttributes::Links->rewrite(
257 $content,
b5747ff2 258 RT->Config->Get('WebURL') . 'Dashboards/Render.html',
84fb5b46
MKG
259 );
260
261 $self->EmailDashboard(
262 %args,
263 Dashboard => $dashboard,
264 Content => $content,
265 );
266}
267
268sub 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
308sub 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
365sub 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',
5b0d0914 399 Name => RT::Interface::Email::EncodeToMIME( String => $filename ),
84fb5b46
MKG
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(
5b0d0914
MKG
414 From => Encode::encode_utf8($args{From}),
415 To => Encode::encode_utf8($args{To}),
416 Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
84fb5b46
MKG
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{
403d7b0b
MKG
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{
84fb5b46
MKG
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
524sub 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 }
403d7b0b
MKG
593 sub header_out { return undef }
594 sub headers_out { wantarray ? () : {} }
595 sub err_headers_out { wantarray ? () : {} }
84fb5b46
MKG
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
608RT::Base->_ImportOverlays();
609
6101;
611