Upgrade to 4.2.2
[usit-rt.git] / lib / RT / Dashboard / Mailer.pm
CommitLineData
84fb5b46
MKG
1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
320f0092 5# This software is Copyright (c) 1996-2014 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;
af59614d 63use URI::QueryParam;
84fb5b46
MKG
64
65sub 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
130sub 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');
320f0092 150 my $sub_fow = $subscription->SubValue('Fow') || 1;
84fb5b46
MKG
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?
84fb5b46
MKG
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
193sub GetFrom {
194 RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
195}
196
197sub 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}>
232SUMMARY
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
403d7b0b
MKG
251 $content = ScrubContent($content);
252
84fb5b46
MKG
253 $RT::Logger->debug("Got ".length($content)." characters of output.");
254
255 $content = HTML::RewriteAttributes::Links->rewrite(
256 $content,
b5747ff2 257 RT->Config->Get('WebURL') . 'Dashboards/Render.html',
84fb5b46
MKG
258 );
259
260 $self->EmailDashboard(
261 %args,
262 Dashboard => $dashboard,
263 Content => $content,
264 );
265}
266
267sub 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
307sub 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(
af59614d 353 %{ RT->Config->Get('Crypt')->{'Dashboards'} || {} },
84fb5b46
MKG
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
84fb5b46 384 my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
af59614d
MKG
385 return $uri unless defined $data;
386
387 $cid_of{$uri} = time() . $$ . int(rand(1e6));
84fb5b46
MKG
388
389 # downgrade non-text strings, because all strings are utf8 by
390 # default, which is wrong for non-text strings.
391 if ( $mimetype !~ m{text/} ) {
392 utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
393 }
394
395 push @parts, MIME::Entity->build(
396 Top => 0,
397 Data => $data,
398 Type => $mimetype,
399 Encoding => $encoding,
400 Disposition => 'inline',
5b0d0914 401 Name => RT::Interface::Email::EncodeToMIME( String => $filename ),
84fb5b46
MKG
402 'Content-Id' => $cid_of{$uri},
403 );
404
405 return "cid:$cid_of{$uri}";
406 },
407 inline_css => sub {
408 my $uri = shift;
409 my ($content) = GetResource($uri);
af59614d 410 return defined $content ? $content : "";
84fb5b46
MKG
411 },
412 inline_imports => 1,
413 );
414
415 my $entity = MIME::Entity->build(
5b0d0914
MKG
416 From => Encode::encode_utf8($args{From}),
417 To => Encode::encode_utf8($args{To}),
418 Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
84fb5b46
MKG
419 Type => "multipart/mixed",
420 );
421
422 $entity->attach(
423 Data => Encode::encode_utf8($content),
424 Type => 'text/html',
425 Charset => 'UTF-8',
426 Disposition => 'inline',
320f0092 427 Encoding => "base64",
84fb5b46
MKG
428 );
429
430 for my $part (@parts) {
431 $entity->add_part($part);
432 }
433
320f0092
MKG
434 $entity->make_singlepart;
435
84fb5b46
MKG
436 return $entity;
437}
438
439{
440 my $mason;
441 my $outbuf = '';
442 my $data_dir = '';
443
444 sub _mason {
445 unless ($mason) {
446 $RT::Logger->debug("Creating Mason object.");
447
448 # user may not have permissions on the data directory, so create a
449 # new one
450 $data_dir = tempdir(CLEANUP => 1);
451
452 $mason = HTML::Mason::Interp->new(
453 RT::Interface::Web::Handler->DefaultHandlerArgs,
454 out_method => \$outbuf,
455 autohandler_name => '', # disable forced login and more
456 data_dir => $data_dir,
457 );
af59614d 458 $mason->set_escape( h => \&RT::Interface::Web::EscapeHTML );
84fb5b46
MKG
459 $mason->set_escape( u => \&RT::Interface::Web::EscapeURI );
460 $mason->set_escape( j => \&RT::Interface::Web::EscapeJS );
461 }
462 return $mason;
463 }
464
465 sub RunComponent {
466 _mason->exec(@_);
467 my $ret = $outbuf;
468 $outbuf = '';
469 return $ret;
470 }
471}
472
473{
403d7b0b
MKG
474 my $scrubber;
475
476 sub _scrubber {
477 unless ($scrubber) {
478 $scrubber = HTML::Scrubber->new;
479 # Allow everything by default, except JS attributes ...
480 $scrubber->default(
481 1 => {
482 '*' => 1,
483 map { ("on$_" => 0) }
484 qw(blur change click dblclick error focus keydown keypress keyup load
485 mousedown mousemove mouseout mouseover mouseup reset select submit unload)
486 }
487 );
488 # ... and <script>s
489 $scrubber->deny('script');
490 }
491 return $scrubber;
492 }
493
494 sub ScrubContent {
495 my $content = shift;
496 return _scrubber->scrub($content);
497 }
498}
499
500{
84fb5b46
MKG
501 my %cache;
502
503 sub HourDowDomIn {
504 my $now = shift;
505 my $tz = shift;
506
507 my $key = "$now $tz";
508 return @{$cache{$key}} if exists $cache{$key};
509
510 my ($hour, $dow, $dom);
511
512 {
513 local $ENV{'TZ'} = $tz;
514 ## Using POSIX::tzset fixes a bug where the TZ environment variable
515 ## is cached.
516 tzset();
517 (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
518 }
519 tzset(); # return back previous value
520
521 $hour = "0$hour"
522 if length($hour) == 1;
523 $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];
524
525 return @{$cache{$key}} = ($hour, $dow, $dom);
526 }
527}
528
529sub GetResource {
530 my $uri = URI->new(shift);
af59614d
MKG
531 my ($content, $content_type, $filename, $mimetype, $encoding);
532
533 # Avoid trying to inline any remote URIs. We absolutified all URIs
534 # using WebURL in SendDashboard() above, so choose the simpler match on
535 # that rather than testing a bunch of URI accessors.
536 my $WebURL = RT->Config->Get("WebURL");
537 return unless $uri =~ /^\Q$WebURL/;
84fb5b46
MKG
538
539 $RT::Logger->debug("Getting resource $uri");
540
541 # strip out the equivalent of WebURL, so we start at the correct /
542 my $path = $uri->path;
543 my $webpath = RT->Config->Get('WebPath');
544 $path =~ s/^\Q$webpath//;
545
546 # add a leading / if needed
547 $path = "/$path"
548 unless $path =~ m{^/};
549
af59614d
MKG
550 # Try the static handler first for non-Mason CSS, JS, etc.
551 my $res = RT::Interface::Web::Handler->GetStatic($path);
552 if ($res->is_success) {
553 RT->Logger->debug("Fetched '$path' from the static handler");
554 $content = $res->decoded_content;
555 $content_type = $res->headers->content_type;
556 } else {
557 # Try it through Mason instead...
558 $HTML::Mason::Commands::r->path_info($path);
559
560 # grab the query arguments
561 my %args = map { $_ => [ $uri->query_param($_) ] } $uri->query_param;
562 # Convert empty and single element arrayrefs to a non-ref scalar
563 @$_ < 2 and $_ = $_->[0]
564 for values %args;
565
566 $RT::Logger->debug("Running component '$path'");
567 $content = RunComponent($path, %args);
568
569 $content_type = $HTML::Mason::Commands::r->content_type;
84fb5b46
MKG
570 }
571
84fb5b46
MKG
572 # guess at the filename from the component name
573 $filename = $1 if $path =~ m{^.*/(.*?)$};
574
575 # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
576 ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
577
84fb5b46
MKG
578 if ($content_type) {
579 $mimetype = $content_type;
580
581 # strip down to just a MIME type
582 $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
583 }
584
585 #If all else fails then some conservative and general-purpose defaults are:
586 $mimetype ||= 'application/octet-stream';
587 $encoding ||= 'base64';
588
589 $RT::Logger->debug("Resource $uri: length=".length($content)." filename='$filename' mimetype='$mimetype', encoding='$encoding'");
590
591 return ($content, $filename, $mimetype, $encoding);
592}
593
594
595{
596 package RT::Dashboard::FakeRequest;
597 sub new { bless {}, shift }
403d7b0b
MKG
598 sub header_out { return undef }
599 sub headers_out { wantarray ? () : {} }
600 sub err_headers_out { wantarray ? () : {} }
84fb5b46
MKG
601 sub content_type {
602 my $self = shift;
603 $self->{content_type} = shift if @_;
604 return $self->{content_type};
605 }
606 sub path_info {
607 my $self = shift;
608 $self->{path_info} = shift if @_;
609 return $self->{path_info};
610 }
611}
612
613RT::Base->_ImportOverlays();
614
6151;
616