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>.
6 package Debbugs::Libravatar;
10 Debbugs::Libravatar -- Libravatar service handler (mod_perl)
14 <Location /libravatar>
15 SetHandler perl-script
16 PerlResponseHandler Debbugs::Libravatar
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.
33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
34 use base qw(Exporter);
37 ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
38 $DEBUG = 0 unless defined $DEBUG;
41 %EXPORT_TAGS = (libravatar => [qw(cache_valid serve_cache retrieve_libravatar)]
44 Exporter::export_ok_tags(keys %EXPORT_TAGS);
45 $EXPORT_TAGS{all} = [@EXPORT_OK];
49 my ($cache_location) = @_;
50 if (-e $cache_location) {
51 if (time - (stat($cache_location))[9] < 60*60) {
58 =item retreive_libravatar
60 $cache_location = retreive_libravatar(location => $cache_location,
61 email => lc($param{email}),
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.
70 sub retreive_libravatar{
81 my $cache_location = $param{location};
82 $cache_location =~ s/\.[^\.]+$//;
83 my $uri = libravatar_url(email => $param{email},
86 my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
88 $ua->from($config{maintainer});
89 # if we don't get an avatar within 10 seconds, return so we don't
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()) {
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
117 print {$temp_fh} $r->content() or
118 die "Unable to print to temp file";
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',
129 $cache_location.'.'.$dest_type) == 0 or
130 die "convert file failed";
134 unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
135 unlink($temp_fn) if -e $temp_fn;
138 return $cache_location.'.'.$dest_type;
143 for my $ext (qw(.png .jpg)) {
144 if (-e $config{libravatar_cache_dir}.'/'.$md5sum.$ext) {
145 return $config{libravatar_cache_dir}.'/'.$md5sum.$ext;
148 return $config{libravatar_cache_dir}.'/'.$md5sum;