lreminder: fix encoding of subject line
[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: 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 }