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>.
6 package Debbugs::Libravatar;
10 Debbugs::Libravatar -- Libravatar service handler (mod_perl)
14 <Location /libravatar>
15 SetHandler perl-script
16 PerlResponseHandler Debbugs::Libravatar
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.
33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
34 use Exporter qw(import);
36 use Debbugs::Config qw(:config);
37 use Debbugs::Common qw(:lock);
40 use Debbugs::CGI qw(cgi_parameters);
41 use Digest::MD5 qw(md5_hex);
42 use File::Temp qw(tempfile);
49 ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
50 $DEBUG = 0 unless defined $DEBUG;
53 %EXPORT_TAGS = (libravatar => [qw(retrieve_libravatar cache_location)]
56 Exporter::export_ok_tags(keys %EXPORT_TAGS);
57 $EXPORT_TAGS{all} = [@EXPORT_OK];
63 =item retrieve_libravatar
65 $cache_location = retrieve_libravatar(location => $cache_location,
66 email => lc($param{email}),
69 Returns the cache location where a specific avatar can be loaded. If
70 there isn't a matching avatar, or there is an error, returns undef.
75 sub retrieve_libravatar{
86 my $cache_location = $param{location};
88 $cache_location =~ s/\.[^\.\/]+$//;
89 # take out a lock on the cache location so that if another request
90 # is made while we are serving this one, we don't do double work
91 my ($fh,$lockfile,$errors) =
92 simple_filelock($cache_location.'.lock',20,0.5);
96 # figure out if the cache is now valid; if it is, return the
99 ($temp_location, $timestamp) = cache_location(email => $param{email});
101 return ($temp_location,$timestamp);
104 require LWP::UserAgent;
108 my $uri = libravatar_url(email => $param{email},
111 my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
113 $ua->from($config{maintainer});
114 # if we don't get an avatar within 10 seconds, return so we
115 # don't block forever
117 # if the avatar is bigger than 30K, we don't want it either
118 $ua->max_size(30*1024);
119 my $r = $ua->get($uri);
120 if (not $r->is_success()) {
121 if ($r->code != 404) {
122 die "Not successful in request";
124 # No avatar - cache a negative result
125 if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) {
128 system('cp', '-laf', $config{libravatar_default_image}, $cache_location.'.'.$dest_type) == 0
129 or die("Cannot copy $config{libravatar_default_image}");
130 # Returns from eval {}
134 my $aborted = $r->header('Client-Aborted');
135 # if we exceeded max size, I'm not sure if we'll be
136 # successfull or not, but regardless, there will be a
137 # Client-Aborted header. Stop here if that header is defined.
138 die "Client aborted header" if defined $aborted;
139 my $type = $r->header('Content-Type');
140 # if there's no content type, or it's not one we like, we won't
141 # bother going further
142 die "No content type" if not defined $type;
143 die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
144 $dest_type = $type_mapping{$1};
145 die "No dest type" if not defined $dest_type;
146 # undo any content encoding
147 $r->decode() or die "Unable to decode content encoding";
148 # ok, now we need to convert it from whatever it is into a
149 # format that we actually like
150 my ($temp_fh,$temp_fn) = tempfile() or
151 die "Unable to create temporary file";
153 print {$temp_fh} $r->content() or
154 die "Unable to print to temp file";
156 ### resize all images to 80x80 and strip comments out of
157 ### them. If convert has a bug, it would be possible for
158 ### this to be an attack vector, but hopefully minimizing
159 ### the size above, and requiring proper mime types will
160 ### minimize that slightly. Doing this will at least make
161 ### it harder for malicious web images to harm our users
162 system('convert','-resize','80x80',
165 $cache_location.'.'.$dest_type) == 0 or
166 die "convert file failed";
170 unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
171 unlink($temp_fn) if -e $temp_fn;
172 die "Unable to convert image";
176 # there was some kind of error; return undef and unlock the
178 simple_unlockfile($fh,$lockfile);
181 simple_unlockfile($fh,$lockfile);
182 $timestamp = (stat($cache_location.'.'.$dest_type))[9];
183 return ($cache_location.'.'.$dest_type,$timestamp);
186 sub blocked_libravatar {
187 my ($email,$md5sum) = @_;
189 for my $blocker (@{$config{libravatar_blacklist}||[]}) {
190 for my $element ($email,$md5sum) {
191 next unless defined $element;
193 if ($element =~ /$blocker/) {
202 # Returns ($path, $timestamp)
203 # - For blocked images, $path will be undef
204 # - If $timestamp is 0 (and $path is not undef), the image should
209 if (exists $param{md5sum}) {
210 $md5sum = $param{md5sum};
211 }elsif (exists $param{email}) {
212 $md5sum = md5_hex(lc($param{email}));
214 croak("cache_location must be called with one of md5sum or email");
216 return (undef, 0) if blocked_libravatar($param{email},$md5sum);
217 $stem = $config{libravatar_cache_dir}.'/'.$md5sum;
218 for my $ext ('.png', '.jpg', '') {
219 my $path = $stem.$ext;
221 my $timestamp = (time - (stat(_))[9] < 60*60) ? (stat(_))[9] : 0;
222 return ($path, $timestamp);
228 ## the following is mod_perl specific
231 if (exists $ENV{MOD_PERL_API_VERSION}) {
232 if ($ENV{MOD_PERL_API_VERSION} == 2) {
233 require Apache2::RequestIO;
234 require Apache2::RequestRec;
235 require Apache2::RequestUtil;
236 require Apache2::Const;
239 APR::Const->import(-compile => qw(FINFO_NORM));
240 Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED));
242 die "Unsupported mod perl api; mod_perl 2.0.0 or later is required";
248 die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION};
249 my $r = shift or Apache2::RequestUtil->request;
251 # we only want GET or HEAD requests
252 unless ($r->method eq 'HEAD' or $r->method eq 'GET') {
253 return Apache2::Const::DECLINED();
255 $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar";
258 # subtract out location
259 my $location = $r->location();
260 my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/;
261 if (not length $email) {
262 return Apache2::Const::NOT_FOUND();
264 my $q = CGI::Simple->new();
265 my %param = cgi_parameters(query => $q,
266 single => [qw(avatar)],
267 default => {avatar => 'yes',
270 if ($param{avatar} ne 'yes' or not defined $email or not length $email) {
271 serve_cache_mod_perl('',$r);
272 return Apache2::Const::DECLINED();
274 # figure out what the md5sum of the e-mail is.
275 my ($cache_location, $timestamp) = cache_location(email => $email);
276 # if we've got it, and it's less than one hour old, return it.
278 serve_cache_mod_perl($cache_location,$r);
279 return Apache2::Const::DECLINED();
281 ($cache_location,$timestamp) =
282 retrieve_libravatar(location => $cache_location,
285 if (not defined $cache_location) {
286 # failure, serve the default image
287 serve_cache_mod_perl('',$r,$timestamp);
288 return Apache2::Const::DECLINED();
290 serve_cache_mod_perl($cache_location,$r,$timestamp);
291 return Apache2::Const::DECLINED();
299 sub serve_cache_mod_perl {
300 my ($cache_location,$r,$timestamp) = @_;
301 if (not defined $cache_location or not length $cache_location) {
302 # serve the default image
303 $cache_location = $config{libravatar_default_image};
305 $magic = File::LibMagic->new() if not defined $magic;
307 return Apache2::Const::DECLINED() if not defined $magic;
309 $r->content_type($magic->checktype_filename(abs_path($cache_location)));
311 $r->filename($cache_location);
313 $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool));