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: Wed Dec  4 21:18:20 CET 2013
  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 DBI ();
  27 use Encode qw(encode);
  28 use File::Basename ();
  29 use File::Spec ();
  30 use FindBin qw($Bin);
  31 use Getopt::Long qw(:config no_auto_abbrev no_ignore_case);
  32 use Hook::Output::File ();
  33 use LUGS::Events::Parser ();
  34 use Mail::Sendmail qw(sendmail);
  35 use Text::Wrap::Smart::XS qw(fuzzy_wrap);
  36 use WWW::Mechanize ();
  37
  38 my $VERSION = '0.42';
  39
  40 #-----------------------
  41 # Start of configuration
  42 #-----------------------
  43
  44 my $Config = {
  45     events_url => 'http://www.lugs.ch/lugs/termine/termine.txt',
  46     form_url   => 'http://lists.lugs.ch/reminder.cgi',
  47     mail_from  => 'reminder@lugs.ch',
  48     dbase_name => '<hidden>',
  49     dbase_user => '<hidden>',
  50     dbase_pass => '<hidden>',
  51 };
  52
  53 #---------------------
  54 # End of configuration
  55 #---------------------
  56
  57 my $dbh  = DBI->connect("dbi:mysql(RaiseError=>1):$Config->{dbase_name}", $Config->{dbase_user}, $Config->{dbase_pass});
  58 my $file = File::Basename::basename($Config->{events_url});
  59
  60 my ($test, $run) = (false, false);
  61
  62 {
  63     getopts(\$test, \$run);
  64     my $hook = Hook::Output::File->redirect(
  65         stdout => File::Spec->catfile($Bin, 'stdout.out'),
  66         stderr => File::Spec->catfile($Bin, 'stderr.out'),
  67     );
  68     fetch_and_write_events();
  69     process_events();
  70 }
  71
  72 sub getopts
  73 {
  74     my ($test, $run) = @_;
  75
  76     GetOptions(test => $test, run => $run) or exit;
  77
  78     if (not $$test || $$run) {
  79         die "$0: neither --test nor --run specified, exiting\n";
  80     }
  81     elsif ($$test && $$run) {
  82         die "$0: both --test and --run specified, exiting\n";
  83     }
  84     return; # --test or --run specified
  85 }
  86
  87 sub fetch_and_write_events
  88 {
  89     my $mech = WWW::Mechanize->new;
  90     my $http = $mech->get($Config->{events_url});
  91
  92     open(my $fh, '>', $file) or die "Cannot open $file: $!\n";
  93     print {$fh} $http->content;
  94     close($fh);
  95 }
  96
  97 sub init
  98 {
  99     my ($parser, $month_days, $current) = @_;
 100
 101     $$parser = LUGS::Events::Parser->new($file, {
 102         filter_html  => true,
 103         tag_handlers => {
 104             'a href' => [ {
 105                 rewrite => '$TEXT - <$HREF>',
 106                 fields  => [ qw(responsible) ],
 107             }, {
 108                 rewrite => '$TEXT - $HREF',
 109                 fields  => [ qw(location more) ],
 110             } ],
 111             'br' => [ {
 112                 rewrite => '',
 113                 fields  => [ qw(more) ],
 114             } ],
 115         },
 116         strip_text => [ 'mailto:' ],
 117     });
 118     unlink $file;
 119
 120     %$month_days = (
 121         1 => 31,   7 => 31,
 122         2 => 28,   8 => 31,
 123         3 => 31,   9 => 30,
 124         4 => 30,  10 => 31,
 125         5 => 31,  11 => 30,
 126         6 => 30,  12 => 31,
 127     );
 128
 129     %$current = do {
 130         my @time = (localtime)[3..5];
 131         $time[1]++;
 132         $time[2] += 1900;
 133         map { $_ => shift @time } qw(day month year);
 134     };
 135 }
 136
 137 sub process_events
 138 {
 139     my   ($parser,  %month_days,  %current);
 140     init(\$parser, \%month_days, \%current);
 141
 142     while (my $event = $parser->next_event) {
 143         my %event = (
 144             year  => $event->get_event_year,
 145             month => $event->get_event_month,
 146             day   => $event->get_event_day,
 147             color => $event->get_event_color,
 148         );
 149
 150         my %sth;
 151
 152         $sth{subscribers} = $dbh->prepare('SELECT mail, mode, notify FROM subscribers');
 153         $sth{subscribers}->execute;
 154
 155         while (my $subscriber = $sth{subscribers}->fetchrow_hashref) {
 156             next unless $subscriber->{mode} == 2;
 157
 158             $sth{subscriptions} = $dbh->prepare('SELECT * FROM subscriptions WHERE mail = ?');
 159             $sth{subscriptions}->execute($subscriber->{mail});
 160
 161             my $subscriptions = $sth{subscriptions}->fetchrow_hashref;
 162             next unless $subscriptions->{$event{color}};
 163
 164             my %notify = %current;
 165
 166             $subscriber->{notify} ||= 0;
 167
 168             my $day = $current{day} + $subscriber->{notify};
 169             my $days_in_month = $month_days{$current{month}};
 170
 171             if ($day > $days_in_month) {
 172                 $notify{day} = $day - $days_in_month;
 173                 $notify{month}++;
 174             }
 175             else {
 176                 $notify{day} += $subscriber->{notify};
 177             }
 178
 179             if ($event{year}  == $notify{year}
 180              && $event{month} == $notify{month}
 181              && $event{day}   == $notify{day}
 182             ) {
 183                 send_mail($event, $subscriber->{mail});
 184             }
 185         }
 186     }
 187 }
 188
 189 sub send_mail
 190 {
 191     my ($event, $mail_subscriber) = @_;
 192
 193     my $year        = $event->get_event_year;
 194     my $month       = $event->get_event_month;
 195     my $simple_day  = $event->get_event_simple_day;
 196     my $wday        = $event->get_event_weekday;
 197     my $time        = $event->get_event_time;
 198     my $title       = $event->get_event_title;
 199     my $color       = $event->get_event_color;
 200     my $location    = $event->get_event_location;
 201     my $responsible = $event->get_event_responsible;
 202     my $more        = $event->get_event_more || '';
 203
 204     wrap_text(\$more);
 205     chomp $more;
 206     wrap_text(\$location);
 207
 208     my $i;
 209     my %month_names = map { sprintf('%02d', ++$i) => $_ }
 210       qw(Januar Februar Maerz April Mai Juni Juli August
 211          September Oktober November Dezember);
 212
 213     my $month_name = $month_names{$month};
 214
 215 my $message = (<<MSG);
 216 Wann:\t$wday, $simple_day. $month_name $year, $time Uhr
 217 Was :\t$title
 218 Wo  :\t$location
 219 Wer :\t$responsible
 220 Info:\t$more
 221
 222 Web Interface:
 223 $Config->{form_url}
 224
 225 ${\info_string()}
 226 MSG
 227
 228     if ($run) {
 229         sendmail(
 230             From    => $Config->{mail_from},
 231             To      => $mail_subscriber,
 232             Subject => encode('MIME-Q', "LUGS Reminder - $title"),
 233             Message => $message,
 234         ) or die $Mail::Sendmail::error;
 235     }
 236     elsif ($test) {
 237         printf "[%s] <$mail_subscriber> ($color)\n", scalar localtime;
 238     }
 239 }
 240
 241 sub wrap_text
 242 {
 243     my ($text) = @_;
 244
 245     return unless length $$text;
 246
 247     my @chunks = fuzzy_wrap($$text, 70);
 248
 249     my $wrapped;
 250     foreach my $chunk (@chunks) {
 251         $wrapped .= ' ' x (defined $wrapped ? 8 : 0);
 252         $wrapped .= "$chunk\n";
 253     }
 254     chomp $wrapped;
 255
 256     $$text = $wrapped;
 257 }
 258
 259 sub info_string
 260 {
 261     my $script = File::Basename::basename($0);
 262     my $modified = localtime((stat($0))[9]);
 263
 264     $modified =~ s/(?<=\b) (?:\d{2}\:?){3} (?=\b)//x;
 265     $modified =~ s/\s+/ /g;
 266
 267     my $info = <<EOT;
 268 --
 269 running $script v$VERSION - last modified: $modified
 270 EOT
 271     return do { local $_ = $info; chomp while /\n$/; $_ };
 272 }