From 088b6d61b5ce934302779d7aec5c4376b4e2a956 Mon Sep 17 00:00:00 2001 From: Don Armstrong Date: Fri, 7 Jun 2013 21:22:39 -0700 Subject: [PATCH] add code to serve images via mod_perl --- Debbugs/Libravatar.pm | 216 ++++++++++++++++++++++++++++++++---------- 1 file changed, 167 insertions(+), 49 deletions(-) diff --git a/Debbugs/Libravatar.pm b/Debbugs/Libravatar.pm index dd1233d..27a879f 100644 --- a/Debbugs/Libravatar.pm +++ b/Debbugs/Libravatar.pm @@ -33,6 +33,15 @@ use strict; use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use base qw(Exporter); +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 LWP::UserAgent; +use File::Temp qw(tempfile); + BEGIN{ ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; $DEBUG = 0 unless defined $DEBUG; @@ -80,66 +89,98 @@ sub retreive_libravatar{ my %param = @_; my $cache_location = $param{location}; $cache_location =~ s/\.[^\.]+$//; - 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); - my $r = $ua->get($uri); - if (not $r->is_success()) { + # 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 = cache_location(email => $param{email}); + if (cache_valid($temp_location)) { + return $temp_location; + } } - 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. - return undef 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 - return undef if not defined $type; - return undef if not $type =~ m{^image/([^/]+)$}; - my $dest_type = $type_mapping{$1}; - return undef if not defined $dest_type; - # undo any content encoding - $r->decode() or return undef; - # 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 - return undef; + my $dest_type; eval { - print {$temp_fh} $r->content() or - die "Unable to print to temp file"; - close ($temp_fh); - ### 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_fh); + 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); + my $r = $ua->get($uri); + if (not $r->is_success()) { + die "Not successful in request"; + } + 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 + die "No content type" if not 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); + ### 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_fh); + }; + 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 ($@) { - unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type; - unlink($temp_fn) if -e $temp_fn; + # there was some kind of error; return undef and unlock the + # lock + simple_unlockfile($fh,$lockfile); return undef; } + simple_unlockfile($fh,$lockfile); return $cache_location.'.'.$dest_type; } sub cache_location { - my ($md5sum) = @_; + my %param = @_; + my $md5sum; + 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"); + } for my $ext (qw(.png .jpg)) { if (-e $config{libravatar_cache_dir}.'/'.$md5sum.$ext) { return $config{libravatar_cache_dir}.'/'.$md5sum.$ext; @@ -148,6 +189,83 @@ sub cache_location { return $config{libravatar_cache_dir}.'/'.$md5sum; } +## 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 = cache_location(email => $email); + # if we've got it, and it's less than one hour old, return it. + if (cache_valid($cache_location)) { + serve_cache_mod_perl($cache_location,$r); + return Apache2::Const::DECLINED(); + } + $cache_location = retreive_libravatar(location => $cache_location, + email => $email, + ); + if (not defined $cache_location) { + # failure, serve the default image + serve_cache_mod_perl('',$r); + return Apache2::Const::DECLINED(); + } else { + serve_cache_mod_perl($cache_location,$r); + return Apache2::Const::DECLINED(); + } +} + + +sub serve_cache_mod_perl { + my ($cache_location,$r) = @_; + if (not defined $cache_location or not length $cache_location) { + # serve the default image + $cache_location = $config{libravatar_default_image}; + } + $r->filename($cache_location); + $r->path_info(''); + $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM, $r->pool)); +} 1; -- 2.39.2