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
  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') || 1;
 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         return 1 if $counter % $sub_fow == 0;
 169
 170         $subscription->SetSubValues(Counter => $counter + 1)
 171             unless $args{DryRun};
 172         return 0;
 173     }
 174
 175     # if monthly, correct day of month?
 176     if ($sub_frequency eq 'monthly') {
 177         return $sub_dom == $dom;
 178     }
 179
 180     # monday through friday
 181     if ($sub_frequency eq 'm-f') {
 182         return 0 if $dow eq 'Sunday' || $dow eq 'Saturday';
 183         return 1;
 184     }
 185
 186     $RT::Logger->debug("Invalid subscription frequency $sub_frequency for " . $args{User}->Name);
 187
 188     # unknown frequency type, bail out
 189     return 0;
 190 }
 191
 192 sub GetFrom {
 193     RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
 194 }
 195
 196 sub SendDashboard {
 197     my $self = shift;
 198     my %args = (
 199         CurrentUser  => undef,
 200         Email        => undef,
 201         Subscription => undef,
 202         DryRun       => 0,
 203         @_,
 204     );
 205
 206     my $currentuser  = $args{CurrentUser};
 207     my $subscription = $args{Subscription};
 208
 209     my $rows = $subscription->SubValue('Rows');
 210
 211     my $DashboardId = $subscription->SubValue('DashboardId');
 212
 213     my $dashboard = RT::Dashboard->new($currentuser);
 214     my ($ok, $msg) = $dashboard->LoadById($DashboardId);
 215
 216     # failed to load dashboard. perhaps it was deleted or it changed privacy
 217     if (!$ok) {
 218         $RT::Logger->warning("Unable to load dashboard $DashboardId of subscription ".$subscription->Id." for user ".$currentuser->Name.": $msg");
 219         return $self->ObsoleteSubscription(
 220             %args,
 221             Subscription => $subscription,
 222         );
 223     }
 224
 225     $RT::Logger->debug('Generating dashboard "'.$dashboard->Name.'" for user "'.$currentuser->Name.'":');
 226
 227     if ($args{DryRun}) {
 228         print << "SUMMARY";
 229     Dashboard: @{[ $dashboard->Name ]}
 230     User:   @{[ $currentuser->Name ]} <$args{Email}>
 231 SUMMARY
 232         return;
 233     }
 234
 235     local $HTML::Mason::Commands::session{CurrentUser} = $currentuser;
 236     local $HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new;
 237
 238     my $content = RunComponent(
 239         '/Dashboards/Render.html',
 240         id      => $dashboard->Id,
 241         Preview => 0,
 242     );
 243
 244     if ( RT->Config->Get('EmailDashboardRemove') ) {
 245         for ( RT->Config->Get('EmailDashboardRemove') ) {
 246             $content =~ s/$_//g;
 247         }
 248     }
 249
 250     $content = ScrubContent($content);
 251
 252     $RT::Logger->debug("Got ".length($content)." characters of output.");
 253
 254     $content = HTML::RewriteAttributes::Links->rewrite(
 255         $content,
 256         RT->Config->Get('WebURL') . 'Dashboards/Render.html',
 257     );
 258
 259     $self->EmailDashboard(
 260         %args,
 261         Dashboard => $dashboard,
 262         Content   => $content,
 263     );
 264 }
 265
 266 sub ObsoleteSubscription {
 267     my $self = shift;
 268     my %args = (
 269         From         => undef,
 270         To           => undef,
 271         Subscription => undef,
 272         CurrentUser  => undef,
 273         @_,
 274     );
 275
 276     my $subscription = $args{Subscription};
 277
 278     my $ok = RT::Interface::Email::SendEmailUsingTemplate(
 279         From      => $args{From},
 280         To        => $args{Email},
 281         Template  => 'Error: Missing dashboard',
 282         Arguments => {
 283             SubscriptionObj => $subscription,
 284         },
 285         ExtraHeaders => {
 286             'X-RT-Dashboard-Subscription-Id' => $subscription->Id,
 287             'X-RT-Dashboard-Id' => $subscription->SubValue('DashboardId'),
 288         },
 289     );
 290
 291     # only delete the subscription if the email looks like it went through
 292     if ($ok) {
 293         my ($deleted, $msg) = $subscription->Delete();
 294         if ($deleted) {
 295             $RT::Logger->debug("Deleted an obsolete subscription: $msg");
 296         }
 297         else {
 298             $RT::Logger->warning("Unable to delete an obsolete subscription: $msg");
 299         }
 300     }
 301     else {
 302         $RT::Logger->warning("Unable to notify ".$args{CurrentUser}->Name." of an obsolete subscription");
 303     }
 304 }
 305
 306 sub EmailDashboard {
 307     my $self = shift;
 308     my %args = (
 309         CurrentUser  => undef,
 310         Email        => undef,
 311         Dashboard    => undef,
 312         Subscription => undef,
 313         Content      => undef,
 314         @_,
 315     );
 316
 317     my $subscription = $args{Subscription};
 318     my $dashboard    = $args{Dashboard};
 319     my $currentuser  = $args{CurrentUser};
 320     my $email        = $args{Email};
 321
 322     my $frequency    = $subscription->SubValue('Frequency');
 323
 324     my %frequency_lookup = (
 325         'm-f'     => 'Weekday', # loc
 326         'daily'   => 'Daily',   # loc
 327         'weekly'  => 'Weekly',  # loc
 328         'monthly' => 'Monthly', # loc
 329         'never'   => 'Never',   # loc
 330     );
 331
 332     my $frequency_display = $frequency_lookup{$frequency}
 333                          || $frequency;
 334
 335     my $subject = sprintf '[%s] ' .  RT->Config->Get('DashboardSubject'),
 336         RT->Config->Get('rtname'),
 337         $currentuser->loc($frequency_display),
 338         $dashboard->Name;
 339
 340     my $entity = $self->BuildEmail(
 341         %args,
 342         To      => $email,
 343         Subject => $subject,
 344     );
 345
 346     $entity->head->replace('X-RT-Dashboard-Id', $dashboard->Id);
 347     $entity->head->replace('X-RT-Dashboard-Subscription-Id', $subscription->Id);
 348
 349     $RT::Logger->debug('Mailing dashboard "'.$dashboard->Name.'" to user '.$currentuser->Name." <$email>");
 350
 351     my $ok = RT::Interface::Email::SendEmail(
 352         Entity => $entity,
 353     );
 354
 355     if (!$ok) {
 356         $RT::Logger->error("Failed to email dashboard to user ".$currentuser->Name." <$email>");
 357         return;
 358     }
 359
 360     $RT::Logger->debug("Done sending dashboard to ".$currentuser->Name." <$email>");
 361 }
 362
 363 sub BuildEmail {
 364     my $self = shift;
 365     my %args = (
 366         Content => undef,
 367         From    => undef,
 368         To      => undef,
 369         Subject => undef,
 370         @_,
 371     );
 372
 373     my @parts;
 374     my %cid_of;
 375
 376     my $content = HTML::RewriteAttributes::Resources->rewrite($args{Content}, sub {
 377             my $uri = shift;
 378
 379             # already attached this object
 380             return "cid:$cid_of{$uri}" if $cid_of{$uri};
 381
 382             $cid_of{$uri} = time() . $$ . int(rand(1e6));
 383             my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
 384
 385             # Encode textual data in UTF-8, and downgrade (treat
 386             # codepoints as codepoints, and ensure the UTF-8 flag is
 387             # off) everything else.
 388             my @extra;
 389             if ( $mimetype =~ m{text/} ) {
 390                 $data = Encode::encode( "UTF-8", $data );
 391                 @extra = ( Charset => "UTF-8" );
 392             } else {
 393                 utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
 394             }
 395
 396             push @parts, MIME::Entity->build(
 397                 Top          => 0,
 398                 Data         => $data,
 399                 Type         => $mimetype,
 400                 Encoding     => $encoding,
 401                 Disposition  => 'inline',
 402                 Name         => RT::Interface::Email::EncodeToMIME( String => $filename ),
 403                 'Content-Id' => $cid_of{$uri},
 404                 @extra,
 405             );
 406
 407             return "cid:$cid_of{$uri}";
 408         },
 409         inline_css => sub {
 410             my $uri = shift;
 411             my ($content) = GetResource($uri);
 412             return $content;
 413         },
 414         inline_imports => 1,
 415     );
 416
 417     my $entity = MIME::Entity->build(
 418         From    => Encode::encode("UTF-8", $args{From}),
 419         To      => Encode::encode("UTF-8", $args{To}),
 420         Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
 421         Type    => "multipart/mixed",
 422     );
 423
 424     $entity->attach(
 425         Type        => 'text/html',
 426         Charset     => 'UTF-8',
 427         Data        => Encode::encode("UTF-8", $content),
 428         Disposition => 'inline',
 429         Encoding    => "base64",
 430     );
 431
 432     for my $part (@parts) {
 433         $entity->add_part($part);
 434     }
 435
 436     $entity->make_singlepart;
 437
 438     return $entity;
 439 }
 440
 441 {
 442     my $mason;
 443     my $outbuf = '';
 444     my $data_dir = '';
 445
 446     sub _mason {
 447         unless ($mason) {
 448             $RT::Logger->debug("Creating Mason object.");
 449
 450             # user may not have permissions on the data directory, so create a
 451             # new one
 452             $data_dir = tempdir(CLEANUP => 1);
 453
 454             $mason = HTML::Mason::Interp->new(
 455                 RT::Interface::Web::Handler->DefaultHandlerArgs,
 456                 out_method => \$outbuf,
 457                 autohandler_name => '', # disable forced login and more
 458                 data_dir => $data_dir,
 459             );
 460             $mason->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
 461             $mason->set_escape( u => \&RT::Interface::Web::EscapeURI  );
 462             $mason->set_escape( j => \&RT::Interface::Web::EscapeJS   );
 463         }
 464         return $mason;
 465     }
 466
 467     sub RunComponent {
 468         _mason->exec(@_);
 469         my $ret = $outbuf;
 470         $outbuf = '';
 471         return $ret;
 472     }
 473 }
 474
 475 {
 476     my $scrubber;
 477
 478     sub _scrubber {
 479         unless ($scrubber) {
 480             $scrubber = HTML::Scrubber->new;
 481             # Allow everything by default, except JS attributes ...
 482             $scrubber->default(
 483                 1 => {
 484                     '*' => 1,
 485                     map { ("on$_" => 0) }
 486                          qw(blur change click dblclick error focus keydown keypress keyup load
 487                             mousedown mousemove mouseout mouseover mouseup reset select submit unload)
 488                 }
 489             );
 490             # ... and <script>s
 491             $scrubber->deny('script');
 492         }
 493         return $scrubber;
 494     }
 495
 496     sub ScrubContent {
 497         my $content = shift;
 498         return _scrubber->scrub($content);
 499     }
 500 }
 501
 502 {
 503     my %cache;
 504
 505     sub HourDowDomIn {
 506         my $now = shift;
 507         my $tz  = shift;
 508
 509         my $key = "$now $tz";
 510         return @{$cache{$key}} if exists $cache{$key};
 511
 512         my ($hour, $dow, $dom);
 513
 514         {
 515             local $ENV{'TZ'} = $tz;
 516             ## Using POSIX::tzset fixes a bug where the TZ environment variable
 517             ## is cached.
 518             tzset();
 519             (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
 520         }
 521         tzset(); # return back previous value
 522
 523         $hour = "0$hour"
 524             if length($hour) == 1;
 525         $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];
 526
 527         return @{$cache{$key}} = ($hour, $dow, $dom);
 528     }
 529 }
 530
 531 sub GetResource {
 532     my $uri = URI->new(shift);
 533     my ($content, $filename, $mimetype, $encoding);
 534
 535     $RT::Logger->debug("Getting resource $uri");
 536
 537     # strip out the equivalent of WebURL, so we start at the correct /
 538     my $path = $uri->path;
 539     my $webpath = RT->Config->Get('WebPath');
 540     $path =~ s/^\Q$webpath//;
 541
 542     # add a leading / if needed
 543     $path = "/$path"
 544         unless $path =~ m{^/};
 545
 546     $HTML::Mason::Commands::r->path_info($path);
 547
 548     # grab the query arguments
 549     my %args;
 550     for (split /&/, ($uri->query||'')) {
 551         my ($k, $v) = /^(.*?)=(.*)$/
 552             or die "Unable to parse query parameter '$_'";
 553
 554         for ($k, $v) { s/%(..)/chr hex $1/ge }
 555
 556         # Decode from bytes to characters
 557         $_ = Encode::decode( "UTF-8", $_ ) for $k, $v;
 558
 559         # no value yet, simple key=value
 560         if (!exists $args{$k}) {
 561             $args{$k} = $v;
 562         }
 563         # already have key=value, need to upgrade it to key=[value1, value2]
 564         elsif (!ref($args{$k})) {
 565             $args{$k} = [$args{$k}, $v];
 566         }
 567         # already key=[value1, value2], just add the new value
 568         else {
 569             push @{ $args{$k} }, $v;
 570         }
 571     }
 572
 573     $RT::Logger->debug("Running component '$path'");
 574     $content = RunComponent($path, %args);
 575
 576     # guess at the filename from the component name
 577     $filename = $1 if $path =~ m{^.*/(.*?)$};
 578
 579     # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
 580     ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
 581
 582     my $content_type = $HTML::Mason::Commands::r->content_type;
 583     if ($content_type) {
 584         $mimetype = $content_type;
 585
 586         # strip down to just a MIME type
 587         $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
 588     }
 589
 590     #If all else fails then some conservative and general-purpose defaults are:
 591     $mimetype ||= 'application/octet-stream';
 592     $encoding ||= 'base64';
 593
 594     $RT::Logger->debug("Resource $uri: length=".length($content)." filename='$filename' mimetype='$mimetype', encoding='$encoding'");
 595
 596     return ($content, $filename, $mimetype, $encoding);
 597 }
 598
 599
 600 {
 601     package RT::Dashboard::FakeRequest;
 602     sub new { bless {}, shift }
 603     sub header_out { return undef }
 604     sub headers_out { wantarray ? () : {} }
 605     sub err_headers_out { wantarray ? () : {} }
 606     sub content_type {
 607         my $self = shift;
 608         $self->{content_type} = shift if @_;
 609         return $self->{content_type};
 610     }
 611     sub path_info {
 612         my $self = shift;
 613         $self->{path_info} = shift if @_;
 614         return $self->{path_info};
 615     }
 616 }
 617
 618 RT::Base->_ImportOverlays();
 619
 620 1;
 621