path: root/lreminder/reminder.pl

#!/usr/bin/perl

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program 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 St, Fifth Floor, Boston, MA  02110-1301  USA
#
# Author: Steven Schubiger <stsc@refcnt.org>
# Last modified: Thu Jan 31 11:12:22 CET 2013

use strict;
use warnings;
use lib qw(lib);
use constant true  => 1;
use constant false => 0;

use DBI ();
use File::Basename ();
use File::Spec ();
use FindBin qw($Bin);
use Getopt::Long qw(:config no_auto_abbrev no_ignore_case);
use Hook::Output::File ();
use LUGS::Events::Parser ();
use Mail::Sendmail qw(sendmail);
use Text::Wrap::Smart::XS qw(fuzzy_wrap);
use WWW::Mechanize ();

my $VERSION = '0.41';

#-----------------------
# Start of configuration
#-----------------------

my $Config = {
    events_url => 'http://www.lugs.ch/lugs/termine/termine.txt',
    form_url   => 'http://lists.lugs.ch/reminder.cgi',
    mail_from  => 'reminder@lugs.ch',
    dbase_name => '<hidden>',
    dbase_user => '<hidden>',
    dbase_pass => '<hidden>',
};

#---------------------
# End of configuration
#---------------------

my $dbh  = DBI->connect("dbi:mysql(RaiseError=>1):$Config->{dbase_name}", $Config->{dbase_user}, $Config->{dbase_pass});
my $file = File::Basename::basename($Config->{events_url});

my ($test, $run) = (false, false);

{
    getopts(\$test, \$run);
    my $hook = Hook::Output::File->redirect(
        stdout => File::Spec->catfile($Bin, 'stdout.out'),
        stderr => File::Spec->catfile($Bin, 'stderr.out'),
    );
    fetch_and_write_events();
    process_events();
}

sub getopts
{
    my ($test, $run) = @_;

    GetOptions(test => $test, run => $run) or exit;

    if (not $$test || $$run) {
        die "$0: neither --test nor --run specified, exiting\n";
    }
    elsif ($$test && $$run) {
        die "$0: both --test and --run specified, exiting\n";
    }
    return; # --test or --run specified
}

sub fetch_and_write_events
{
    my $mech = WWW::Mechanize->new;
    my $http = $mech->get($Config->{events_url});

    open(my $fh, '>', $file) or die "Cannot open $file: $!\n";
    print {$fh} $http->content;
    close($fh);
}

sub init
{
    my ($parser, $month_days, $current) = @_;

    $$parser = LUGS::Events::Parser->new($file, {
        filter_html  => true,
        tag_handlers => {
            'a href' => [ {
                rewrite => '$TEXT - <$HREF>',
                fields  => [ qw(responsible) ],
            }, {
                rewrite => '$TEXT - $HREF',
                fields  => [ qw(location more) ],
            } ],
            'br' => [ {
                rewrite => '',
                fields  => [ qw(more) ],
            } ],
        },
        strip_text => [ 'mailto:' ],
    });
    unlink $file;

    %$month_days = (
        1 => 31,   7 => 31,
        2 => 28,   8 => 31,
        3 => 31,   9 => 30,
        4 => 30,  10 => 31,
        5 => 31,  11 => 30,
        6 => 30,  12 => 31,
    );

    %$current = do {
        my @time = (localtime)[3..5];
        $time[1]++;
        $time[2] += 1900;
        map { $_ => shift @time } qw(day month year);
    };
}

sub process_events
{
    my   ($parser,  %month_days,  %current);
    init(\$parser, \%month_days, \%current);

    while (my $event = $parser->next_event) {
        my %event = (
            year  => $event->get_event_year,
            month => $event->get_event_month,
            day   => $event->get_event_day,
            color => $event->get_event_color,
        );

        my %sth;

        $sth{subscribers} = $dbh->prepare('SELECT mail, mode, notify FROM subscribers');
        $sth{subscribers}->execute;

        while (my $subscriber = $sth{subscribers}->fetchrow_hashref) {
            next unless $subscriber->{mode} == 2;

            $sth{subscriptions} = $dbh->prepare('SELECT * FROM subscriptions WHERE mail = ?');
            $sth{subscriptions}->execute($subscriber->{mail});

            my $subscriptions = $sth{subscriptions}->fetchrow_hashref;
            next unless $subscriptions->{$event{color}};

            my %notify = %current;

            $subscriber->{notify} ||= 0;

            my $day = $current{day} + $subscriber->{notify};
            my $days_in_month = $month_days{$current{month}};

            if ($day > $days_in_month) {
                $notify{day} = $day - $days_in_month;
                $notify{month}++;
            }
            else {
                $notify{day} += $subscriber->{notify};
            }

            if ($event{year}  == $notify{year}
             && $event{month} == $notify{month}
             && $event{day}   == $notify{day}
            ) {
                send_mail($event, $subscriber->{mail});
            }
        }
    }
}

sub send_mail
{
    my ($event, $mail_subscriber) = @_;

    my $year        = $event->get_event_year;
    my $month       = $event->get_event_month;
    my $simple_day  = $event->get_event_simple_day;
    my $wday        = $event->get_event_weekday;
    my $time        = $event->get_event_time;
    my $title       = $event->get_event_title;
    my $color       = $event->get_event_color;
    my $location    = $event->get_event_location;
    my $responsible = $event->get_event_responsible;
    my $more        = $event->get_event_more || '';

    wrap_text(\$more);
    chomp $more;
    wrap_text(\$location);

    my $i;
    my %month_names = map { sprintf('%02d', ++$i) => $_ }
      qw(Januar Februar Maerz April Mai Juni Juli August
         September Oktober November Dezember);

    my $month_name = $month_names{$month};

my $message = (<<MSG);
Wann:\t$wday, $simple_day. $month_name $year, $time Uhr
Was :\t$title
Wo  :\t$location
Wer :\t$responsible
Info:\t$more

Web Interface:
$Config->{form_url}

${\info_string()}
MSG

    if ($run) {
        sendmail(
            From    => $Config->{mail_from},
            To      => $mail_subscriber,
            Subject => "LUGS Reminder - $title",
            Message => $message,
        ) or die $Mail::Sendmail::error;
    }
    elsif ($test) {
        printf "[%s] <$mail_subscriber> ($color)\n", scalar localtime;
    }
}

sub wrap_text
{
    my ($text) = @_;

    return unless length $$text;

    my @chunks = fuzzy_wrap($$text, 70);

    my $wrapped;
    foreach my $chunk (@chunks) {
        $wrapped .= ' ' x (defined $wrapped ? 8 : 0);
        $wrapped .= "$chunk\n";
    }
    chomp $wrapped;

    $$text = $wrapped;
}

sub info_string
{
    my $script = File::Basename::basename($0);
    my $modified = localtime((stat($0))[9]);

    $modified =~ s/(?<=\b) (?:\d{2}\:?){3} (?=\b)//x;
    $modified =~ s/\s+/ /g;

    my $info = <<EOT;
-- 
running $script v$VERSION - last modified: $modified
EOT
    return do { local $_ = $info; chomp while /\n$/; $_ };
}