#!/usr/bin/perl
# BEGIN BPS TAGGED BLOCK {{{
# 
# COPYRIGHT:
# 
# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
#                                          <jesse@bestpractical.com>
# 
# (Except where explicitly superseded by other copyright notices)
# 
# 
# LICENSE:
# 
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
# from www.gnu.org.
# 
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 or visit their web page on the internet at
# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
# 
# 
# CONTRIBUTION SUBMISSION POLICY:
# 
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of
# the GNU General Public License and is only of importance to you if
# you choose to contribute your changes and enhancements to the
# community by submitting them to Best Practical Solutions, LLC.)
# 
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with
# Request Tracker, to Best Practical Solutions, LLC, you confirm that
# you are the copyright holder for those contributions and you grant
# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
# royalty-free, perpetual, license to use, copy, create derivative
# works based on those contributions, and sublicense and distribute
# those contributions and any derivatives thereof.
# 
# END BPS TAGGED BLOCK }}}
use strict;
use warnings;

# fix lib paths, some may be relative
BEGIN {
    require File::Spec;
    my @libs = ("lib", "local/lib");
    my $bin_path;

    for my $lib (@libs) {
        unless ( File::Spec->file_name_is_absolute($lib) ) {
            unless ($bin_path) {
                if ( File::Spec->file_name_is_absolute(__FILE__) ) {
                    $bin_path = ( File::Spec->splitpath(__FILE__) )[1];
                }
                else {
                    require FindBin;
                    no warnings "once";
                    $bin_path = $FindBin::Bin;
                }
            }
            $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib );
        }
        unshift @INC, $lib;
    }

}

use RT;
use RT::Interface::Web;
use RT::Interface::Web::Handler;
use RT::Dashboard;
use RT::Interface::CLI qw{ CleanEnv loc };

use Getopt::Long;
use HTML::Mason;
use HTML::RewriteAttributes::Resources;
use HTML::RewriteAttributes::Links;
use MIME::Types;
use POSIX 'tzset';
use File::Temp 'tempdir';

# Clean out all the nasties from the environment
CleanEnv();

# Load the config file
RT::LoadConfig();

# Connect to the database and get RT::SystemUser and RT::Nobody loaded
RT::Init();

$HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new;

no warnings 'once';

# Read in the options
my %opts;
GetOptions( \%opts,
    "help", "dryrun", "verbose", "debug", "epoch=i", "all", "skip-acl"
);

if ($opts{'help'}) {
    require Pod::Usage;
    import Pod::Usage;
    pod2usage(-message => "RT Email Dashboards\n", -verbose => 1);
    exit 1;
}

# helper functions
sub verbose  { print loc(@_), "\n" if $opts{debug} || $opts{verbose}; 1 }
sub debug    { print loc(@_), "\n" if $opts{debug}; 1 }
sub error    { $RT::Logger->error(loc(@_)); verbose(@_); 1 }
sub warning  { $RT::Logger->warning(loc(@_)); verbose(@_); 1 }

my $now = $opts{epoch} || time;
verbose "Using time [_1]", scalar localtime($now);

my $from = get_from();
debug "Sending email from [_1]", $from;

# look through each user for her subscriptions
my $Users = RT::Users->new($RT::SystemUser);
$Users->LimitToPrivileged;

while (defined(my $user = $Users->Next)) {
    if ($user->PrincipalObj->Disabled) {
        debug "Skipping over "
            . $user->Name
            . " due to having a disabled account.";
        next;
    }

    my ($hour, $dow, $dom) = hour_dow_dom_in($user->Timezone || RT->Config->Get('Timezone'));
    $hour .= ':00';
    debug "Checking [_1]'s subscriptions: hour [_2], dow [_3], dom [_4]",
          $user->Name, $hour, $dow, $dom;

    my $currentuser = RT::CurrentUser->new;
    $currentuser->LoadByName($user->Name);

    # look through this user's subscriptions, are any supposed to be generated
    # right now?
    for my $subscription ($user->Attributes->Named('Subscription')) {
        my $counter = $subscription->SubValue('Counter') || 0;

        if (!$opts{all}) {
            debug "Checking against subscription with frequency [_1], hour [_2], dow [_3], dom [_4]",
                $subscription->SubValue('Frequency'), $subscription->SubValue('Hour'),
                $subscription->SubValue('Dow'), $subscription->SubValue('Dom');

            next if $subscription->SubValue('Frequency') eq 'never';

            # correct hour?
            next if $subscription->SubValue('Hour') ne $hour;

            # if weekly, correct day of week?
            if ( $subscription->SubValue('Frequency') eq 'weekly' ) {
                next if $subscription->SubValue('Dow') ne $dow;
                my $fow       = $subscription->SubValue('Fow') || 1;
                if ( $counter % $fow ) {
                    $subscription->SetSubValues( Counter => $counter + 1 )
                      unless $opts{'dryrun'};
                    next;
                }
            }

            # if monthly, correct day of month?
            elsif ($subscription->SubValue('Frequency') eq 'monthly') {
                next if $subscription->SubValue('Dom') != $dom;
            }

            elsif ($subscription->SubValue('Frequency') eq 'm-f') {
                next if $dow eq 'Sunday' || $dow eq 'Saturday';
            }
        }

        my $email = $subscription->SubValue('Recipient')
                 || $user->EmailAddress;

        eval { send_dashboard($currentuser, $email, $subscription) };
        if ( $@ ) {
            error 'Caught exception: ' . $@;
        }
        else {
            $subscription->SetSubValues(
                Counter => $counter + 1 )
              unless $opts{'dryrun'};
        }
    }
}

sub send_dashboard {
    my ($currentuser, $email, $subscription) = @_;

    my $rows = $subscription->SubValue('Rows');

    my $dashboard = RT::Dashboard->new($currentuser);

    my ($ok, $msg) = $dashboard->LoadById($subscription->SubValue('DashboardId'));

    # failed to load dashboard. perhaps it was deleted or it changed privacy
    if (!$ok) {
        warning "Unable to load dashboard [_1] of subscription [_2] for user [_3]: [_4]",
            $subscription->SubValue('DashboardId'),
            $subscription->Id,
            $currentuser->Name,
            $msg;

        my $ok = RT::Interface::Email::SendEmailUsingTemplate(
            From      => $from,
            To        => $email,
            Template  => 'Error: Missing dashboard',
            Arguments => {
                SubscriptionObj => $subscription,
            },
        );

        # only delete the subscription if the email looks like it went through
        if ($ok) {
            my ($deleted, $msg) = $subscription->Delete();
            if ($deleted) {
                verbose("Deleted an obsolete subscription: [_1]", $msg);
            }
            else {
                warning("Unable to delete an obsolete subscription: [_1]", $msg);
            }
        }
        else {
            warning("Unable to notify [_1] of an obsolete subscription", $currentuser->Name);
        }

        return;
    }

    verbose 'Creating dashboard "[_1]" for user "[_2]":',
            $dashboard->Name,
            $currentuser->Name;

    if ($opts{'dryrun'}) {
        print << "SUMMARY";
    Dashboard: @{[ $dashboard->Name ]}
    User:   @{[ $currentuser->Name ]} <$email>
SUMMARY
        return;
    }

    $HTML::Mason::Commands::session{CurrentUser} = $currentuser;
    my $contents = run_component(
        '/Dashboards/Render.html',
        id      => $dashboard->Id,
        Preview => 0,
    );

    for (@{ RT->Config->Get('EmailDashboardRemove') || [] }) {
        $contents =~ s/$_//g;
    }

    debug "Got [_1] characters of output.", length $contents;

    $contents = HTML::RewriteAttributes::Links->rewrite(
        $contents,
        RT->Config->Get('WebURL') . '/Dashboards/Render.html',
    );

    email_dashboard($currentuser, $email, $dashboard, $subscription, $contents);
}

sub email_dashboard {
    my ($currentuser, $email, $dashboard, $subscription, $content) = @_;

    verbose 'Sending dashboard "[_1]" to user [_2] <[_3]>',
            $dashboard->Name,
            $currentuser->Name,
            $email;

    my $subject = sprintf '[%s] ' .  RT->Config->Get('DashboardSubject'),
        RT->Config->Get('rtname'),
        ucfirst($subscription->SubValue('Frequency')),
        $dashboard->Name;

    my $entity = build_email($content, $from, $email, $subject);

    my $ok = RT::Interface::Email::SendEmail(
        Entity => $entity,
    );

    debug "Done sending dashboard to [_1] <[_2]>",
          $currentuser->Name, $email
              and return if $ok;

    error 'Failed to email dashboard to user [_1] <[_2]>',
          $currentuser->Name, $email;
}

sub build_email {
    my ($content, $from, $to, $subject) = @_;
    my @parts;
    my %cid_of;

    $content = HTML::RewriteAttributes::Resources->rewrite($content, sub {
            my $uri = shift;

            # already attached this object
            return "cid:$cid_of{$uri}" if $cid_of{$uri};

            $cid_of{$uri} = time() . $$ . int(rand(1e6));
            my ($data, $filename, $mimetype, $encoding) = get_resource($uri);

            # downgrade non-text strings, because all strings are utf8 by
            # default, which is wrong for non-text strings.
            if ( $mimetype !~ m{text/} ) {
                utf8::downgrade( $data, 1 ) or warning "downgrade $data failed";
            }

            push @parts, MIME::Entity->build(
                Top          => 0,
                Data         => $data,
                Type         => $mimetype,
                Encoding     => $encoding,
                Disposition  => 'inline',
                Name         => $filename,
                'Content-Id' => $cid_of{$uri},
            );

            return "cid:$cid_of{$uri}";
        },
        inline_css => sub {
            my $uri = shift;
            my ($content) = get_resource($uri);
            return $content;
        },
        inline_imports => 1,
    );

    my $entity = MIME::Entity->build(
        From    => $from,
        To      => $to,
        Subject => $subject,
        Type    => "multipart/mixed",
    );

    $entity->attach(
        Data        => Encode::encode_utf8($content),
        Type        => 'text/html',
        Charset     => 'UTF-8',
        Disposition => 'inline',
    );

    for my $part (@parts) {
        $entity->add_part($part);
    }

    return $entity;
}

sub get_from {
    RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail')
}

{
    my $mason;
    my $outbuf = '';
    my $data_dir = '';

    sub mason {
        unless ($mason) {
            debug "Creating Mason object.";

            # user may not have permissions on the data directory, so create a
            # new one
            $data_dir = tempdir(CLEANUP => 1);

            $mason = HTML::Mason::Interp->new(
                RT::Interface::Web::Handler->DefaultHandlerArgs,
                out_method => \$outbuf,
                autohandler_name => '', # disable forced login and more
                data_dir => $data_dir,
            );
        }
        return $mason;
    }

    sub run_component {
        mason->exec(@_);
        my $ret = $outbuf;
        $outbuf = '';
        return $ret;
    }
}

{
    my %cache;

    sub hour_dow_dom_in {
        my $tz = shift;
        return @{$cache{$tz}} if exists $cache{$tz};

        my ($hour, $dow, $dom);

        {
            local $ENV{'TZ'} = $tz;
            ## Using POSIX::tzset fixes a bug where the TZ environment variable
            ## is cached.
            tzset();
            (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now);
        }
        tzset(); # return back previous value

        $hour = "0$hour"
            if length($hour) == 1;
        $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow];

        return @{$cache{$tz}} = ($hour, $dow, $dom);
    }
}

sub get_resource {
    my $uri = URI->new(shift);
    my ($content, $filename, $mimetype, $encoding);

    verbose "Getting resource [_1]", $uri;

    # strip out the equivalent of WebURL, so we start at the correct /
    my $path = $uri->path;
    my $webpath = RT->Config->Get('WebPath');
    $path =~ s/^\Q$webpath//;

    # add a leading / if needed
    $path = "/$path"
        unless $path =~ m{^/};

    # grab the query arguments
    my %args;
    for (split /&/, ($uri->query||'')) {
        my ($k, $v) = /^(.*?)=(.*)$/
            or die "Unable to parse query parameter '$_'";

        for ($k, $v) { s/%(..)/chr hex $1/ge }

        # no value yet, simple key=value
        if (!exists $args{$k}) {
            $args{$k} = $v;
        }
        # already have key=value, need to upgrade it to key=[value1, value2]
        elsif (!ref($args{$k})) {
            $args{$k} = [$args{$k}, $v];
        }
        # already key=[value1, value2], just add the new value
        else {
            push @{ $args{$k} }, $v;
        }
    }

    debug "Running component '[_1]'", $path;
    $content = run_component($path, %args);

    # guess at the filename from the component name
    $filename = $1 if $path =~ m{^.*/(.*?)$};

    # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP
    ($mimetype, $encoding) = MIME::Types::by_suffix($filename);

    my $content_type = $HTML::Mason::Commands::r->content_type;
    if ($content_type) {
        $mimetype = $content_type;

        # strip down to just a MIME type
        $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/;
    }

    #If all else fails then some conservative and general-purpose defaults are:
    $mimetype ||= 'application/octet-stream';
    $encoding ||= 'base64';

    debug "Resource [_1]: length=[_2] filename='[_3]' mimetype='[_4]', encoding='[_5]'",
        $uri,
        length($content),
        $filename,
        $mimetype,
        $encoding;

    return ($content, $filename, $mimetype, $encoding);
}

package RT::Dashboard::FakeRequest;
sub new { bless {}, shift }
sub header_out { shift }
sub headers_out { shift }
sub content_type {
    my $self = shift;
    $self->{content_type} = shift if @_;
    return $self->{content_type};
}

=head1 NAME

rt-email-dashboards - Send email dashboards

=head1 SYNOPSIS

    /opt/rt3/local/sbin/rt-email-dashboards [options]

=head1 DESCRIPTION

This tool will send users email based on how they have subscribed to
dashboards. A dashboard is a set of saved searches, the subscription controls
how often that dashboard is sent and how it's displayed.

Each subscription has an hour, and possibly day of week or day of month. These
are taken to be in the user's timezone if available, UTC otherwise.

=head1 SETUP

You'll need to have cron run this script every hour. Here's an example crontab
entry to do this.

    0 * * * * /usr/bin/perl /opt/rt3/local/sbin/rt-email-dashboards

This will run the script every hour on the hour. This may need some further
tweaking to be run as the correct user.

=head1 OPTIONS

This tool supports a few options. Most are for debugging.

=over 8

=item --help

Display this documentation

=item --dryrun

Figure out which dashboards would be sent, but don't actually generate them

=item --epoch SECONDS

Instead of using the current time to figure out which dashboards should be
sent, use SECONDS (usually since midnight Jan 1st, 1970, so C<1192216018> would
be Oct 12 19:06:58 GMT 2007).

=item --verbose

Print out some tracing information (such as which dashboards are being
generated and sent out)

=item --debug

Print out more tracing information (such as each user and subscription that is
being considered)

=item --all

Ignore subscription frequency when considering each dashboard (should only be
used with --dryrun)

=back

=cut