Dev -> 4.0.6. Clean upgrade from 4.0.5-5.
[usit-rt.git] / lib / RT / Dashboard / Mailer.pm
CommitLineData
84fb5b46
MKG
1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
5# This software is Copyright (c) 1996-2012 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
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';
62
63sub MailDashboards {
64 my $self = shift;
65 my %args = (
66 All => 0,
67 DryRun => 0,
68 Time => time,
69 @_,
70 );
71
72 $RT::Logger->debug("Using time $args{Time} for dashboard generation");
73
74 my $from = $self->GetFrom();
75 $RT::Logger->debug("Sending email from $from");
76
77 # look through each user for her subscriptions
78 my $Users = RT::Users->new(RT->SystemUser);
79 $Users->LimitToPrivileged;
80
81 while (defined(my $user = $Users->Next)) {
82 if ($user->PrincipalObj->Disabled) {
83 $RT::Logger->debug("Skipping over " . $user->Name . " due to having a disabled account.");
84 next;
85 }
86
87 my ($hour, $dow, $dom) = HourDowDomIn($args{Time}, $user->Timezone || RT->Config->Get('Timezone'));
88 $hour .= ':00';
89 $RT::Logger->debug("Checking ".$user->Name."'s subscriptions: hour $hour, dow $dow, dom $dom");
90
91 my $currentuser = RT::CurrentUser->new;
92 $currentuser->LoadByName($user->Name);
93
94 # look through this user's subscriptions, are any supposed to be generated
95 # right now?
96 for my $subscription ($user->Attributes->Named('Subscription')) {
97 next unless $self->IsSubscriptionReady(
98 %args,
99 Subscription => $subscription,
100 User => $user,
101 LocalTime => [$hour, $dow, $dom],
102 );
103
104 my $email = $subscription->SubValue('Recipient')
105 || $user->EmailAddress;
106
107 eval {
108 $self->SendDashboard(
109 %args,
110 CurrentUser => $currentuser,
111 Email => $email,
112 Subscription => $subscription,
113 From => $from,
114 )
115 };
116 if ( $@ ) {
117 $RT::Logger->error("Caught exception: $@");
118 }
119 else {
120 my $counter = $subscription->SubValue('Counter') || 0;
121 $subscription->SetSubValues(Counter => $counter + 1)
122 unless $args{DryRun};
123 }
124 }
125 }
126}
127
128sub IsSubscriptionReady {
129 my $self = shift;
130 my %args = (
131 All => 0,
132 Subscription => undef,
133 User => undef,
134 LocalTime => [0, 0, 0],
135 @_,
136 );
137
138 return 1 if $args{All};
139
140 my $subscription = $args{Subscription};
141
142 my $counter = $subscription->SubValue('Counter') || 0;
143
144 my $sub_frequency = $subscription->SubValue('Frequency');
145 my $sub_hour = $subscription->SubValue('Hour');
146 my $sub_dow = $subscription->SubValue('Dow');
147 my $sub_dom = $subscription->SubValue('Dom');
148 my $sub_fow = $subscription->SubValue('Fow');
149
150 my ($hour, $dow, $dom) = @{ $args{LocalTime} };
151
152 $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");
153
154 return 0 if $sub_frequency eq 'never';
155
156 # correct hour?
157 return 0 if $sub_hour ne $hour;
158
159 # all we need is the correct hour for daily dashboards
160 return 1 if $sub_frequency eq 'daily';
161
162 if ($sub_frequency eq 'weekly') {
163 # correct day of week?
164 return 0 if $sub_dow ne $dow;
165
166 # does it match the "every N weeks" clause?
167 $sub_fow = 1 if !$sub_fow;
168
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
251 $RT::Logger->debug("Got ".length($content)." characters of output.");
252
253 $content = HTML::RewriteAttributes::Links->rewrite(
254 $content,
b5747ff2 255 RT->Config->Get('WebURL') . 'Dashboards/Render.html',
84fb5b46
MKG
256 );
257
258 $self->EmailDashboard(
259 %args,
260 Dashboard => $dashboard,
261 Content => $content,
262 );
263}
264
265sub ObsoleteSubscription {
266 my $self = shift;
267 my %args = (
268 From => undef,
269 To => undef,
270 Subscription => undef,
271 CurrentUser => undef,
272 @_,
273 );
274
275 my $subscription = $args{Subscription};
276
277 my $ok = RT::Interface::Email::SendEmailUsingTemplate(
278 From => $args{From},
279 To => $args{Email},
280 Template => 'Error: Missing dashboard',
281 Arguments => {
282 SubscriptionObj => $subscription,
283 },
284 ExtraHeaders => {
285 'X-RT-Dashboard-Subscription-Id' => $subscription->Id,
286 'X-RT-Dashboard-Id' => $subscription->SubValue('DashboardId'),
287 },
288 );
289
290 # only delete the subscription if the email looks like it went through
291 if ($ok) {
292 my ($deleted, $msg) = $subscription->Delete();
293 if ($deleted) {
294 $RT::Logger->debug("Deleted an obsolete subscription: $msg");
295 }
296 else {
297 $RT::Logger->warning("Unable to delete an obsolete subscription: $msg");
298 }
299 }
300 else {
301 $RT::Logger->warning("Unable to notify ".$args{CurrentUser}->Name." of an obsolete subscription");
302 }
303}
304
305sub EmailDashboard {
306 my $self = shift;
307 my %args = (
308 CurrentUser => undef,
309 Email => undef,
310 Dashboard => undef,
311 Subscription => undef,
312 Content => undef,
313 @_,
314 );
315
316 my $subscription = $args{Subscription};
317 my $dashboard = $args{Dashboard};
318 my $currentuser = $args{CurrentUser};
319 my $email = $args{Email};
320
321 my $frequency = $subscription->SubValue('Frequency');
322
323 my %frequency_lookup = (
324 'm-f' => 'Weekday', # loc
325 'daily' => 'Daily', # loc
326 'weekly' => 'Weekly', # loc
327 'monthly' => 'Monthly', # loc
328 'never' => 'Never', # loc
329 );
330
331 my $frequency_display = $frequency_lookup{$frequency}
332 || $frequency;
333
334 my $subject = sprintf '[%s] ' . RT->Config->Get('DashboardSubject'),
335 RT->Config->Get('rtname'),
336 $currentuser->loc($frequency_display),
337 $dashboard->Name;
338
339 my $entity = $self->BuildEmail(
340 %args,
341 To => $email,
342 Subject => $subject,
343 );
344
345 $entity->head->replace('X-RT-Dashboard-Id', $dashboard->Id);
346 $entity->head->replace('X-RT-Dashboard-Subscription-Id', $subscription->Id);
347
348 $RT::Logger->debug('Mailing dashboard "'.$dashboard->Name.'" to user '.$currentuser->Name." <$email>");
349
350 my $ok = RT::Interface::Email::SendEmail(
351 Entity => $entity,
352 );
353
354 if (!$ok) {
355 $RT::Logger->error("Failed to email dashboard to user ".$currentuser->Name." <$email>");
356 return;
357 }
358
359 $RT::Logger->debug("Done sending dashboard to ".$currentuser->Name." <$email>");
360}
361
362sub BuildEmail {
363 my $self = shift;
364 my %args = (
365 Content => undef,
366 From => undef,
367 To => undef,
368 Subject => undef,
369 @_,
370 );
371
372 my @parts;
373 my %cid_of;
374
375 my $content = HTML::RewriteAttributes::Resources->rewrite($args{Content}, sub {
376 my $uri = shift;
377
378 # already attached this object
379 return "cid:$cid_of{$uri}" if $cid_of{$uri};
380
381 $cid_of{$uri} = time() . $$ . int(rand(1e6));
382 my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
383
384 # downgrade non-text strings, because all strings are utf8 by
385 # default, which is wrong for non-text strings.
386 if ( $mimetype !~ m{text/} ) {
387 utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
388 }
389
390 push @parts, MIME::Entity->build(
391 Top => 0,
392 Data => $data,
393 Type => $mimetype,
394 Encoding => $encoding,
395 Disposition => 'inline',
396 Name => $filename,
397 'Content-Id' => $cid_of{$uri},
398 );
399
400 return "cid:$cid_of{$uri}";
401 },
402 inline_css => sub {
403 my $uri = shift;
404 my ($content) = GetResource($uri);
405 return $content;
406 },
407 inline_imports => 1,
408 );
409
410 my $entity = MIME::Entity->build(
411 From => $args{From},
412 To => $args{To},
413 Subject => $args{Subject},
414 Type => "multipart/mixed",
415 );
416
417 $entity->attach(
418 Data => Encode::encode_utf8($content),
419 Type => 'text/html',
420 Charset => 'UTF-8',
421 Disposition => 'inline',
422 );
423
424 for my $part (@parts) {
425 $entity->add_part($part);
426 }
427
428 return $entity;
429}
430
431{
432 my $mason;
433 my $outbuf = '';
434 my $data_dir = '';
435
436 sub _mason {
437 unless ($mason) {
438 $RT::Logger->debug("Creating Mason object.");
439
440 # user may not have permissions on the data directory, so create a
441 # new one
442 $data_dir = tempdir(CLEANUP => 1);
443
444 $mason = HTML::Mason::Interp->new(
445 RT::Interface::Web::Handler->DefaultHandlerArgs,
446 out_method => \$outbuf,
447 autohandler_name => '', # disable forced login and more
448 data_dir => $data_dir,
449 );
450 $mason->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
451 $mason->set_escape( u => \&RT::Interface::Web::EscapeURI );
452 $mason->set_escape( j => \&RT::Interface::Web::EscapeJS );
453 }
454 return $mason;
455 }
456
457 sub RunComponent {
458 _mason->exec(@_);
459 my $ret = $outbuf;
460 $outbuf = '';
461 return $ret;
462 }
463}
464
465{
466 my %cache;
467
468 sub HourDowDomIn {
469 my $now = shift;
470 my $tz = shift;
471
472 my $key = "$now $tz";
473 return @{$cache{$key}} if exists $cache{$key};
474
475 my ($hour, $dow, $dom);
476
477 {
478 local $ENV{'TZ'} = $tz;
479 ## Using POSIX::tzset fixes a bug where the TZ environment variable
480 ## is cached.
481 tzset();
482 (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
483 }
484 tzset(); # return back previous value
485
486 $hour = "0$hour"
487 if length($hour) == 1;
488 $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];
489
490 return @{$cache{$key}} = ($hour, $dow, $dom);
491 }
492}
493
494sub GetResource {
495 my $uri = URI->new(shift);
496 my ($content, $filename, $mimetype, $encoding);
497
498 $RT::Logger->debug("Getting resource $uri");
499
500 # strip out the equivalent of WebURL, so we start at the correct /
501 my $path = $uri->path;
502 my $webpath = RT->Config->Get('WebPath');
503 $path =~ s/^\Q$webpath//;
504
505 # add a leading / if needed
506 $path = "/$path"
507 unless $path =~ m{^/};
508
509 $HTML::Mason::Commands::r->path_info($path);
510
511 # grab the query arguments
512 my %args;
513 for (split /&/, ($uri->query||'')) {
514 my ($k, $v) = /^(.*?)=(.*)$/
515 or die "Unable to parse query parameter '$_'";
516
517 for ($k, $v) { s/%(..)/chr hex $1/ge }
518
519 # no value yet, simple key=value
520 if (!exists $args{$k}) {
521 $args{$k} = $v;
522 }
523 # already have key=value, need to upgrade it to key=[value1, value2]
524 elsif (!ref($args{$k})) {
525 $args{$k} = [$args{$k}, $v];
526 }
527 # already key=[value1, value2], just add the new value
528 else {
529 push @{ $args{$k} }, $v;
530 }
531 }
532
533 $RT::Logger->debug("Running component '$path'");
534 $content = RunComponent($path, %args);
535
536 # guess at the filename from the component name
537 $filename = $1 if $path =~ m{^.*/(.*?)$};
538
539 # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
540 ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
541
542 my $content_type = $HTML::Mason::Commands::r->content_type;
543 if ($content_type) {
544 $mimetype = $content_type;
545
546 # strip down to just a MIME type
547 $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
548 }
549
550 #If all else fails then some conservative and general-purpose defaults are:
551 $mimetype ||= 'application/octet-stream';
552 $encoding ||= 'base64';
553
554 $RT::Logger->debug("Resource $uri: length=".length($content)." filename='$filename' mimetype='$mimetype', encoding='$encoding'");
555
556 return ($content, $filename, $mimetype, $encoding);
557}
558
559
560{
561 package RT::Dashboard::FakeRequest;
562 sub new { bless {}, shift }
563 sub header_out { shift }
564 sub headers_out { shift }
565 sub content_type {
566 my $self = shift;
567 $self->{content_type} = shift if @_;
568 return $self->{content_type};
569 }
570 sub path_info {
571 my $self = shift;
572 $self->{path_info} = shift if @_;
573 return $self->{path_info};
574 }
575}
576
577RT::Base->_ImportOverlays();
578
5791;
580