File Coverage

blib/lib/CPAN/InGit/Server.pm

Criterion	Covered	Total	%
statement	119	132	90.1
branch	23	38	60.5
condition	15	39	38.4
subroutine	24	24	100.0
pod	10	10	100.0
total	191	243	78.6

package CPAN::InGit::Server;
our $VERSION = '0.003'; # VERSION
# ABSTRACT: A Mojolicious::Controller that serves the ArchiveTrees from a git repo


use Carp;
use Scalar::Util 'refaddr', 'blessed';
use JSON::PP;
use Time::Piece;
use Log::Any '$log';
use Archive::Tar;
use IO::Compress::Gzip qw( gzip $GzipError );
use CPAN::InGit;
use Mojo::Base 'Mojolicious::Controller';
use v5.36;


sub cpan_repo($c) { $c->stash('cpan_repo') }

sub archive_tree($c) {
   $c->stash->{archive_tree} //= do {
      my $branch_name= $c->branch_name;
      my $cache= $c->branch_cache;
      my $atree= $cache->{$branch_name};
      if ($atree) {
         # check whether branch has updated since cached
         my $current_tree= $c->cpan_repo->lookup_tree($branch_name);
         unless (defined $current_tree and $atree->tree->id eq $current_tree->id) {
            delete $cache->{$branch_name};
            $atree= undef;
         }
      }
      if (!$atree && ($atree= $c->cpan_repo->get_archive_tree($branch_name))) {
         if ($c->branch_head_only && !defined $atree->branch) {
            $c->log->debug("Branch '$branch_name' is not a branch HEAD");
            $atree= undef;
         } else {
            $cache->{$branch_name}= $atree;
         }
      }
      $atree;
   };
}

sub branch_name($c) { $c->stash('branch_name') }

sub branch_cache($c) {
   $c->stash->{branch_cache} //= do {
      warn "no branch_cache, creating temporary";
      $c->_new_cache
   }
}

sub branch_head_only($c) { $c->stash('branch_head_only') }

sub _new_cache {
   # the 'recent_limit' feature was added in 0.20
   state $have_tree_rb_xs= eval 'use Tree::RB::XS 0.20';
   my %hash;
   tie %hash, 'Tree::RB::XS', track_recent => 1, recent_limit => 20
      if $have_tree_rb_xs;
   \%hash;
}


sub mount($class, $base_route, $cpan_repo, %options) {
   my $atree= $options{archive_tree};
   if ($atree) {
      croak "Not an ArchiveTree"
         unless blessed($atree) && $atree->can('get_path');
   } else {
      # Ensure there is a cache if serving all branches
      $options{branch_cache} //= $class->_new_cache;
   }
   $base_route= $base_route->to(namespace => '', controller => $class, cpan_repo => $cpan_repo, %options);
   my $tree_route= $atree? $base_route
      : $base_route->any('/:branch_name');
   $tree_route->get('/modules/02packages.details', [ format => ['txt','txt.gz'] ])
      ->to(action => 'serve_package_details');
   $tree_route->get('/authors/id/*author_path')->to(action => 'serve_author_file');
}


sub check_branch_exists($c) {
   unless ($c->archive_tree) {
      $c->render(text => 'Git branch does not exist', status => 404);
      return undef;
   }
   return 1;
}


sub serve_package_details($c) {
   return undef unless $c->check_branch_exists;
   my $blob= $c->archive_tree->package_details_blob;
   $c->respond_to(
      txt      => sub { $c->render(text => $blob->content) },
      'txt.gz' => sub { $c->render_gzipped($blob->content, '02packages.details.txt.gz') },
   );
}


sub serve_author_file($c) {
   return undef unless $c->check_branch_exists;
   my $path= 'authors/id/'.$c->stash->{author_path};
   # cpanm adds extra '/' when the path name doesn't match the expected A/AU/AUTHOR format
   $path =~ s,//+,/,g;
   my ($basename)= ($path =~ m,([^/]+)\z,);
   # Does the exact file exist?
   my $ent= $c->archive_tree->get_path($path);
   $c->log->debug("Path $path is ".($ent? ($ent->[0]->is_blob? 'blob ':'tree ').$ent->[0]->id : ''));
   if ($ent) {
      if ($ent->[0]->is_blob) {
         $c->res->headers->content_disposition(qq{attachment; filename="$basename"});
         $c->render(data => $ent->[0]->content);
      } else {
         $c->render(status => 403, text => 'not a file');
      }
   }
   elsif ($path =~ /(.*?)\.gz\z/
      && ($ent= $c->archive_tree->get_path($1)) && $ent->[0]->is_blob
   ) {
      $c->log->debug("Path $1 is ".$ent->[0]->id.', will gzip it');
      $c->render_gzipped($ent->[0]->content, $basename);
   }
   elsif ($path =~ /(.*?)\.tar\.gz\z/
      # Don't auto-tar trees that don't look like distributions
      && ($ent= $c->archive_tree->get_path("$1.meta")) && $ent->[0]->is_blob
      && ($ent= $c->archive_tree->get_path($1)) && $ent->[0]->is_tree
   ) {
      $c->log->debug("Path $1 is ".$ent->[0]->id.', will tar+gzip it');
      my $tar= Archive::Tar->new;
      $c->cpan_repo->add_git_tree_to_tar($tar, substr($basename, 0, -7), $ent->[0]);
      $c->render_gzipped($tar->write, $basename);
   }
   else {
      $c->render(status => 404, text => 'No such path in branch');
   }
}


sub render_gzipped($c, $data, $filename='') {
   my $gzipped;
   gzip \$data => \$gzipped
     or return $c->reply->exception("gzip failed: $GzipError");
   $c->res->headers->content_type('application/gzip');
   $c->res->headers->content_disposition(qq{attachment; filename="$filename"})
      if length $filename;
   return $c->render(data => $gzipped);
}

1;

__END__