rt/lib/RT/Dashboard/Mailer.pm

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