]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Libravatar.pm
fix how e-mails are passed to the avatar script
[debbugs.git] / Debbugs / Libravatar.pm
1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later version. See the
3 # file README and COPYING for more information.
4 # Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
5
6 package Debbugs::Libravatar;
7
8 =head1 NAME
9
10 Debbugs::Libravatar -- Libravatar service handler (mod_perl)
11
12 =head1 SYNOPSIS
13
14 <Location /libravatar>
15    SetHandler perl-script
16    PerlResponseHandler Debbugs::Libravatar
17 </Location>
18
19 =head1 DESCRIPTION
20
21 Debbugs::Libravatar is a libravatar service handler which will serve
22 libravatar requests. It also contains utility routines which are used
23 by the libravatar.cgi script for those who do not have mod_perl.
24
25 =head1 BUGS
26
27 None known.
28
29 =cut
30
31 use warnings;
32 use strict;
33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
34 use base qw(Exporter);
35
36 use Debbugs::Config qw(:config);
37 use Debbugs::Common qw(:lock);
38 use Libravatar::URL;
39 use CGI::Simple;
40 use Debbugs::CGI qw(cgi_parameters);
41 use Digest::MD5 qw(md5_hex);
42 use LWP::UserAgent;
43 use File::Temp qw(tempfile);
44
45 use Carp;
46
47 BEGIN{
48      ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
49      $DEBUG = 0 unless defined $DEBUG;
50
51      @EXPORT = ();
52      %EXPORT_TAGS = (libravatar => [qw(cache_valid serve_cache retrieve_libravatar cache_location)]
53                     );
54      @EXPORT_OK = ();
55      Exporter::export_ok_tags(keys %EXPORT_TAGS);
56      $EXPORT_TAGS{all} = [@EXPORT_OK];
57 }
58
59 sub cache_valid{
60     my ($cache_location) = @_;
61     if (-e $cache_location) {
62         if (time - (stat($cache_location))[9] < 60*60) {
63             return 1;
64         }
65     }
66     return 0;
67 }
68
69 =over
70
71 =item retrieve_libravatar
72
73      $cache_location = retrieve_libravatar(location => $cache_location,
74                                            email => lc($param{email}),
75                                           );
76
77 Returns the cache location where a specific avatar can be loaded. If
78 there isn't a matching avatar, or there is an error, returns undef.
79
80
81 =cut
82
83 sub retrieve_libravatar{
84     my %type_mapping =
85         (jpeg => 'jpg',
86          png => 'png',
87          gif => 'png',
88          tiff => 'png',
89          tif => 'png',
90          pjpeg => 'jpg',
91          jpg => 'jpg'
92         );
93     my %param = @_;
94     my $cache_location = $param{location};
95     $cache_location =~ s/\.[^\.]+$//;
96     # take out a lock on the cache location so that if another request
97     # is made while we are serving this one, we don't do double work
98     my ($fh,$lockfile,$errors) =
99         simple_filelock($cache_location.'.lock',20,0.5);
100     if (not $fh) {
101         return undef;
102     } else {
103         # figure out if the cache is now valid; if it is, return the
104         # cache location
105         my $temp_location = cache_location(email => $param{email});
106         if (cache_valid($temp_location)) {
107             return $temp_location;
108         }
109     }
110     my $dest_type;
111     eval {
112         my $uri = libravatar_url(email => $param{email},
113                                  default => 404,
114                                  size => 80);
115         my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
116                                     );
117         $ua->from($config{maintainer});
118         # if we don't get an avatar within 10 seconds, return so we
119         # don't block forever
120         $ua->timeout(10);
121         # if the avatar is bigger than 30K, we don't want it either
122         $ua->max_size(30*1024);
123         my $r = $ua->get($uri);
124         if (not $r->is_success()) {
125             die "Not successful in request";
126         }
127         my $aborted = $r->header('Client-Aborted');
128         # if we exceeded max size, I'm not sure if we'll be
129         # successfull or not, but regardless, there will be a
130         # Client-Aborted header. Stop here if that header is defined.
131         die "Client aborted header" if defined $aborted;
132         my $type = $r->header('Content-Type');
133         # if there's no content type, or it's not one we like, we won't
134         # bother going further
135         die "No content type" if not defined $type;
136         die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
137         $dest_type = $type_mapping{$1};
138         die "No dest type" if not defined $dest_type;
139         # undo any content encoding
140         $r->decode() or die "Unable to decode content encoding";
141         # ok, now we need to convert it from whatever it is into a
142         # format that we actually like
143         my ($temp_fh,$temp_fn) = tempfile() or
144             die "Unable to create temporary file";
145         eval {
146             print {$temp_fh} $r->content() or
147                 die "Unable to print to temp file";
148             close ($temp_fh);
149             ### resize all images to 80x80 and strip comments out of
150             ### them. If convert has a bug, it would be possible for
151             ### this to be an attack vector, but hopefully minimizing
152             ### the size above, and requiring proper mime types will
153             ### minimize that slightly. Doing this will at least make
154             ### it harder for malicious web images to harm our users
155             system('convert','-resize','80x80',
156                    '-strip',
157                    $temp_fn,
158                    $cache_location.'.'.$dest_type) == 0 or
159                        die "convert file failed";
160             unlink($temp_fh);
161         };
162         if ($@) {
163             unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
164             unlink($temp_fn) if -e $temp_fn;
165             die "Unable to convert image";
166         }
167     };
168     if ($@) {
169         # there was some kind of error; return undef and unlock the
170         # lock
171         simple_unlockfile($fh,$lockfile);
172         return undef;
173     }
174     simple_unlockfile($fh,$lockfile);
175     return $cache_location.'.'.$dest_type;
176 }
177
178 sub blocked_libravatar {
179     my ($email,$md5sum) = @_;
180     my $blocked = 0;
181     for my $blocker (@{$config{libravatar_blacklist}||[]}) {
182         for my $element ($email,$md5sum) {
183             next unless defined $element;
184             eval {
185                 if ($element =~ /$blocker/) {
186                     $blocked=1;
187                 }
188             };
189         }
190     }
191     return $blocked;
192 }
193
194 sub cache_location {
195     my %param = @_;
196     my $md5sum;
197     if (exists $param{md5sum}) {
198         $md5sum = $param{md5sum};
199     }elsif (exists $param{email}) {
200         $md5sum = md5_hex(lc($param{email}));
201     } else {
202         croak("cache_location must be called with one of md5sum or email");
203     }
204     return undef if blocked_libravatar($param{email},$md5sum);
205     for my $ext (qw(.png .jpg)) {
206         if (-e $config{libravatar_cache_dir}.'/'.$md5sum.$ext) {
207             return $config{libravatar_cache_dir}.'/'.$md5sum.$ext;
208         }
209     }
210     return $config{libravatar_cache_dir}.'/'.$md5sum;
211 }
212
213 ## the following is mod_perl specific
214
215 BEGIN{
216     if (exists $ENV{MOD_PERL_API_VERSION}) {
217         if ($ENV{MOD_PERL_API_VERSION} == 2) {
218             require Apache2::RequestIO;
219             require Apache2::RequestRec;
220             require Apache2::RequestUtil;
221             require Apache2::Const;
222             require APR::Finfo;
223             require APR::Const;
224             APR::Const->import(-compile => qw(FINFO_NORM));
225             Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED));
226         } else {
227             die "Unsupported mod perl api; mod_perl 2.0.0 or later is required";
228         }
229     }
230 }
231
232 sub handler {
233     die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION};
234     my $r = shift or Apache2::RequestUtil->request;
235
236     # we only want GET or HEAD requests
237     unless ($r->method eq 'HEAD' or $r->method eq 'GET') {
238         return Apache2::Const::DECLINED();
239     }
240     $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar";
241
242     my $uri = $r->uri();
243     # subtract out location
244     my $location = $r->location();
245     my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/;
246     if (not length $email) {
247         return Apache2::Const::NOT_FOUND;
248     }
249     my $q = CGI::Simple->new();
250     my %param = cgi_parameters(query => $q,
251                                single => [qw(avatar)],
252                                default => {avatar => 'yes',
253                                           },
254                               );
255     if ($param{avatar} ne 'yes' or not defined $email or not length $email) {
256         serve_cache_mod_perl('',$r);
257         return Apache2::Const::DECLINED();
258     }
259     # figure out what the md5sum of the e-mail is.
260     my $cache_location = cache_location(email => $email);
261     # if we've got it, and it's less than one hour old, return it.
262     if (cache_valid($cache_location)) {
263         serve_cache_mod_perl($cache_location,$r);
264         return Apache2::Const::DECLINED();
265     }
266     $cache_location = retreive_libravatar(location => $cache_location,
267                                           email => $email,
268                                          );
269     if (not defined $cache_location) {
270         # failure, serve the default image
271         serve_cache_mod_perl('',$r);
272         return Apache2::Const::DECLINED();
273     } else {
274         serve_cache_mod_perl($cache_location,$r);
275         return Apache2::Const::DECLINED();
276     }
277 }
278
279
280 sub serve_cache_mod_perl {
281     my ($cache_location,$r) = @_;
282     if (not defined $cache_location or not length $cache_location) {
283         # serve the default image
284         $cache_location = $config{libravatar_default_image};
285     }
286     $r->filename($cache_location);
287     $r->path_info('');
288     $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM, $r->pool));
289 }
290
291 =back
292
293 =cut
294
295 1;
296
297
298 __END__