rt/lib/RT/Dashboard/Mailer.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2013 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 use HTML::Scrubber;
  63
  64 sub 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
 129 sub 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
 194 sub GetFrom {
 195     RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
 196 }
 197
 198 sub 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}>
 233 SUMMARY
 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
 252     $content = ScrubContent($content);
 253
 254     $RT::Logger->debug("Got ".length($content)." characters of output.");
 255
 256     $content = HTML::RewriteAttributes::Links->rewrite(
 257         $content,
 258         RT->Config->Get('WebURL') . 'Dashboards/Render.html',
 259     );
 260
 261     $self->EmailDashboard(
 262         %args,
 263         Dashboard => $dashboard,
 264         Content   => $content,
 265     );
 266 }
 267
 268 sub 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
 308 sub 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
 365 sub 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',
 399                 Name         => RT::Interface::Email::EncodeToMIME( String => $filename ),
 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(
 414         From    => Encode::encode_utf8($args{From}),
 415         To      => Encode::encode_utf8($args{To}),
 416         Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
 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 {
 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 {
 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
 524 sub 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 }
 593     sub header_out { return undef }
 594     sub headers_out { wantarray ? () : {} }
 595     sub err_headers_out { wantarray ? () : {} }
 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
 608 RT::Base->_ImportOverlays();
 609
 610 1;
 611