if ($_ eq 'From' and $param{avatars}) {
my $libravatar_url = __libravatar_url(decode_rfc1522($head_field));
if (defined $libravatar_url and length $libravatar_url) {
- push @headers,q(<img src=").$libravatar_url.qq(" alt="">\n);
+ push @headers,q(<img src="http://).$libravatar_url.qq(" alt="">\n);
}
}
push @headers, qq(<div class="header"><span class="headerfield">$_:</span> ) . html_escape(decode_rfc1522($head_field))."</div>\n";
return undef;
}
($email) = get_addresses($email);
- return $config{libravatar_uri}.md5_hex(lc($email)).($config{libravatar_uri_options}//'');
+ return $config{libravatar_uri}.$email.($config{libravatar_uri_options}//'');
}
],
date => [qw(secs_to_english)],
quit => [qw(quit)],
- lock => [qw(filelock unfilelock lockpid)],
+ lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
);
@EXPORT_OK = ();
Exporter::export_ok_tags(keys %EXPORT_TAGS);
use Mail::Address;
use Cwd qw(cwd);
use Storable qw(dclone);
+use Time::HiRes qw(usleep);
use Params::Validate qw(validate_with :types);
confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
}
}
- my ($count,$errors);
- $count= 10; $errors= '';
- for (;;) {
- my $fh = eval {
+ my ($fh,$t_lockfile,$errors) =
+ simple_filelock($lockfile,10,1);
+ if ($fh) {
+ push @filelocks, {fh => $fh, file => $lockfile};
+ if (defined $locks) {
+ $locks->{locks}{$lockfile}++;
+ push @{$locks->{lockorder}},$lockfile;
+ }
+ } else {
+ use Data::Dumper;
+ croak "failed to get lock on $lockfile -- $errors".
+ (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
+ }
+}
+
+=head2 simple_filelock
+
+ my ($fh,$t_lockfile,$errors) =
+ simple_filelock($lockfile,$count,$wait);
+
+Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
+Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
+seconds in between.
+
+In list context, returns the lockfile filehandle, lockfile name, and
+any errors which occured.
+
+When the lockfile filehandle is undef, locking failed.
+
+These lockfiles must be unlocked manually at process end.
+
+
+=cut
+
+sub simple_filelock {
+ my ($lockfile,$count,$wait) = @_;
+ if (not defined $count) {
+ $count = 10;
+ }
+ if ($count < 0) {
+ $count = 0;
+ }
+ if (not defined $wait) {
+ $wait = 1;
+ }
+ my $errors= '';
+ my $fh;
+ while (1) {
+ $fh = eval {
my $fh2 = IO::File->new($lockfile,'w')
or die "Unable to open $lockfile for writing: $!";
- flock($fh2,LOCK_EX|LOCK_NB)
+ # Do a blocking lock if count is zero
+ flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
or die "Unable to lock $lockfile $!";
return $fh2;
};
if ($@) {
$errors .= $@;
}
- if ($fh) {
- push @filelocks, {fh => $fh, file => $lockfile};
- if (defined $locks) {
- $locks->{locks}{$lockfile}++;
- push @{$locks->{lockorder}},$lockfile;
- }
- last;
- }
- if (--$count <=0) {
- $errors =~ s/\n+$//;
- use Data::Dumper;
- croak "failed to get lock on $lockfile -- $errors".
- (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
+ if ($fh) {
+ last;
}
-# sleep 10;
+ # use usleep for fractional wait seconds
+ usleep($wait * 1_000_000);
+ } continue {
+ last unless (--$count > 0);
+ }
+ if ($fh) {
+ return wantarray?($fh,$lockfile,$errors):$fh
}
+ return wantarray?(undef,$lockfile,$errors):undef;
}
# clean up all outstanding locks at end time
}
}
+=head2 simple_unlockfile
+
+ simple_unlockfile($fh,$lockfile);
+
+
+=cut
+
+sub simple_unlockfile {
+ my ($fh,$lockfile) = @_;
+ flock($fh,LOCK_UN)
+ or warn "Unable to unlock lockfile $lockfile: $!";
+ close($fh)
+ or warn "Unable to close lockfile $lockfile: $!";
+ unlink($lockfile)
+ or warn "Unable to unlink lockfile $lockfile: $!";
+}
+
=head2 unfilelock
delete $locks->{locks}{$lockfile};
}
my %fl = %{pop(@filelocks)};
- flock($fl{fh},LOCK_UN)
- or warn "Unable to unlock lockfile $fl{file}: $!";
- close($fl{fh})
- or warn "Unable to close lockfile $fl{file}: $!";
- unlink($fl{file})
- or warn "Unable to unlink lockfile $fl{file}: $!";
+ simple_unlockfile($fl{fh},$fl{file});
}
],
text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote),
],
- cgi => [qw($gLibravatarUri $gLibravatarUriOptions)],
+ cgi => [qw($gLibravatarUri $gLibravatarUriOptions @gLibravatarBlacklist)],
config => [qw(%config)],
);
@EXPORT_OK = ();
set_default(\%config,'bug_subscription_domain',$config{list_domain});
-=head2 CGI Options
-
-=over
-
-=item libravatar_uri $gLibravatarUri
-
-URI to a libravatar configuration. If empty or undefined, libravatar
-support will be disabled. Defaults to
-http://cdn.libravatar.org/avatar/ which uses a federated Avatar system
-and falls back to gravatar if necessary.
-
-=cut
-
-set_default(\%config,'libravatar_uri',"http://cdn.libravatar.org/avatar/");
-
-=item libravatar_uri_options $gLibravatarUriOptions
-
-Options to append to the md5_hex of the e-mail. This sets the default
-avatar used when an avatar isn't available. Currently defaults to
-'?d=retro', which causes a bitmap-looking avatar to be displayed for
-unknown e-mails.
-
-Other options which make sense include ?d=404, ?d=wavatar, etc. See
-the API of libravatar for details.
-
-=cut
-
-set_default(\%config,'libravatar_uri_options','?d=retro');
-
-
-=back
=head2 Misc Options
set_default(\%config,'usertag_dir',$config{spool_dir}.'/user');
set_default(\%config,'incoming_dir','incoming');
+
+=item web_dir $gWebDir
+
+Directory where base html files are kept. Should normally be the same
+as the web server's document root.
+
+Default: /var/lib/debbugs/www
+
+=cut
+
set_default(\%config,'web_dir','/var/lib/debbugs/www');
set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt');
set_default(\%config,'lib_path','/usr/lib/debbugs');
=back
+=head2 CGI Options
+
+=over
+
+=item libravatar_uri $gLibravatarUri
+
+URI to a libravatar configuration. If empty or undefined, libravatar
+support will be disabled. Defaults to
+libravatar.cgi, our internal federated libravatar system.
+
+=cut
+
+set_default(\%config,'libravatar_uri',$config{cgi_domain}.'/libravatar.cgi?email=');
+
+=item libravatar_uri_options $gLibravatarUriOptions
+
+Options to append to the md5_hex of the e-mail. This sets the default
+avatar used when an avatar isn't available. Currently defaults to
+'?d=retro', which causes a bitmap-looking avatar to be displayed for
+unknown e-mails.
+
+Other options which make sense include ?d=404, ?d=wavatar, etc. See
+the API of libravatar for details.
+
+=cut
+
+set_default(\%config,'libravatar_uri_options','');
+
+=item libravatar_default_image
+
+Default image to serve for libravatar if there is no avatar for an
+e-mail address. By default, this is a 1x1 png. [This will also be the
+image served if someone specifies avatar=no.]
+
+Default: $config{web_dir}/1x1.png
+
+=cut
+
+set_default(\%config,'libravatar_default_image',$config{web_dir}.'/1x1.png');
+
+=item libravatar_cache_dir
+
+Directory where cached libravatar images are stored
+
+Default: $config{web_dir}/libravatar/
+
+=cut
+
+set_default(\%config,'libravatar_cache_dir',$config{web_dir}.'/libravatar/');
+
+=item libravatar_blacklist
+
+Array of regular expressions to match against emails, domains, or
+images to only show the default image
+
+Default: empty array
+
+=cut
+
+set_default(\%config,'libravatar_blacklist',[]);
+
+=back
=head2 Text Fields
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version. See the
+# file README and COPYING for more information.
+# Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Libravatar;
+
+=head1 NAME
+
+Debbugs::Libravatar -- Libravatar service handler (mod_perl)
+
+=head1 SYNOPSIS
+
+<Location /libravatar>
+ SetHandler perl-script
+ PerlResponseHandler Debbugs::Libravatar
+</Location>
+
+=head1 DESCRIPTION
+
+Debbugs::Libravatar is a libravatar service handler which will serve
+libravatar requests. It also contains utility routines which are used
+by the libravatar.cgi script for those who do not have mod_perl.
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+use warnings;
+use strict;
+use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
+use base qw(Exporter);
+
+use Debbugs::Config qw(:config);
+use Debbugs::Common qw(:lock);
+use Libravatar::URL;
+use CGI::Simple;
+use Debbugs::CGI qw(cgi_parameters);
+use Digest::MD5 qw(md5_hex);
+use LWP::UserAgent;
+use File::Temp qw(tempfile);
+
+use Carp;
+
+BEGIN{
+ ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (libravatar => [qw(cache_valid serve_cache retrieve_libravatar cache_location)]
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+sub cache_valid{
+ my ($cache_location) = @_;
+ if (-e $cache_location) {
+ if (time - (stat($cache_location))[9] < 60*60) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+=over
+
+=item retrieve_libravatar
+
+ $cache_location = retrieve_libravatar(location => $cache_location,
+ email => lc($param{email}),
+ );
+
+Returns the cache location where a specific avatar can be loaded. If
+there isn't a matching avatar, or there is an error, returns undef.
+
+
+=cut
+
+sub retrieve_libravatar{
+ my %type_mapping =
+ (jpeg => 'jpg',
+ png => 'png',
+ gif => 'png',
+ tiff => 'png',
+ tif => 'png',
+ pjpeg => 'jpg',
+ jpg => 'jpg'
+ );
+ my %param = @_;
+ my $cache_location = $param{location};
+ $cache_location =~ s/\.[^\.]+$//;
+ # take out a lock on the cache location so that if another request
+ # is made while we are serving this one, we don't do double work
+ my ($fh,$lockfile,$errors) =
+ simple_filelock($cache_location.'.lock',20,0.5);
+ if (not $fh) {
+ return undef;
+ } else {
+ # figure out if the cache is now valid; if it is, return the
+ # cache location
+ my $temp_location = cache_location(email => $param{email});
+ if (cache_valid($temp_location)) {
+ return $temp_location;
+ }
+ }
+ my $dest_type;
+ eval {
+ my $uri = libravatar_url(email => $param{email},
+ default => 404,
+ size => 80);
+ my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)',
+ );
+ $ua->from($config{maintainer});
+ # if we don't get an avatar within 10 seconds, return so we
+ # don't block forever
+ $ua->timeout(10);
+ # if the avatar is bigger than 30K, we don't want it either
+ $ua->max_size(30*1024);
+ my $r = $ua->get($uri);
+ if (not $r->is_success()) {
+ die "Not successful in request";
+ }
+ my $aborted = $r->header('Client-Aborted');
+ # if we exceeded max size, I'm not sure if we'll be
+ # successfull or not, but regardless, there will be a
+ # Client-Aborted header. Stop here if that header is defined.
+ die "Client aborted header" if defined $aborted;
+ my $type = $r->header('Content-Type');
+ # if there's no content type, or it's not one we like, we won't
+ # bother going further
+ die "No content type" if not defined $type;
+ die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
+ $dest_type = $type_mapping{$1};
+ die "No dest type" if not defined $dest_type;
+ # undo any content encoding
+ $r->decode() or die "Unable to decode content encoding";
+ # ok, now we need to convert it from whatever it is into a
+ # format that we actually like
+ my ($temp_fh,$temp_fn) = tempfile() or
+ die "Unable to create temporary file";
+ eval {
+ print {$temp_fh} $r->content() or
+ die "Unable to print to temp file";
+ close ($temp_fh);
+ ### resize all images to 80x80 and strip comments out of
+ ### them. If convert has a bug, it would be possible for
+ ### this to be an attack vector, but hopefully minimizing
+ ### the size above, and requiring proper mime types will
+ ### minimize that slightly. Doing this will at least make
+ ### it harder for malicious web images to harm our users
+ system('convert','-resize','80x80',
+ '-strip',
+ $temp_fn,
+ $cache_location.'.'.$dest_type) == 0 or
+ die "convert file failed";
+ unlink($temp_fh);
+ };
+ if ($@) {
+ unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type;
+ unlink($temp_fn) if -e $temp_fn;
+ die "Unable to convert image";
+ }
+ };
+ if ($@) {
+ # there was some kind of error; return undef and unlock the
+ # lock
+ simple_unlockfile($fh,$lockfile);
+ return undef;
+ }
+ simple_unlockfile($fh,$lockfile);
+ return $cache_location.'.'.$dest_type;
+}
+
+sub blocked_libravatar {
+ my ($email,$md5sum) = @_;
+ my $blocked = 0;
+ for my $blocker (@{$config{libravatar_blacklist}||[]}) {
+ for my $element ($email,$md5sum) {
+ next unless defined $element;
+ eval {
+ if ($element =~ /$blocker/) {
+ $blocked=1;
+ }
+ };
+ }
+ }
+ return $blocked;
+}
+
+sub cache_location {
+ my %param = @_;
+ my $md5sum;
+ if (exists $param{md5sum}) {
+ $md5sum = $param{md5sum};
+ }elsif (exists $param{email}) {
+ $md5sum = md5_hex(lc($param{email}));
+ } else {
+ croak("cache_location must be called with one of md5sum or email");
+ }
+ return undef if blocked_libravatar($param{email},$md5sum);
+ for my $ext (qw(.png .jpg)) {
+ if (-e $config{libravatar_cache_dir}.'/'.$md5sum.$ext) {
+ return $config{libravatar_cache_dir}.'/'.$md5sum.$ext;
+ }
+ }
+ return $config{libravatar_cache_dir}.'/'.$md5sum;
+}
+
+## the following is mod_perl specific
+
+BEGIN{
+ if (exists $ENV{MOD_PERL_API_VERSION}) {
+ if ($ENV{MOD_PERL_API_VERSION} == 2) {
+ require Apache2::RequestIO;
+ require Apache2::RequestRec;
+ require Apache2::RequestUtil;
+ require Apache2::Const;
+ require APR::Finfo;
+ require APR::Const;
+ APR::Const->import(-compile => qw(FINFO_NORM));
+ Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED));
+ } else {
+ die "Unsupported mod perl api; mod_perl 2.0.0 or later is required";
+ }
+ }
+}
+
+sub handler {
+ die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION};
+ my $r = shift or Apache2::RequestUtil->request;
+
+ # we only want GET or HEAD requests
+ unless ($r->method eq 'HEAD' or $r->method eq 'GET') {
+ return Apache2::Const::DECLINED();
+ }
+ $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar";
+
+ my $uri = $r->uri();
+ # subtract out location
+ my $location = $r->location();
+ my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/;
+ if (not length $email) {
+ return Apache2::Const::NOT_FOUND();
+ }
+ my $q = CGI::Simple->new();
+ my %param = cgi_parameters(query => $q,
+ single => [qw(avatar)],
+ default => {avatar => 'yes',
+ },
+ );
+ if ($param{avatar} ne 'yes' or not defined $email or not length $email) {
+ serve_cache_mod_perl('',$r);
+ return Apache2::Const::DECLINED();
+ }
+ # figure out what the md5sum of the e-mail is.
+ my $cache_location = cache_location(email => $email);
+ # if we've got it, and it's less than one hour old, return it.
+ if (cache_valid($cache_location)) {
+ serve_cache_mod_perl($cache_location,$r);
+ return Apache2::Const::DECLINED();
+ }
+ $cache_location = retreive_libravatar(location => $cache_location,
+ email => $email,
+ );
+ if (not defined $cache_location) {
+ # failure, serve the default image
+ serve_cache_mod_perl('',$r);
+ return Apache2::Const::DECLINED();
+ } else {
+ serve_cache_mod_perl($cache_location,$r);
+ return Apache2::Const::DECLINED();
+ }
+}
+
+
+sub serve_cache_mod_perl {
+ my ($cache_location,$r) = @_;
+ if (not defined $cache_location or not length $cache_location) {
+ # serve the default image
+ $cache_location = $config{libravatar_default_image};
+ }
+ $r->filename($cache_location);
+ $r->path_info('');
+ $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool));
+}
+
+=back
+
+=cut
+
+1;
+
+
+__END__
--- /dev/null
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Debbugs::Config qw(:config);
+use Debbugs::CGI qw(cgi_parameters);
+use Debbugs::Common;
+use Digest::MD5 qw(md5_hex);
+use File::LibMagic;
+use File::Temp qw(tempfile);
+use Debbugs::Libravatar qw(:libravatar);
+
+use Libravatar::URL;
+
+use LWP::UserAgent;
+use HTTP::Request;
+
+use CGI::Simple;
+use Cwd qw(abs_path);
+
+my $q = CGI::Simple->new();
+
+my %param =
+ cgi_parameters(query => $q,
+ single => [qw(email avatar default)],
+ default => {avatar => 'yes',
+ default => $config{libravatar_uri_options},
+ },
+ );
+# if avatar is no, serve the empty png
+if ($param{avatar} ne 'yes' or not defined $param{email} or not length $param{email}) {
+ serve_cache('',$q);
+ exit 0;
+}
+
+# figure out what the md5sum of the e-mail is.
+my $email_md5sum = md5_hex(lc($param{email}));
+my $cache_location = cache_location(email => lc($param{email}));
+# if we've got it, and it's less than one hour old, return it.
+if (cache_valid($cache_location)) {
+ serve_cache($cache_location,$q);
+ exit 0;
+}
+# if we don't have it, get it, and store it in the cache
+$cache_location = retrieve_libravatar(location => $cache_location,
+ email => lc($param{email}),
+ );
+if (not defined $cache_location) {
+ # failure, serve the default image
+ serve_cache('',$q);
+ exit 0;
+} else {
+ serve_cache($cache_location,$q);
+ exit 0;
+}
+
+
+sub serve_cache {
+ my ($cache_location,$q) = @_;
+ if (not defined $cache_location or not length $cache_location) {
+ # serve the default image
+ $cache_location = $config{libravatar_default_image};
+ }
+ my $fh = IO::File->new($cache_location,'r') or
+ error($q,404, "Failed to open cached image $cache_location");
+ my $m = File::LibMagic->new() or
+ error($q,500,'Unable to create File::LibMagic object');
+ my $mime_string = $m->checktype_filename(abs_path($cache_location)) or
+ error($q,500,'Bad file; no mime known');
+ print $q->header(-type => $mime_string,
+ -expires => '+1d',
+ );
+ print <$fh>;
+ close($fh);
+}
+
+
+sub error {
+ my ($q,$error,$text) = @_;
+ $text //= '';
+ print $q->header(-status => $error);
+ print "<h2>$error: $text</h2>";
+ exit 0;
+}
libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl,
libcgi-simple-perl, libparams-validate-perl, libtext-template-perl,
libsafe-hole-perl, libmail-rfc822-address-perl, liblist-moreutils-perl,
+ libtext-template-perl,
+# used by Debbugs::Libravatar and libravatar.cgi
+ libfile-libmagic-perl, libgravatar-url-perl, libwww-perl
Section: perl
Description: modules used by the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
Depends:
${misc:Depends},
libdebbugs-perl, apache | httpd
-Suggests: libcgi-alert-perl
+Suggests: libcgi-alert-perl, libapache2-mod-perl2
Description: web scripts for the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
users and developers. Each bug is given a number, and is kept on file until
projects / debbugs.git / commitdiff
