lreminder/reminder.pl

   1 #!/usr/bin/perl
   2
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program; if not, write to the Free Software
  15 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  16 #
  17 # Author: Steven Schubiger <stsc@refcnt.org>
  18 # Last modified: Mon Jan 13 22:07:51 CET 2014
  19
  20 use strict;
  21 use warnings;
  22 use lib qw(lib);
  23 use constant true  => 1;
  24 use constant false => 0;
  25
  26 use DateTime ();
  27 use DBI ();
  28 use Encode qw(encode);
  29 use File::Basename ();
  30 use File::Spec ();
  31 use FindBin qw($Bin);
  32 use Getopt::Long qw(:config no_auto_abbrev no_ignore_case);
  33 use Hook::Output::File ();
  34 use LUGS::Events::Parser ();
  35 use Mail::Sendmail qw(sendmail);
  36 use Text::Wrap::Smart::XS qw(fuzzy_wrap);
  37 use WWW::Mechanize ();
  38
  39 my $VERSION = '0.43';
  40
  41 #-----------------------
  42 # Start of configuration
  43 #-----------------------
  44
  45 my $Config = {
  46     events_url => 'http://www.lugs.ch/lugs/termine/termine.txt',
  47     form_url   => 'http://lists.lugs.ch/reminder.cgi',
  48     mail_from  => 'reminder@lugs.ch',
  49     dbase_name => '<hidden>',
  50     dbase_user => '<hidden>',
  51     dbase_pass => '<hidden>',
  52 };
  53
  54 #---------------------
  55 # End of configuration
  56 #---------------------
  57
  58 my $dbh  = DBI->connect("dbi:mysql(RaiseError=>1):$Config->{dbase_name}", $Config->{dbase_user}, $Config->{dbase_pass});
  59 my $file = File::Basename::basename($Config->{events_url});
  60
  61 my ($test, $run) = (false, false);
  62
  63 {
  64     getopts(\$test, \$run);
  65     my $hook = Hook::Output::File->redirect(
  66         stdout => File::Spec->catfile($Bin, 'stdout.out'),
  67         stderr => File::Spec->catfile($Bin, 'stderr.out'),
  68     );
  69     fetch_and_write_events();
  70     process_events();
  71 }
  72
  73 sub getopts
  74 {
  75     my ($test, $run) = @_;
  76
  77     GetOptions(test => $test, run => $run) or exit;
  78
  79     if (not $$test || $$run) {
  80         die "$0: neither --test nor --run specified, exiting\n";
  81     }
  82     elsif ($$test && $$run) {
  83         die "$0: both --test and --run specified, exiting\n";
  84     }
  85     return; # --test or --run specified
  86 }
  87
  88 sub fetch_and_write_events
  89 {
  90     my $mech = WWW::Mechanize->new;
  91     my $http = $mech->get($Config->{events_url});
  92
  93     open(my $fh, '>', $file) or die "Cannot open $file: $!\n";
  94     print {$fh} $http->content;
  95     close($fh);
  96 }
  97
  98 sub init
  99 {
 100     my ($parser) = @_;
 101
 102     $$parser = LUGS::Events::Parser->new($file, {
 103         filter_html  => true,
 104         tag_handlers => {
 105             'a href' => [ {
 106                 rewrite => '$TEXT - <$HREF>',
 107                 fields  => [ qw(responsible) ],
 108             }, {
 109                 rewrite => '$TEXT - $HREF',
 110                 fields  => [ qw(location more) ],
 111             } ],
 112             'br' => [ {
 113                 rewrite => '',
 114                 fields  => [ qw(more) ],
 115             } ],
 116         },
 117         strip_text => [ 'mailto:' ],
 118     });
 119     unlink $file;
 120 }
 121
 122 sub process_events
 123 {
 124     my $parser;
 125     init(\$parser);
 126
 127     while (my $event = $parser->next_event) {
 128         my %event = (
 129             year  => $event->get_event_year,
 130             month => $event->get_event_month,
 131             day   => $event->get_event_day,
 132             color => $event->get_event_color,
 133         );
 134
 135         my %sth;
 136
 137         $sth{subscribers} = $dbh->prepare('SELECT mail, mode, notify FROM subscribers');
 138         $sth{subscribers}->execute;
 139
 140         while (my $subscriber = $sth{subscribers}->fetchrow_hashref) {
 141             next unless $subscriber->{mode} == 2;
 142
 143             $sth{subscriptions} = $dbh->prepare('SELECT * FROM subscriptions WHERE mail = ?');
 144             $sth{subscriptions}->execute($subscriber->{mail});
 145
 146             my $subscriptions = $sth{subscriptions}->fetchrow_hashref;
 147             next unless $subscriptions->{$event{color}};
 148
 149             my $notify = DateTime->now(time_zone => 'Europe/Zurich');
 150
 151             $subscriber->{notify} ||= 0;
 152
 153             $notify->add(days => $subscriber->{notify});
 154
 155             if ($event{year}  == $notify->year
 156              && $event{month} == $notify->month
 157              && $event{day}   == $notify->day
 158             ) {
 159                 send_mail($event, $subscriber->{mail});
 160             }
 161         }
 162     }
 163 }
 164
 165 sub send_mail
 166 {
 167     my ($event, $mail_subscriber) = @_;
 168
 169     my $year        = $event->get_event_year;
 170     my $month       = $event->get_event_month;
 171     my $simple_day  = $event->get_event_simple_day;
 172     my $wday        = $event->get_event_weekday;
 173     my $time        = $event->get_event_time;
 174     my $title       = $event->get_event_title;
 175     my $color       = $event->get_event_color;
 176     my $location    = $event->get_event_location;
 177     my $responsible = $event->get_event_responsible;
 178     my $more        = $event->get_event_more || '';
 179
 180     wrap_text(\$more);
 181     chomp $more;
 182     wrap_text(\$location);
 183
 184     my $i;
 185     my %month_names = map { sprintf('%02d', ++$i) => $_ }
 186       qw(Januar Februar Maerz April Mai Juni Juli August
 187          September Oktober November Dezember);
 188
 189     my $month_name = $month_names{$month};
 190
 191 my $message = (<<MSG);
 192 Wann:\t$wday, $simple_day. $month_name $year, $time Uhr
 193 Was :\t$title
 194 Wo  :\t$location
 195 Wer :\t$responsible
 196 Info:\t$more
 197
 198 Web Interface:
 199 $Config->{form_url}
 200
 201 ${\info_string()}
 202 MSG
 203
 204     if ($run) {
 205         sendmail(
 206             From    => $Config->{mail_from},
 207             To      => $mail_subscriber,
 208             Subject => encode('MIME-Q', "LUGS Reminder - $title"),
 209             Message => $message,
 210         ) or die $Mail::Sendmail::error;
 211     }
 212     elsif ($test) {
 213         printf "[%s] <$mail_subscriber> ($color)\n", scalar localtime;
 214     }
 215 }
 216
 217 sub wrap_text
 218 {
 219     my ($text) = @_;
 220
 221     return unless length $$text;
 222
 223     my @chunks = fuzzy_wrap($$text, 70);
 224
 225     my $wrapped;
 226     foreach my $chunk (@chunks) {
 227         $wrapped .= ' ' x (defined $wrapped ? 8 : 0);
 228         $wrapped .= "$chunk\n";
 229     }
 230     chomp $wrapped;
 231
 232     $$text = $wrapped;
 233 }
 234
 235 sub info_string
 236 {
 237     my $script = File::Basename::basename($0);
 238     my $modified = localtime((stat($0))[9]);
 239
 240     $modified =~ s/(?<=\b) (?:\d{2}\:?){3} (?=\b)//x;
 241     $modified =~ s/\s+/ /g;
 242
 243     my $info = <<EOT;
 244 --
 245 running $script v$VERSION - last modified: $modified
 246 EOT
 247     return do { local $_ = $info; chomp while /\n$/; $_ };
 248 }