cgi/libravatar.cgi

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 # if we're running out of git, we want to use the git base directory as the
   7 # first INC directory. If you're not running out of git, don't do that.
   8 use File::Basename qw(dirname);
   9 use Cwd qw(abs_path);
  10 our $debbugs_dir;
  11 BEGIN {
  12     $debbugs_dir =
  13         abs_path(dirname(abs_path(__FILE__)) . '/../');
  14     # clear the taint; we'll assume that the absolute path to __FILE__ is the
  15     # right path if there's a .git directory there
  16     ($debbugs_dir) = $debbugs_dir =~ /([[:print:]]+)/;
  17     if (defined $debbugs_dir and
  18         -d $debbugs_dir . '/.git/') {
  19     } else {
  20         undef $debbugs_dir;
  21     }
  22     # if the first directory in @INC is not an absolute directory, assume that
  23     # someone has overridden us via -I.
  24     if ($INC[0] !~ /^\//) {
  25     }
  26 }
  27 use if defined $debbugs_dir, lib => $debbugs_dir.'/lib/';
  28
  29 use Debbugs::Config qw(:config);
  30 use Debbugs::CGI qw(cgi_parameters);
  31 use Debbugs::Common;
  32 use File::LibMagic;
  33 use Debbugs::Libravatar qw(:libravatar);
  34
  35 use Libravatar::URL;
  36
  37 use CGI::Simple;
  38 use Cwd qw(abs_path);
  39 use Digest::MD5 qw(md5_hex);
  40
  41 my $q = CGI::Simple->new();
  42
  43 my %param =
  44     cgi_parameters(query => $q,
  45                    single => [qw(email avatar default)],
  46                    default => {avatar => 'yes',
  47                                default => $config{libravatar_uri_options},
  48                               },
  49                   );
  50 # if avatar is no, serve the empty png
  51 if ($param{avatar} ne 'yes' or not defined $param{email} or not length $param{email}) {
  52     serve_cache('',$q,0);
  53     exit 0;
  54 }
  55
  56 my ($cache_location, $timestamp) = cache_location(email => lc($param{email}));
  57 # if we've got it, and it's less than one hour old, return it.
  58 if ($timestamp) {
  59     serve_cache($cache_location,$q,$timestamp);
  60     exit 0;
  61 }
  62 # if we don't have it, get it, and store it in the cache
  63 ($cache_location,$timestamp) =
  64     retrieve_libravatar(location => $cache_location,
  65                         email => lc($param{email}),
  66                        );
  67 if (not defined $cache_location) {
  68     # failure, serve the default image
  69     serve_cache('',$q,0);
  70     exit 0;
  71 } else {
  72     serve_cache($cache_location,$q,$timestamp);
  73     exit 0;
  74 }
  75
  76
  77 sub serve_cache {
  78     my ($cache_location,$q,$timestamp) = @_;
  79     if (not defined $cache_location or not length $cache_location) {
  80         # serve the default image
  81         $cache_location = $config{libravatar_default_image};
  82         if (not defined $timestamp or not $timestamp) {
  83             $timestamp = (stat($cache_location))[9];
  84         }
  85     }
  86     if (not defined $timestamp) {
  87         # this probably means that the default image doesn't exist
  88         print $q->header(status => 404);
  89         print "404: Not found\n";
  90         return;
  91     }
  92     my $etag = md5_hex($cache_location.$timestamp);
  93     if (defined $q->http('if-none-match')
  94         and $etag eq $q->http('if-none-match')) {
  95         print $q->header(-status => 304);
  96         print "304: Not modified\n";
  97         return;
  98     }
  99     my $fh = IO::File->new($cache_location,'r') or
 100         error($q,404, "Failed to open cached image $cache_location");
 101     my $m = File::LibMagic->new() or
 102         error($q,500,'Unable to create File::LibMagic object');
 103     my $mime_string = $m->checktype_filename(abs_path($cache_location)) or
 104         error($q,500,'Bad file; no mime known');
 105     print $q->header(-type => $mime_string,
 106                      -expires => '+1d',
 107                      -status => 200,
 108                      -etag => $etag,
 109                     );
 110     print <$fh>;
 111     close($fh);
 112 }
 113
 114
 115 sub error {
 116     my ($q,$error,$text) = @_;
 117     $text //= '';
 118     print $q->header(-status => $error);
 119     print "<h2>$error: $text</h2>";
 120     exit 0;
 121 }