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 BEGIN{
  37      ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
  38      $DEBUG = 0 unless defined $DEBUG;
  39
  40      @EXPORT = ();
  41      %EXPORT_TAGS = (libravatar => [qw(cache_valid serve_cache retrieve_libravatar)]
  42                     );
  43      @EXPORT_OK = ();
  44      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  45      $EXPORT_TAGS{all} = [@EXPORT_OK];
  46 }
  47
  48 sub cache_valid{
  49     my ($cache_location) = @_;
  50     if (-e $cache_location) {
  51         if (time - (stat($cache_location))[9] < 60*60) {
  52             return 1;
  53         }
  54     }
  55     return 0;
  56 }
  57
  58 =item retreive_libravatar
  59
  60      $cache_location = retreive_libravatar(location => $cache_location,
  61                                            email => lc($param{email}),
  62                                           );
  63
  64 Returns the cache location where a specific avatar can be loaded. If
  65 there isn't a matching avatar, or there is an error, returns undef.
  66
  67
  68 =cut
  69
  70 sub retreive_libravatar{
  71     my %type_mapping =
  72         (jpeg => 'jpg',
  73          png => 'png',
  74          gif => 'png',
  75          tiff => 'png',
  76          tif => 'png',
  77          pjpeg => 'jpg',
  78          jpg => 'jpg'
  79         );
  80     my %param = @_;
  81     my $cache_location = $param{location};
  82     $cache_location =~ s/\.[^\.]+$//;
  83     my $uri = libravatar_url(email => $param{email},
  84                              default => 404,
  85                              size => 80);
  86     my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
  87                                 );
  88     $ua->from($config{maintainer});
  89     # if we don't get an avatar within 10 seconds, return so we don't
  90     # block forever
  91     $ua->timeout(10);
  92     # if the avatar is bigger than 30K, we don't want it either
  93     $ua->max_size(30*1024);
  94     my $r = $ua->get($uri);
  95     if (not $r->is_success()) {
  96         return undef;
  97     }
  98     my $aborted = $r->header('Client-Aborted');
  99     # if we exceeded max size, I'm not sure if we'll be successfull or
 100     # not, but regardless, there will be a Client-Aborted header. Stop
 101     # here if that header is defined.
 102     return undef if defined $aborted;
 103     my $type = $r->header('Content-Type');
 104     # if there's no content type, or it's not one we like, we won't
 105     # bother going further
 106     return undef if not defined $type;
 107     return undef if not $type =~ m{^image/([^/]+)$};
 108     my $dest_type = $type_mapping{$1};
 109     return undef if not defined $dest_type;
 110     # undo any content encoding
 111     $r->decode() or return undef;
 112     # ok, now we need to convert it from whatever it is into a format
 113     # that we actually like
 114     my ($temp_fh,$temp_fn) = tempfile() or
 115         return undef;
 116     eval {
 117         print {$temp_fh} $r->content() or
 118             die "Unable to print to temp file";
 119         close ($temp_fh);
 120         ### resize all images to 80x80 and strip comments out of them.
 121         ### If convert has a bug, it would be possible for this to be
 122         ### an attack vector, but hopefully minimizing the size above,
 123         ### and requiring proper mime types will minimize that
 124         ### slightly. Doing this will at least make it harder for
 125         ### malicious web images to harm our users
 126         system('convert','-resize','80x80',
 127                '-strip',
 128                $temp_fn,
 129                $cache_location.'.'.$dest_type) == 0 or
 130                    die "convert file failed";
 131         unlink($temp_fh);
 132     };
 133     if ($@) {
 134         unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
 135         unlink($temp_fn) if -e $temp_fn;
 136         return undef;
 137     }
 138     return $cache_location.'.'.$dest_type;
 139 }
 140
 141 sub cache_location {
 142     my ($md5sum) = @_;
 143     for my $ext (qw(.png .jpg)) {
 144         if (-e $config{libravatar_cache_dir}.'/'.$md5sum.$ext) {
 145             return $config{libravatar_cache_dir}.'/'.$md5sum.$ext;
 146         }
 147     }
 148     return $config{libravatar_cache_dir}.'/'.$md5sum;
 149 }
 150
 151
 152
 153 1;
 154
 155
 156 __END__