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