Initial commit 4.0.5-3
[usit-rt.git] / lib / RT / Dashboard / Mailer.pm
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