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 File::LibMagic;
  10 use Debbugs::Libravatar qw(:libravatar);
  11
  12 use Libravatar::URL;
  13
  14 use CGI::Simple;
  15 use Cwd qw(abs_path);
  16
  17 my $q = CGI::Simple->new();
  18
  19 my %param =
  20     cgi_parameters(query => $q,
  21                    single => [qw(email avatar default)],
  22                    default => {avatar => 'yes',
  23                                default => $config{libravatar_uri_options},
  24                               },
  25                   );
  26 # if avatar is no, serve the empty png
  27 if ($param{avatar} ne 'yes' or not defined $param{email} or not length $param{email}) {
  28     serve_cache('',$q);
  29     exit 0;
  30 }
  31
  32 my ($cache_location, $is_valid) = cache_location(email => lc($param{email}));
  33 # if we've got it, and it's less than one hour old, return it.
  34 if ($is_valid) {
  35     serve_cache($cache_location,$q);
  36     exit 0;
  37 }
  38 # if we don't have it, get it, and store it in the cache
  39 $cache_location = retrieve_libravatar(location => $cache_location,
  40                                       email => lc($param{email}),
  41                                      );
  42 if (not defined $cache_location) {
  43     # failure, serve the default image
  44     serve_cache('',$q);
  45     exit 0;
  46 } else {
  47     serve_cache($cache_location,$q);
  48     exit 0;
  49 }
  50
  51
  52 sub serve_cache {
  53     my ($cache_location,$q) = @_;
  54     if (not defined $cache_location or not length $cache_location) {
  55         # serve the default image
  56         $cache_location = $config{libravatar_default_image};
  57     }
  58     my $fh = IO::File->new($cache_location,'r') or
  59         error($q,404, "Failed to open cached image $cache_location");
  60     my $m = File::LibMagic->new() or
  61         error($q,500,'Unable to create File::LibMagic object');
  62     my $mime_string = $m->checktype_filename(abs_path($cache_location)) or
  63         error($q,500,'Bad file; no mime known');
  64     print $q->header(-type => $mime_string,
  65                      -expires => '+1d',
  66                     );
  67     print <$fh>;
  68     close($fh);
  69 }
  70
  71
  72 sub error {
  73     my ($q,$error,$text) = @_;
  74     $text //= '';
  75     print $q->header(-status => $error);
  76     print "<h2>$error: $text</h2>";
  77     exit 0;
  78 }