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