X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;ds=sidebyside;f=lib%2FDebbugs%2FLibravatar.pm;fp=lib%2FDebbugs%2FLibravatar.pm;h=373a9f5374cef6ae9426dc16db33fa96aa2d68c7;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=0000000000000000000000000000000000000000;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/lib/Debbugs/Libravatar.pm b/lib/Debbugs/Libravatar.pm new file mode 100644 index 0000000..373a9f5 --- /dev/null +++ b/lib/Debbugs/Libravatar.pm @@ -0,0 +1,333 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2013 by Don Armstrong . + +package Debbugs::Libravatar; + +=head1 NAME + +Debbugs::Libravatar -- Libravatar service handler (mod_perl) + +=head1 SYNOPSIS + + + SetHandler perl-script + PerlResponseHandler Debbugs::Libravatar + + +=head1 DESCRIPTION + +Debbugs::Libravatar is a libravatar service handler which will serve +libravatar requests. It also contains utility routines which are used +by the libravatar.cgi script for those who do not have mod_perl. + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use Debbugs::Config qw(:config); +use Debbugs::Common qw(:lock); +use Libravatar::URL; +use CGI::Simple; +use Debbugs::CGI qw(cgi_parameters); +use Digest::MD5 qw(md5_hex); +use File::Temp qw(tempfile); +use File::LibMagic; +use Cwd qw(abs_path); + +use Carp; + +BEGIN{ + ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (libravatar => [qw(retrieve_libravatar cache_location)] + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + + +our $magic; + +=over + +=item retrieve_libravatar + + $cache_location = retrieve_libravatar(location => $cache_location, + email => lc($param{email}), + ); + +Returns the cache location where a specific avatar can be loaded. If +there isn't a matching avatar, or there is an error, returns undef. + + +=cut + +sub retrieve_libravatar{ + my %type_mapping = + (jpeg => 'jpg', + png => 'png', + gif => 'png', + tiff => 'png', + tif => 'png', + pjpeg => 'jpg', + jpg => 'jpg' + ); + my %param = @_; + my $cache_location = $param{location}; + my $timestamp; + $cache_location =~ s/\.[^\.\/]+$//; + # take out a lock on the cache location so that if another request + # is made while we are serving this one, we don't do double work + my ($fh,$lockfile,$errors) = + simple_filelock($cache_location.'.lock',20,0.5); + if (not $fh) { + return undef; + } else { + # figure out if the cache is now valid; if it is, return the + # cache location + my $temp_location; + ($temp_location, $timestamp) = cache_location(email => $param{email}); + if ($timestamp) { + return ($temp_location,$timestamp); + } + } + require LWP::UserAgent; + + my $dest_type = 'png'; + eval { + my $uri = libravatar_url(email => $param{email}, + default => 404, + size => 80); + my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)', + ); + $ua->from($config{maintainer}); + # if we don't get an avatar within 10 seconds, return so we + # don't block forever + $ua->timeout(10); + # if the avatar is bigger than 30K, we don't want it either + $ua->max_size(30*1024); + $ua->default_header('Accept' => 'image/*'); + my $r = $ua->get($uri); + if (not $r->is_success()) { + if ($r->code != 404) { + die "Not successful in request"; + } + # No avatar - cache a negative result + if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) { + $dest_type = $1; + + system('cp', '-laf', $config{libravatar_default_image}, $cache_location.'.'.$dest_type) == 0 + or die("Cannot copy $config{libravatar_default_image}"); + # Returns from eval {} + return; + } + } + my $aborted = $r->header('Client-Aborted'); + # if we exceeded max size, I'm not sure if we'll be + # successfull or not, but regardless, there will be a + # Client-Aborted header. Stop here if that header is defined. + die "Client aborted header" if defined $aborted; + my $type = $r->header('Content-Type'); + # if there's no content type, or it's not one we like, we won't + # bother going further + if (defined $type) { + die "Wrong content type" if not $type =~ m{^image/([^/]+)$}; + $dest_type = $type_mapping{$1}; + die "No dest type" if not defined $dest_type; + } + # undo any content encoding + $r->decode() or die "Unable to decode content encoding"; + # ok, now we need to convert it from whatever it is into a + # format that we actually like + my ($temp_fh,$temp_fn) = tempfile() or + die "Unable to create temporary file"; + eval { + print {$temp_fh} $r->content() or + die "Unable to print to temp file"; + close ($temp_fh) or + die "Unable to close temp file"; + ### Figure out the actual type from the file + $magic = File::LibMagic->new() if not defined $magic; + $type = $magic->checktype_filename(abs_path($temp_fn)); + die "Wrong content type ($type)" if not $type =~ m{^image/([^/;]+)(?:;|$)}; + $dest_type = $type_mapping{$1}; + die "No dest type for ($1)" if not defined $dest_type; + ### resize all images to 80x80 and strip comments out of + ### them. If convert has a bug, it would be possible for + ### this to be an attack vector, but hopefully minimizing + ### the size above, and requiring proper mime types will + ### minimize that slightly. Doing this will at least make + ### it harder for malicious web images to harm our users + system('convert','-resize','80x80', + '-strip', + $temp_fn, + $cache_location.'.'.$dest_type) == 0 or + die "convert file failed"; + unlink($temp_fn); + }; + if ($@) { + unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type; + unlink($temp_fn) if -e $temp_fn; + die "Unable to convert image"; + } + }; + if ($@) { + # there was some kind of error; return undef and unlock the + # lock + simple_unlockfile($fh,$lockfile); + return undef; + } + simple_unlockfile($fh,$lockfile); + $timestamp = (stat($cache_location.'.'.$dest_type))[9]; + return ($cache_location.'.'.$dest_type,$timestamp); +} + +sub blocked_libravatar { + my ($email,$md5sum) = @_; + my $blocked = 0; + for my $blocker (@{$config{libravatar_blacklist}||[]}) { + for my $element ($email,$md5sum) { + next unless defined $element; + eval { + if ($element =~ /$blocker/) { + $blocked=1; + } + }; + } + } + return $blocked; +} + +# Returns ($path, $timestamp) +# - For blocked images, $path will be undef +# - If $timestamp is 0 (and $path is not undef), the image should +# be re-fetched. +sub cache_location { + my %param = @_; + my ($md5sum, $stem); + if (exists $param{md5sum}) { + $md5sum = $param{md5sum}; + }elsif (exists $param{email}) { + $md5sum = md5_hex(lc($param{email})); + } else { + croak("cache_location must be called with one of md5sum or email"); + } + return (undef, 0) if blocked_libravatar($param{email},$md5sum); + my $cache_dir = $param{cache_dir} // $config{libravatar_cache_dir}; + $stem = $cache_dir.'/'.$md5sum; + for my $ext ('.png', '.jpg', '') { + my $path = $stem.$ext; + if (-e $path) { + my $timestamp = (time - (stat(_))[9] < 60*60) ? (stat(_))[9] : 0; + return ($path, $timestamp); + } + } + return ($stem, 0); +} + +## the following is mod_perl specific + +BEGIN{ + if (exists $ENV{MOD_PERL_API_VERSION}) { + if ($ENV{MOD_PERL_API_VERSION} == 2) { + require Apache2::RequestIO; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::Const; + require APR::Finfo; + require APR::Const; + APR::Const->import(-compile => qw(FINFO_NORM)); + Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED)); + } else { + die "Unsupported mod perl api; mod_perl 2.0.0 or later is required"; + } + } +} + +sub handler { + die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION}; + my $r = shift or Apache2::RequestUtil->request; + + # we only want GET or HEAD requests + unless ($r->method eq 'HEAD' or $r->method eq 'GET') { + return Apache2::Const::DECLINED(); + } + $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar"; + + my $uri = $r->uri(); + # subtract out location + my $location = $r->location(); + my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/; + if (not length $email) { + return Apache2::Const::NOT_FOUND(); + } + my $q = CGI::Simple->new(); + my %param = cgi_parameters(query => $q, + single => [qw(avatar)], + default => {avatar => 'yes', + }, + ); + if ($param{avatar} ne 'yes' or not defined $email or not length $email) { + serve_cache_mod_perl('',$r); + return Apache2::Const::DECLINED(); + } + # figure out what the md5sum of the e-mail is. + my ($cache_location, $timestamp) = cache_location(email => $email); + # if we've got it, and it's less than one hour old, return it. + if ($timestamp) { + serve_cache_mod_perl($cache_location,$r); + return Apache2::Const::DECLINED(); + } + ($cache_location,$timestamp) = + retrieve_libravatar(location => $cache_location, + email => $email, + ); + if (not defined $cache_location) { + # failure, serve the default image + serve_cache_mod_perl('',$r,$timestamp); + return Apache2::Const::DECLINED(); + } else { + serve_cache_mod_perl($cache_location,$r,$timestamp); + return Apache2::Const::DECLINED(); + } +} + + + +sub serve_cache_mod_perl { + my ($cache_location,$r,$timestamp) = @_; + if (not defined $cache_location or not length $cache_location) { + # serve the default image + $cache_location = $config{libravatar_default_image}; + } + $magic = File::LibMagic->new() if not defined $magic; + + return Apache2::Const::DECLINED() if not defined $magic; + + $r->content_type($magic->checktype_filename(abs_path($cache_location))); + + $r->filename($cache_location); + $r->path_info(''); + $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool)); +} + +=back + +=cut + +1; + + +__END__