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 =over
  62
  63 =item retrieve_libravatar
  64
  65      $cache_location = retrieve_libravatar(location => $cache_location,
  66                                            email => lc($param{email}),
  67                                           );
  68
  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.
  71
  72
  73 =cut
  74
  75 sub retrieve_libravatar{
  76     my %type_mapping =
  77         (jpeg => 'jpg',
  78          png => 'png',
  79          gif => 'png',
  80          tiff => 'png',
  81          tif => 'png',
  82          pjpeg => 'jpg',
  83          jpg => 'jpg'
  84         );
  85     my %param = @_;
  86     my $cache_location = $param{location};
  87     my $timestamp;
  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);
  93     if (not $fh) {
  94         return undef;
  95     } else {
  96         # figure out if the cache is now valid; if it is, return the
  97         # cache location
  98         my $temp_location;
  99         ($temp_location, $timestamp) = cache_location(email => $param{email});
 100         if ($timestamp) {
 101             return ($temp_location,$timestamp);
 102         }
 103     }
 104     require LWP::UserAgent;
 105
 106     my $dest_type;
 107     eval {
 108         my $uri = libravatar_url(email => $param{email},
 109                                  default => 404,
 110                                  size => 80);
 111         my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
 112                                     );
 113         $ua->from($config{maintainer});
 114         # if we don't get an avatar within 10 seconds, return so we
 115         # don't block forever
 116         $ua->timeout(10);
 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";
 123             }
 124             # No avatar - cache a negative result
 125             if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) {
 126                 $dest_type = $1;
 127
 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 {}
 131                 return;
 132             }
 133         }
 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";
 152         eval {
 153             print {$temp_fh} $r->content() or
 154                 die "Unable to print to temp file";
 155             close ($temp_fh);
 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',
 163                    '-strip',
 164                    $temp_fn,
 165                    $cache_location.'.'.$dest_type) == 0 or
 166                        die "convert file failed";
 167             unlink($temp_fn);
 168         };
 169         if ($@) {
 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";
 173         }
 174     };
 175     if ($@) {
 176         # there was some kind of error; return undef and unlock the
 177         # lock
 178         simple_unlockfile($fh,$lockfile);
 179         return undef;
 180     }
 181     simple_unlockfile($fh,$lockfile);
 182     $timestamp = (stat($cache_location.'.'.$dest_type))[9];
 183     return ($cache_location.'.'.$dest_type,$timestamp);
 184 }
 185
 186 sub blocked_libravatar {
 187     my ($email,$md5sum) = @_;
 188     my $blocked = 0;
 189     for my $blocker (@{$config{libravatar_blacklist}||[]}) {
 190         for my $element ($email,$md5sum) {
 191             next unless defined $element;
 192             eval {
 193                 if ($element =~ /$blocker/) {
 194                     $blocked=1;
 195                 }
 196             };
 197         }
 198     }
 199     return $blocked;
 200 }
 201
 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
 205 #   be re-fetched.
 206 sub cache_location {
 207     my %param = @_;
 208     my ($md5sum, $stem);
 209     if (exists $param{md5sum}) {
 210         $md5sum = $param{md5sum};
 211     }elsif (exists $param{email}) {
 212         $md5sum = md5_hex(lc($param{email}));
 213     } else {
 214         croak("cache_location must be called with one of md5sum or email");
 215     }
 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;
 220         if (-e $path) {
 221             my $timestamp = (time - (stat(_))[9] < 60*60) ? (stat(_))[9] : 0;
 222             return ($path, $timestamp);
 223         }
 224     }
 225     return ($stem, 0);
 226 }
 227
 228 ## the following is mod_perl specific
 229
 230 BEGIN{
 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;
 237             require APR::Finfo;
 238             require APR::Const;
 239             APR::Const->import(-compile => qw(FINFO_NORM));
 240             Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED));
 241         } else {
 242             die "Unsupported mod perl api; mod_perl 2.0.0 or later is required";
 243         }
 244     }
 245 }
 246
 247 sub handler {
 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;
 250
 251     # we only want GET or HEAD requests
 252     unless ($r->method eq 'HEAD' or $r->method eq 'GET') {
 253         return Apache2::Const::DECLINED();
 254     }
 255     $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar";
 256
 257     my $uri = $r->uri();
 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();
 263     }
 264     my $q = CGI::Simple->new();
 265     my %param = cgi_parameters(query => $q,
 266                                single => [qw(avatar)],
 267                                default => {avatar => 'yes',
 268                                           },
 269                               );
 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();
 273     }
 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.
 277     if ($timestamp) {
 278         serve_cache_mod_perl($cache_location,$r);
 279         return Apache2::Const::DECLINED();
 280     }
 281     ($cache_location,$timestamp) =
 282         retrieve_libravatar(location => $cache_location,
 283                             email => $email,
 284                            );
 285     if (not defined $cache_location) {
 286         # failure, serve the default image
 287         serve_cache_mod_perl('',$r,$timestamp);
 288         return Apache2::Const::DECLINED();
 289     } else {
 290         serve_cache_mod_perl($cache_location,$r,$timestamp);
 291         return Apache2::Const::DECLINED();
 292     }
 293 }
 294
 295
 296
 297 our $magic;
 298
 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};
 304     }
 305     $magic = File::LibMagic->new() if not defined $magic;
 306
 307     return Apache2::Const::DECLINED() if not defined $magic;
 308
 309     $r->content_type($magic->checktype_filename(abs_path($cache_location)));
 310
 311     $r->filename($cache_location);
 312     $r->path_info('');
 313     $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool));
 314 }
 315
 316 =back
 317
 318 =cut
 319
 320 1;
 321
 322
 323 __END__