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