Merge pull request #1546 from CPAN-API/leo/caching_1

Leo/caching 1
metacpan · Jun 8, 2015 · a180b15 · a180b15
2 parents 0bd5aa0 + ffb737c
commit a180b15
Show file tree

Hide file tree

Showing 12 changed files with 195 additions and 19 deletions.
diff --git a/app.psgi b/app.psgi
@@ -194,21 +194,6 @@ else {
             'Cache-Control' => "max-age=${hour_ttl}",
         ];
 
-        # Tell fastly to cache, most of /source/
-        # /source/AUTHOR/anything e.g /source/ETHER/YAML-Tiny-1.67/
-        # But NO instructions for...
-        # /source/Foo::bar <- latest package (no 3rd /)
-        # /source/AUTHOR/ <- author package list, nothing after 3rd /
-        enable_if { $_[0]->{PATH_INFO} =~ m{^/source/.+/.+} } 'Headers',
-            set => [
-            'Surrogate-Control' => "max-age=${year_ttl}",
-            'Surrogate-Key'     => 'source',
-
-            # Tell the user's browser to cache for an hour,
-            # incase the regex isn't quite right!
-            'Cache-Control' => "max-age=${hour_ttl}",
-            ];
-
         $app;
     };
 }

diff --git a/lib/MetaCPAN/Web/Controller/About.pm b/lib/MetaCPAN/Web/Controller/About.pm
@@ -5,6 +5,16 @@ use Format::Human::Bytes;
 
 BEGIN { extends 'MetaCPAN::Web::Controller' }
 
+sub auto : Private {
+    my ( $self, $c ) = @_;
+
+    $c->add_surrogate_key('about');
+    $c->res->header(
+        'Cache-Control' => 'max-age=' . $c->cdn_times->{one_day} );
+    $c->cdn_cache_ttl( $c->cdn_times->{one_day} );
+
+}
+
 sub about : Local : Path('/about') {
     my ( $self, $c ) = @_;
     $c->stash( template => 'about.html' );
@@ -48,9 +58,7 @@ sub metadata : Local {
 sub stats : Local {
     my ( $self, $c ) = @_;
 
-    $c->add_surrogate_key('html');
     $c->add_surrogate_key('stats');
-    $c->cdn_cache_ttl(86_400);    # 1 day
 
     $c->stash( template => 'about/stats.html' );
 

diff --git a/lib/MetaCPAN/Web/Controller/Mirrors.pm b/lib/MetaCPAN/Web/Controller/Mirrors.pm
@@ -8,6 +8,11 @@ BEGIN { extends 'MetaCPAN::Web::Controller' }
 sub index : Path {
     my ( $self, $c ) = @_;
 
+    $c->add_surrogate_key('mirrors');
+    $c->res->header(
+        'Cache-Control' => 'max-age=' . $c->cdn_times->{one_day} );
+    $c->cdn_cache_ttl( $c->cdn_times->{one_day} );
+
     my $location;
     my @protocols;
     if ( my $q = $c->req->parameters->{q} ) {

diff --git a/lib/MetaCPAN/Web/Controller/Root.pm b/lib/MetaCPAN/Web/Controller/Root.pm
@@ -38,6 +38,12 @@ The root page (/)
 
 sub index : Path : Args(0) {
     my ( $self, $c ) = @_;
+
+    $c->add_surrogate_key('homepage');
+    $c->res->header(
+        'Cache-Control' => 'max-age=' . $c->cdn_times->{one_hour} );
+    $c->cdn_cache_ttl( $c->cdn_times->{one_day} );
+
     $c->stash->{template} = 'home.html';
 }
 
@@ -71,6 +77,12 @@ sub forbidden : Private {
 
 sub robots : Path("robots.txt") {
     my ( $self, $c ) = @_;
+
+    $c->add_surrogate_key('robots');
+    $c->res->header(
+        'Cache-Control' => 'max-age=' . $c->cdn_times->{one_day} );
+    $c->cdn_cache_ttl( $c->cdn_times->{one_year} );
+
     $c->stash( { template => 'robots.txt' } );
 }
 

diff --git a/lib/MetaCPAN/Web/Controller/Source.pm b/lib/MetaCPAN/Web/Controller/Source.pm
@@ -8,6 +8,22 @@ BEGIN { extends 'MetaCPAN::Web::Controller' }
 sub index : PathPart('source') : Chained('/') : Args {
     my ( $self, $c, @module ) = @_;
 
+    $c->add_surrogate_key('source');
+    $c->res->header(
+        'Cache-Control' => 'max-age=' . $c->cdn_times->{one_hour} );
+
+    if ( @module == 1 ) {
+
+        # /source/Foo::bar or /source/AUTHOR/
+        $c->cdn_cache_ttl( $c->cdn_times->{one_hour} );
+
+    }
+    else {
+        # SO can cache for a LONG time
+        # /source/AUTHOR/anything e.g /source/ETHER/YAML-Tiny-1.67/
+        $c->cdn_cache_ttl( $c->cdn_times->{one_year} );
+    }
+
     my ( $source, $module );
     if ( @module == 1 ) {
         $module = $c->model('API::Module')->find(@module)->recv;

diff --git a/lib/MetaCPAN/Web/Role/Fastly.pm b/lib/MetaCPAN/Web/Role/Fastly.pm
@@ -17,7 +17,7 @@ The following:
 
 =head2 $c->purge_surrogate_key('bar');
 
-=head2 $c->cdn_cache_ttl(3600);
+=head2 $c->cdn_cache_ttl( $c->cdn_times->{one_day} );
 
 Are applied when:
 
@@ -30,6 +30,11 @@ Are applied when:
 Is set fastly is forced to NOT cache, no matter
 what other options have been set
 
+=head2 $c->cdn_times;
+
+Returns a hashref of 'one_hour', 'one_day', 'one_week'
+and 'one_year' so we don't have numbers all over the place
+
 =cut
 
 ## Stuff for working with Fastly CDN
@@ -75,6 +80,21 @@ has 'cdn_never_cache' => (
     default => sub {0},
 );
 
+has 'cdn_times' => (
+    is         => 'ro',
+    isa        => 'HashRef',
+    lazy_build => 1,
+);
+
+sub _build_cdn_times {
+    return {
+        one_hour => 3600,
+        one_day  => 86_400,
+        one_week => 604_800,
+        one_year => 31_536_000
+    };
+}
+
 sub _net_fastly {
     my $c = shift;
 

diff --git a/lib/MetaCPAN/Web/Test.pm b/lib/MetaCPAN/Web/Test.pm
@@ -8,6 +8,7 @@ use Plack::Test;
 use HTTP::Request::Common;
 use HTTP::Message::PSGI;
 use HTML::Tree;
+use Test::More;
 use Test::XPath;
 use Try::Tiny;
 use Encode;
@@ -18,6 +19,7 @@ our @EXPORT = qw(
     override_api_response
     app
     tx
+    test_cache_headers
 );
 
 # TODO: use Sub:Override?
@@ -98,6 +100,28 @@ sub tx {
     return $tx;
 }
 
+sub test_cache_headers {
+    my ( $res, $conf ) = @_;
+
+    is(
+        $res->header('Cache-Control'),
+        $conf->{cache_control},
+        "Cache Header: Cache-Control ok"
+    ) if $conf->{cache_control};
+
+    is(
+        $res->header('Surrogate-Key'),
+        $conf->{surrogate_key},
+        "Cache Header: Surrogate-Key ok"
+    ) if $conf->{surrogate_key};
+
+    is(
+        $res->header('Surrogate-Control'),
+        $conf->{surrogate_control},
+        "Cache Header: Surrogate-Control ok"
+    ) if $conf->{surrogate_control};
+}
+
 1;
 
 =head1 ENVIRONMENTAL VARIABLES
@@ -135,3 +159,18 @@ Returns the L<MetaCPAN::Web> psgi app.
 =head2 tx($res)
 
 Parses C<< $res->content >> and generates a L<Test::XPath> object.
+
+=head2 test_cache_headers
+
+  test_cache_headers(
+      $res,
+      {
+          cache_control     => 'max-age=3600',
+          surrogate_key     => 'source',
+          surrogate_control => 'max-age=31536000',
+      }
+  );
+
+Checks headers on a response, only checks provieded keys
+
+=cut
diff --git a/t/controller/about.t b/t/controller/about.t
@@ -0,0 +1,33 @@
+use strict;
+use warnings;
+use Test::More;
+use MetaCPAN::Web::Test;
+
+my @tests = (
+    {
+        url => '/about'
+    },
+    {
+        url => '/about/resources',
+    },
+);
+
+test_psgi app, sub {
+    my $cb = shift;
+
+    foreach my $test (@tests) {
+        ok( my $res = $cb->( GET $test->{url} ), 'GET ' . $test->{url} );
+        is( $res->code, 200, 'code 200' );
+        test_cache_headers(
+            $res,
+            {
+                cache_control     => 'max-age=86400',
+                surrogate_key     => 'about',
+                surrogate_control => 'max-age=86400',
+            }
+        );
+    }
+
+};
+
+done_testing;
diff --git a/t/controller/home.t b/t/controller/home.t
@@ -7,6 +7,15 @@ test_psgi app, sub {
     my $cb = shift;
     ok( my $res = $cb->( GET q{/} ), 'GET /' );
     is( $res->code, 200, 'code 200' );
+    test_cache_headers(
+        $res,
+        {
+            cache_control     => 'max-age=3600',
+            surrogate_key     => 'homepage',
+            surrogate_control => 'max-age=86400',
+        }
+    );
+
 };
 
 done_testing;
diff --git a/t/controller/robots.t b/t/controller/robots.t
@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+use Test::More;
+use MetaCPAN::Web::Test;
+
+test_psgi app, sub {
+    my $cb = shift;
+    ok( my $res = $cb->( GET q{/robots.txt} ), 'GET /robots.txt' );
+    is( $res->code, 200, 'code 200' );
+
+SKIP: {
+        skip 'Root controller is not serving /robots.txt!', 3;
+        test_cache_headers(
+            $res,
+            {
+                cache_control     => 'max-age=3600',
+                surrogate_key     => 'robots',
+                surrogate_control => 'max-age=86400',
+            }
+        );
+    }
+};
+
+done_testing;
diff --git a/t/controller/source.t b/t/controller/source.t
@@ -17,8 +17,33 @@ test_psgi app, sub {
         'text/html; charset=utf-8',
         'Content-type text/html; charset=utf-8'
     );
+    test_cache_headers(
+        $res,
+        {
+            cache_control     => 'max-age=3600',
+            surrogate_key     => 'source',
+            surrogate_control => 'max-age=31536000',
+        }
+    );
+
     ok( $res->content =~ /package Moose/, 'includes Moose package' );
 
+    {
+        # Check a URL that is the 'latest', e.g. no version num
+        my $uri = '/source/Moose';
+        ok( my $res = $cb->( GET $uri ), "GET $uri" );
+        is( $res->code, 200, 'code 200' );
+        test_cache_headers(
+            $res,
+            {
+                cache_control     => 'max-age=3600',
+                surrogate_key     => 'source',
+                surrogate_control => 'max-age=3600',
+            }
+        );
+
+    }
+
     {
         # Test the html produced once; test different filetypes below.
         my $prefix = '/source/RJBS/Dist-Zilla-4.200012';

diff --git a/t/lib/TestContext.pm b/t/lib/TestContext.pm
@@ -13,7 +13,7 @@ our @EXPORT_OK = qw(
 );
 
 sub get_context {
-    return ( ctx_request('/robots.txt') )[1];
+    return ( ctx_request('/foo_not_real.txt') )[1];
 }
 
 1;