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 base qw(Exporter);
  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 LWP::UserAgent;
  43 use File::Temp qw(tempfile);
  44
  45 use Carp;
  46
  47 BEGIN{
  48      ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
  49      $DEBUG = 0 unless defined $DEBUG;
  50
  51      @EXPORT = ();
  52      %EXPORT_TAGS = (libravatar => [qw(cache_valid serve_cache retrieve_libravatar cache_location)]
  53                     );
  54      @EXPORT_OK = ();
  55      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  56      $EXPORT_TAGS{all} = [@EXPORT_OK];
  57 }
  58
  59 sub cache_valid{
  60     my ($cache_location) = @_;
  61     if (-e $cache_location) {
  62         if (time - (stat($cache_location))[9] < 60*60) {
  63             return 1;
  64         }
  65     }
  66     return 0;
  67 }
  68
  69 =item retreive_libravatar
  70
  71      $cache_location = retreive_libravatar(location => $cache_location,
  72                                            email => lc($param{email}),
  73                                           );
  74
  75 Returns the cache location where a specific avatar can be loaded. If
  76 there isn't a matching avatar, or there is an error, returns undef.
  77
  78
  79 =cut
  80
  81 sub retreive_libravatar{
  82     my %type_mapping =
  83         (jpeg => 'jpg',
  84          png => 'png',
  85          gif => 'png',
  86          tiff => 'png',
  87          tif => 'png',
  88          pjpeg => 'jpg',
  89          jpg => 'jpg'
  90         );
  91     my %param = @_;
  92     my $cache_location = $param{location};
  93     $cache_location =~ s/\.[^\.]+$//;
  94     # take out a lock on the cache location so that if another request
  95     # is made while we are serving this one, we don't do double work
  96     my ($fh,$lockfile,$errors) =
  97         simple_filelock($cache_location.'.lock',20,0.5);
  98     if (not $fh) {
  99         return undef;
 100     } else {
 101         # figure out if the cache is now valid; if it is, return the
 102         # cache location
 103         my $temp_location = cache_location(email => $param{email});
 104         if (cache_valid($temp_location)) {
 105             return $temp_location;
 106         }
 107     }
 108     my $dest_type;
 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         my $r = $ua->get($uri);
 122         if (not $r->is_success()) {
 123             die "Not successful in request";
 124         }
 125         my $aborted = $r->header('Client-Aborted');
 126         # if we exceeded max size, I'm not sure if we'll be
 127         # successfull or not, but regardless, there will be a
 128         # Client-Aborted header. Stop here if that header is defined.
 129         die "Client aborted header" if defined $aborted;
 130         my $type = $r->header('Content-Type');
 131         # if there's no content type, or it's not one we like, we won't
 132         # bother going further
 133         die "No content type" if not defined $type;
 134         die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
 135         $dest_type = $type_mapping{$1};
 136         die "No dest type" if not defined $dest_type;
 137         # undo any content encoding
 138         $r->decode() or die "Unable to decode content encoding";
 139         # ok, now we need to convert it from whatever it is into a
 140         # format that we actually like
 141         my ($temp_fh,$temp_fn) = tempfile() or
 142             die "Unable to create temporary file";
 143         eval {
 144             print {$temp_fh} $r->content() or
 145                 die "Unable to print to temp file";
 146             close ($temp_fh);
 147             ### resize all images to 80x80 and strip comments out of
 148             ### them. If convert has a bug, it would be possible for
 149             ### this to be an attack vector, but hopefully minimizing
 150             ### the size above, and requiring proper mime types will
 151             ### minimize that slightly. Doing this will at least make
 152             ### it harder for malicious web images to harm our users
 153             system('convert','-resize','80x80',
 154                    '-strip',
 155                    $temp_fn,
 156                    $cache_location.'.'.$dest_type) == 0 or
 157                        die "convert file failed";
 158             unlink($temp_fh);
 159         };
 160         if ($@) {
 161             unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
 162             unlink($temp_fn) if -e $temp_fn;
 163             die "Unable to convert image";
 164         }
 165     };
 166     if ($@) {
 167         # there was some kind of error; return undef and unlock the
 168         # lock
 169         simple_unlockfile($fh,$lockfile);
 170         return undef;
 171     }
 172     simple_unlockfile($fh,$lockfile);
 173     return $cache_location.'.'.$dest_type;
 174 }
 175
 176 sub cache_location {
 177     my %param = @_;
 178     my $md5sum;
 179     if (exists $param{md5sum}) {
 180         $md5sum = $param{md5sum};
 181     }elsif (exists $param{email}) {
 182         $md5sum = md5_hex(lc($param{email}));
 183     } else {
 184         croak("cache_location must be called with one of md5sum or email");
 185     }
 186     for my $ext (qw(.png .jpg)) {
 187         if (-e $config{libravatar_cache_dir}.'/'.$md5sum.$ext) {
 188             return $config{libravatar_cache_dir}.'/'.$md5sum.$ext;
 189         }
 190     }
 191     return $config{libravatar_cache_dir}.'/'.$md5sum;
 192 }
 193
 194 ## the following is mod_perl specific
 195
 196 BEGIN{
 197     if (exists $ENV{MOD_PERL_API_VERSION}) {
 198         if ($ENV{MOD_PERL_API_VERSION} == 2) {
 199             require Apache2::RequestIO;
 200             require Apache2::RequestRec;
 201             require Apache2::RequestUtil;
 202             require Apache2::Const;
 203             require APR::Finfo;
 204             require APR::Const;
 205             APR::Const->import(-compile => qw(FINFO_NORM));
 206             Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED));
 207         } else {
 208             die "Unsupported mod perl api; mod_perl 2.0.0 or later is required";
 209         }
 210     }
 211 }
 212
 213 sub handler {
 214     die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION};
 215     my $r = shift or Apache2::RequestUtil->request;
 216
 217     # we only want GET or HEAD requests
 218     unless ($r->method eq 'HEAD' or $r->method eq 'GET') {
 219         return Apache2::Const::DECLINED();
 220     }
 221     $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar";
 222
 223     my $uri = $r->uri();
 224     # subtract out location
 225     my $location = $r->location();
 226     my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/;
 227     if (not length $email) {
 228         return Apache2::Const::NOT_FOUND;
 229     }
 230     my $q = CGI::Simple->new();
 231     my %param = cgi_parameters(query => $q,
 232                                single => [qw(avatar)],
 233                                default => {avatar => 'yes',
 234                                           },
 235                               );
 236     if ($param{avatar} ne 'yes' or not defined $email or not length $email) {
 237         serve_cache_mod_perl('',$r);
 238         return Apache2::Const::DECLINED();
 239     }
 240     # figure out what the md5sum of the e-mail is.
 241     my $cache_location = cache_location(email => $email);
 242     # if we've got it, and it's less than one hour old, return it.
 243     if (cache_valid($cache_location)) {
 244         serve_cache_mod_perl($cache_location,$r);
 245         return Apache2::Const::DECLINED();
 246     }
 247     $cache_location = retreive_libravatar(location => $cache_location,
 248                                           email => $email,
 249                                          );
 250     if (not defined $cache_location) {
 251         # failure, serve the default image
 252         serve_cache_mod_perl('',$r);
 253         return Apache2::Const::DECLINED();
 254     } else {
 255         serve_cache_mod_perl($cache_location,$r);
 256         return Apache2::Const::DECLINED();
 257     }
 258 }
 259
 260
 261 sub serve_cache_mod_perl {
 262     my ($cache_location,$r) = @_;
 263     if (not defined $cache_location or not length $cache_location) {
 264         # serve the default image
 265         $cache_location = $config{libravatar_default_image};
 266     }
 267     $r->filename($cache_location);
 268     $r->path_info('');
 269     $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM, $r->pool));
 270 }
 271
 272
 273 1;
 274
 275
 276 __END__