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