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