cgi/libravatar.cgi

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use Debbugs::Config qw(:config);
   7 use Debbugs::CGI qw(cgi_parameters);
   8 use Debbugs::Common;
   9 use Digest::MD5 qw(md5_hex);
  10 use File::LibMagic;
  11 use File::Temp qw(tempfile);
  12
  13 use Libravatar::URL;
  14
  15 use LWP::UserAgent;
  16 use HTTP::Request;
  17
  18 use CGI::Simple;
  19
  20 my $q = CGI::Simple->new();
  21
  22 my %param =
  23     cgi_parameters(query => $q,
  24                    single => [qw(email avatar default)],
  25                    default => {avatar => 'yes',
  26                                default => $config{libravatar_uri_options},
  27                               },
  28                   );
  29 # if avatar is no, serve the empty png
  30 if ($param{avatar} ne 'yes' or not defined $param{email} or not length $param{email}) {
  31     serve_cache('',$q);
  32     exit 0;
  33 }
  34
  35 # figure out what the md5sum of the e-mail is.
  36 my $email_md5sum = md5_hex(lc($param{email}));
  37 my $cache_location = cache_location($email_md5sum);
  38 # if we've got it, and it's less than one hour old, return it.
  39 if (cache_valid($cache_location)) {
  40     serve_cache($cache_location,$q);
  41     exit 0;
  42 }
  43 # if we don't have it, get it, and store it in the cache
  44 $cache_location = retreive_libravatar(location => $cache_location,
  45                                       email => lc($param{email}),
  46                                      );
  47 if (not defined $cache_location) {
  48     # failure, serve the default image
  49     serve_cache('',$q);
  50     exit 0;
  51 } else {
  52     serve_cache($cache_location,$q);
  53     exit 0;
  54 }
  55
  56
  57 sub serve_cache {
  58     my ($cache_location,$q) = @_;
  59     if (not defined $cache_location or not length $cache_location) {
  60         # serve the default image
  61         $cache_location = $config{libravatar_default_image};
  62     }
  63     my $fh = IO::File->new($cache_location,'r') or
  64         error(404, "Failed to open cached image $cache_location");
  65     my $m = File::LibMagic->new() or
  66         error(500,'Unable to create File::LibMagic object');
  67     my $mime_string = $m->checktype_filename($cache_location) or
  68         error(500,'Bad file; no mime known');
  69     print $q->header(-type => $mime_string,
  70                      -expires => '+1d',
  71                     );
  72     print STDOUT <$fh>;
  73     close($fh);
  74 }
  75
  76
  77 sub error {
  78     my ($error,$text) = @_;
  79     $text //= '';
  80     print $q->header(-status => $error);
  81     print "<h2>$error: $text</h2>";
  82     exit 0;
  83 }