]>
Commit | Line | Data |
---|---|---|
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 | ||
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 | ||
63 | sub 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 | ||
128 | sub 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 | ||
193 | sub GetFrom { | |
194 | RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail') | |
195 | } | |
196 | ||
197 | sub 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}> | |
232 | SUMMARY | |
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, | |
255 | RT->Config->Get('WebURL') . '/Dashboards/Render.html', | |
256 | ); | |
257 | ||
258 | $self->EmailDashboard( | |
259 | %args, | |
260 | Dashboard => $dashboard, | |
261 | Content => $content, | |
262 | ); | |
263 | } | |
264 | ||
265 | sub 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 | ||
305 | sub 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 | ||
362 | sub 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 | ||
494 | sub 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 | ||
577 | RT::Base->_ImportOverlays(); | |
578 | ||
579 | 1; | |
580 |