]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Libravatar.pm
get_bug_status can now accept a schema to pull from DB
[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 Exporter qw(import);
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 File::Temp qw(tempfile);
43 use File::LibMagic;
44 use Cwd qw(abs_path);
45
46 use Carp;
47
48 BEGIN{
49      ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
50      $DEBUG = 0 unless defined $DEBUG;
51
52      @EXPORT = ();
53      %EXPORT_TAGS = (libravatar => [qw(retrieve_libravatar cache_location)]
54                     );
55      @EXPORT_OK = ();
56      Exporter::export_ok_tags(keys %EXPORT_TAGS);
57      $EXPORT_TAGS{all} = [@EXPORT_OK];
58 }
59
60
61 our $magic;
62
63 =over
64
65 =item retrieve_libravatar
66
67      $cache_location = retrieve_libravatar(location => $cache_location,
68                                            email => lc($param{email}),
69                                           );
70
71 Returns the cache location where a specific avatar can be loaded. If
72 there isn't a matching avatar, or there is an error, returns undef.
73
74
75 =cut
76
77 sub retrieve_libravatar{
78     my %type_mapping =
79         (jpeg => 'jpg',
80          png => 'png',
81          gif => 'png',
82          tiff => 'png',
83          tif => 'png',
84          pjpeg => 'jpg',
85          jpg => 'jpg'
86         );
87     my %param = @_;
88     my $cache_location = $param{location};
89     my $timestamp;
90     $cache_location =~ s/\.[^\.\/]+$//;
91     # take out a lock on the cache location so that if another request
92     # is made while we are serving this one, we don't do double work
93     my ($fh,$lockfile,$errors) =
94         simple_filelock($cache_location.'.lock',20,0.5);
95     if (not $fh) {
96         return undef;
97     } else {
98         # figure out if the cache is now valid; if it is, return the
99         # cache location
100         my $temp_location;
101         ($temp_location, $timestamp) = cache_location(email => $param{email});
102         if ($timestamp) {
103             return ($temp_location,$timestamp);
104         }
105     }
106     require LWP::UserAgent;
107
108     my $dest_type = 'png';
109     eval {
110         my $uri = libravatar_url(email => $param{email},
111                                  default => 404,
112                                  size => 80);
113         my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
114                                     );
115         $ua->from($config{maintainer});
116         # if we don't get an avatar within 10 seconds, return so we
117         # don't block forever
118         $ua->timeout(10);
119         # if the avatar is bigger than 30K, we don't want it either
120         $ua->max_size(30*1024);
121         $ua->default_header('Accept' => 'image/*');
122         my $r = $ua->get($uri);
123         if (not $r->is_success()) {
124             if ($r->code != 404) {
125                 die "Not successful in request";
126             }
127             # No avatar - cache a negative result
128             if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) {
129                 $dest_type = $1;
130
131                 system('cp', '-laf', $config{libravatar_default_image},  $cache_location.'.'.$dest_type) == 0
132                   or die("Cannot copy $config{libravatar_default_image}");
133                 # Returns from eval {}
134                 return;
135             }
136         }
137         my $aborted = $r->header('Client-Aborted');
138         # if we exceeded max size, I'm not sure if we'll be
139         # successfull or not, but regardless, there will be a
140         # Client-Aborted header. Stop here if that header is defined.
141         die "Client aborted header" if defined $aborted;
142         my $type = $r->header('Content-Type');
143         # if there's no content type, or it's not one we like, we won't
144         # bother going further
145         if (defined $type) {
146             die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
147             $dest_type = $type_mapping{$1};
148             die "No dest type" if not defined $dest_type;
149         }
150         # undo any content encoding
151         $r->decode() or die "Unable to decode content encoding";
152         # ok, now we need to convert it from whatever it is into a
153         # format that we actually like
154         my ($temp_fh,$temp_fn) = tempfile() or
155             die "Unable to create temporary file";
156         eval {
157             print {$temp_fh} $r->content() or
158                 die "Unable to print to temp file";
159             close ($temp_fh) or
160                 die "Unable to close temp file";
161             ### Figure out the actual type from the file
162             $magic = File::LibMagic->new() if not defined $magic;
163             $type = $magic->checktype_filename(abs_path($temp_fn));
164             die "Wrong content type ($type)" if not $type =~ m{^image/([^/;]+)(?:;|$)};
165             $dest_type = $type_mapping{$1};
166             die "No dest type for ($1)" if not defined $dest_type;
167             ### resize all images to 80x80 and strip comments out of
168             ### them. If convert has a bug, it would be possible for
169             ### this to be an attack vector, but hopefully minimizing
170             ### the size above, and requiring proper mime types will
171             ### minimize that slightly. Doing this will at least make
172             ### it harder for malicious web images to harm our users
173             system('convert','-resize','80x80',
174                    '-strip',
175                    $temp_fn,
176                    $cache_location.'.'.$dest_type) == 0 or
177                        die "convert file failed";
178             unlink($temp_fn);
179         };
180         if ($@) {
181             unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
182             unlink($temp_fn) if -e $temp_fn;
183             die "Unable to convert image";
184         }
185     };
186     if ($@) {
187         # there was some kind of error; return undef and unlock the
188         # lock
189         simple_unlockfile($fh,$lockfile);
190         return undef;
191     }
192     simple_unlockfile($fh,$lockfile);
193     $timestamp = (stat($cache_location.'.'.$dest_type))[9];
194     return ($cache_location.'.'.$dest_type,$timestamp);
195 }
196
197 sub blocked_libravatar {
198     my ($email,$md5sum) = @_;
199     my $blocked = 0;
200     for my $blocker (@{$config{libravatar_blacklist}||[]}) {
201         for my $element ($email,$md5sum) {
202             next unless defined $element;
203             eval {
204                 if ($element =~ /$blocker/) {
205                     $blocked=1;
206                 }
207             };
208         }
209     }
210     return $blocked;
211 }
212
213 # Returns ($path, $timestamp)
214 # - For blocked images, $path will be undef
215 # - If $timestamp is 0 (and $path is not undef), the image should
216 #   be re-fetched.
217 sub cache_location {
218     my %param = @_;
219     my ($md5sum, $stem);
220     if (exists $param{md5sum}) {
221         $md5sum = $param{md5sum};
222     }elsif (exists $param{email}) {
223         $md5sum = md5_hex(lc($param{email}));
224     } else {
225         croak("cache_location must be called with one of md5sum or email");
226     }
227     return (undef, 0) if blocked_libravatar($param{email},$md5sum);
228     my $cache_dir = $param{cache_dir} // $config{libravatar_cache_dir};
229     $stem = $cache_dir.'/'.$md5sum;
230     for my $ext ('.png', '.jpg', '') {
231         my $path = $stem.$ext;
232         if (-e $path) {
233             my $timestamp = (time - (stat(_))[9] < 60*60) ? (stat(_))[9] : 0;
234             return ($path, $timestamp);
235         }
236     }
237     return ($stem, 0);
238 }
239
240 ## the following is mod_perl specific
241
242 BEGIN{
243     if (exists $ENV{MOD_PERL_API_VERSION}) {
244         if ($ENV{MOD_PERL_API_VERSION} == 2) {
245             require Apache2::RequestIO;
246             require Apache2::RequestRec;
247             require Apache2::RequestUtil;
248             require Apache2::Const;
249             require APR::Finfo;
250             require APR::Const;
251             APR::Const->import(-compile => qw(FINFO_NORM));
252             Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED));
253         } else {
254             die "Unsupported mod perl api; mod_perl 2.0.0 or later is required";
255         }
256     }
257 }
258
259 sub handler {
260     die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION};
261     my $r = shift or Apache2::RequestUtil->request;
262
263     # we only want GET or HEAD requests
264     unless ($r->method eq 'HEAD' or $r->method eq 'GET') {
265         return Apache2::Const::DECLINED();
266     }
267     $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar";
268
269     my $uri = $r->uri();
270     # subtract out location
271     my $location = $r->location();
272     my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/;
273     if (not length $email) {
274         return Apache2::Const::NOT_FOUND();
275     }
276     my $q = CGI::Simple->new();
277     my %param = cgi_parameters(query => $q,
278                                single => [qw(avatar)],
279                                default => {avatar => 'yes',
280                                           },
281                               );
282     if ($param{avatar} ne 'yes' or not defined $email or not length $email) {
283         serve_cache_mod_perl('',$r);
284         return Apache2::Const::DECLINED();
285     }
286     # figure out what the md5sum of the e-mail is.
287     my ($cache_location, $timestamp) = cache_location(email => $email);
288     # if we've got it, and it's less than one hour old, return it.
289     if ($timestamp) {
290         serve_cache_mod_perl($cache_location,$r);
291         return Apache2::Const::DECLINED();
292     }
293     ($cache_location,$timestamp) =
294         retrieve_libravatar(location => $cache_location,
295                             email => $email,
296                            );
297     if (not defined $cache_location) {
298         # failure, serve the default image
299         serve_cache_mod_perl('',$r,$timestamp);
300         return Apache2::Const::DECLINED();
301     } else {
302         serve_cache_mod_perl($cache_location,$r,$timestamp);
303         return Apache2::Const::DECLINED();
304     }
305 }
306
307
308
309 sub serve_cache_mod_perl {
310     my ($cache_location,$r,$timestamp) = @_;
311     if (not defined $cache_location or not length $cache_location) {
312         # serve the default image
313         $cache_location = $config{libravatar_default_image};
314     }
315     $magic = File::LibMagic->new() if not defined $magic;
316
317     return Apache2::Const::DECLINED() if not defined $magic;
318
319     $r->content_type($magic->checktype_filename(abs_path($cache_location)));
320
321     $r->filename($cache_location);
322     $r->path_info('');
323     $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool));
324 }
325
326 =back
327
328 =cut
329
330 1;
331
332
333 __END__