Catalyst::Plugin::PageCache - Cache the output of entire pages

    use Catalyst;
    MyApp->setup( qw/Cache::FileCache PageCache/ );

    __PACKAGE__->config(
        'Plugin::PageCache' => {
            expires => 300,
            set_http_headers => 1,
            auto_cache => [
                '/view/.*',
                '/list',
            ],
            debug => 1,

            # Optionally, a cache hook method to be called prior to dispatch to
            # determine if the page should be cached.  This is called both
            # before dispatch, and before finalize.
            cache_hook => 'some_method',

            # You may alternatively set different methods to be used as hooks
            # for dispatch and finalize. The dispatch method will determine
            # whether the currently cached page will be displayed to the user,
            # and the finalize hook will determine whether to save the newly
            # created page.
            cache_dispatch_hook => 'some_method_for_dispatch',
            cache_finalize_hook => 'some_method_for_finalize',
        }
    );

    sub some_method {
        my $c = shift;
        if ( $c->user_exists and $c->user->some_field ) {
            return 0; # Don't cache
        }
        return 1; # Cache
    }

    # in a controller method
    $c->cache_page( '3600' );

    $c->clear_cached_page( '/list' );

    # Expire at a specific time
    $c->cache_page( $datetime_object );




    # Fine control
    $c->cache_page(
        last_modified   => $last_modified,
        cache_seconds   => 24 * 60 * 60,    # once a day
        expires         => 300,             # allow client caching
    );

    expires => $seconds

    cache_headers => 1

    set_http_headers => 1

    auto_cache => [
        $uri,
    ]

    disable_index => 1

    index_page_key => '...'

    busy_lock => 10

    debug => 1

    auto_check_user => 1

    cache_hook => 'cache_hook_method'
    cache_finalize_hook => 'cache_finalize_hook_method'
    cache_dispatch_hook => 'cache_dispatch_hook_method'

    package MyApp;

    ...

    sub cache_hook_method { return shift->debug; }

    sub cache_hook_method {
        my ( $c ) = @_;
        return !$c->check_user_roles('admin');
    }

    __PACKAGE__->config(
        'Plugin::PageCache' => {
            key_maker => sub {
                my $c = shift;
                return $c->req->base . '/' . $c->req->path;
            }
        }
    );

    $c->cache_page( $expire );

    $two_hours = DateTime->now->add( hours => 2 );
    $c->cache_page( $two_hours );

    $c->cache_page(
        last_modified   => $last_modified,
        cache_seconds   => 24 * 60 * 60,
        expires         => 30,
    );

    $c->clear_cached_page( '/view/userlist' );
    $c->clear_cached_page( '/view/.*' );
    $c->clear_cached_page( '/view/.*\?.*\bparam=value\b' );

package Catalyst::Plugin::PageCache;

use strict;
use base qw/Class::Accessor::Fast/;
use MRO::Compat;
use Digest::SHA1 ();

our $VERSION = '0.31';

# Do we need to cache the current page?
__PACKAGE__->mk_accessors('_cache_page');

# Keeps track of whether the current request was served from cache
__PACKAGE__->mk_accessors('_page_cache_used');

# Keeps a safe copy of the initial request parameters, in case the
# user changes them during processing
__PACKAGE__->mk_accessors('_page_cache_key');

sub cache_page {
    my ( $c, @args ) = @_;
    my %options;

    # Mark that cache_page has been called but defer on selecting the time
    # period to cache for until finalize. _get_page_cache_expiration_time has
    # more options at that time, such as various headers which may have been set.

    if (@args == 1) {
        my $expires = shift @args;

        # Allow specific end time
        $expires = $expires->epoch - time()
            if ref($expires) && $expires->can('epoch');

        $options{cache_seconds} = $expires;
    }
    else {
        %options = @args;
    }

    $c->_cache_page( \%options );
}


sub clear_cached_page {
    my ( $c, $uri ) = @_;

    return undef unless $c->can( 'cache' );

    my $pc_config = $c->config->{'Plugin::PageCache'};
    my $is_debug  = $pc_config->{debug};
    
    # Warn if index was disabled
    my $index_page_key = $pc_config->{index_page_key} or do {
        $c->log->warn("clear_cached_page($uri) did not clear the cache because disable_index is set");
        return;
    };
    
    my $cache = $c->cache; # curry the cache just once, here

    my $index = $cache->get( $index_page_key ) || {};

    my $removed = 0;
    foreach my $index_key ( keys %$index ) {

        # find matching entries, ignoring the language prefix
        next unless $index_key =~ /^ $uri (?:\#.*)? $/x;

        # delete from the index and remove the corresponding cache entry
        # (which may have a different key, e.g., sha1 encoded)
        my $cache_key = delete $index->{$index_key};
        $cache->remove( $cache_key );
        $removed++;

        $c->log->debug( "Removed $index_key from page cache" ) if $is_debug;
    }

    $cache->set( $index_page_key, $index, $pc_config->{no_expire} )
        if $removed;

    $removed;
}


# return the time that the item should expire
sub _get_page_cache_expiration_time {
    my ($c, $options) = @_;
    my $pc_config = $c->config->{'Plugin::PageCache'};
    my $is_debug = $pc_config->{debug};

    my $expires;

    # Use the explicitely passed in duration if available.
    # XXX but why then ignore it if it's <= 0 ?
    if ($options->{cache_seconds} and $options->{cache_seconds} > 0) {
        $c->log->debug("expires in specified $options->{cache_seconds}s")
            if $is_debug;

        $expires = time() + $options->{cache_seconds};
    }
    # else {
    #   ... calculate expiry based on the response headers
    # }
    # If all else fails, fallback to the default 'expires' configuration value.
    else {
        $c->log->debug("expires in default $pc_config->{expires}s")
            if $is_debug;
        $expires = time() + $pc_config->{expires};
    }

    return $expires;
}


sub dispatch {
    my $c = shift;

    # only serve GET and HEAD request pages from cache
    # (never POST, PUT, DELETE etc)
    return $c->next::method(@_)
        unless $c->req->method =~ m/^(?:GET|HEAD)$/;

    my $pc_config = $c->config->{'Plugin::PageCache'};

    my $hook_name = $pc_config->{cache_dispatch_hook} || $pc_config->{cache_hook};
    my $hook = $hook_name ? $c->can($hook_name) : undef;
    return $c->next::method(@_) if ( $hook && !$c->$hook() );

    return $c->next::method(@_)
      if ( $pc_config->{auto_check_user}
        && $c->can('user_exists')
        && $c->user_exists);

    # check the page cache for a cached copy of this page
    return $c->next::method(@_)
        unless my $key = $c->_get_page_cache_key;

    my $cache = $c->cache; # curry the cache just once, here

    return $c->next::method(@_)
        unless my $data = $cache->get( $key );

    # Time to remove page from cache?

    if ( $data->{expire_time} && $data->{expire_time} <= time ) {
        if ( my $busy_lock = $pc_config->{busy_lock} ) {
            # Extend the expiration time for others while
            # this caller refreshes the cache
            $data->{expire_time} = time() + $busy_lock;
            
            $cache->set( $key, $data );
            
            $c->log->debug( "$key has expired, being refreshed for $busy_lock seconds" )
                if ($pc_config->{debug});
        }
        else {
            $c->log->debug( "Expiring $key from page cache" )
              if ($pc_config->{debug});

            $cache->remove( $key );

            if ( my $index_page_key = $pc_config->{index_page_key} ) {
                my $index = $cache->get( $index_page_key ) || {};
                my $found = delete $index->{ $data->{index_key} };
                $cache->set( $index_page_key, $index, $pc_config->{no_expire})
                    if $found;
            }
        }

        return $c->next::method(@_);
    }

    $c->log->debug("Serving $key from page cache, expires in "
          . ($data->{expire_time} - time)
          . " seconds")
        if ($pc_config->{debug});

    $c->_page_cache_used( 1 );

    # Check If-Modified-Since headers
    return 1 if $c->_page_cache_not_modified( $data );

    # Serve cached page

    $c->res->body( $data->{body} );

    $c->res->content_type( join '; ', @{$data->{content_type}} )
        if $data->{content_type};

    $c->res->content_encoding( $data->{content_encoding} )
        if $data->{content_encoding};

    $c->_set_page_cache_headers( $data );

    $c->res->header('X-PageCache', 'Catalyst');

}

# See if request matches last_modified date in cache
# if so, arrange to return a 304 Not Modified status
# and return true.

sub _page_cache_not_modified {
    my ( $c, $data ) = @_;

    if ( $c->req->headers->if_modified_since ) {

        if ( $c->req->headers->if_modified_since == $data->{create_time} ) {
            $c->res->status(304); # Not Modified
            $c->res->headers->remove_content_headers;
            $c->_set_page_cache_headers( $data );
            $c->res->body( '' );
            return 1;
        }
    }

    return;
}

# Sets cache headers for the page if set_http_headers is true.

sub _set_page_cache_headers {
    my ( $c, $data ) = @_;
    my $headers = $c->res->headers;
    my $pc_config = $c->config->{'Plugin::PageCache'};

    if ( $pc_config->{cache_headers} ) {
        for my $header_key ( keys %{ $data->{headers} || {} } ) {
            $headers->header(
                $header_key => $data->{headers}->{$header_key}
            );
        }
    }
    
    return unless $pc_config->{set_http_headers};

    if ( exists $data->{expires} ) {

        # page cache but not client cache
        if ( !$data->{expires} ) {
            $headers->header( 'Cache-Control' => 'no-cache' );
            $headers->header( 'Pragma' => 'no-cache' );
            return;
        }

        $headers->header(
            'Cache-Control' => "max-age=" . $data->{expires});

        $headers->expires( time + $data->{expires} );

    }
    else {

        $headers->header(
            'Cache-Control' => "max-age=" . ($data->{expire_time} - time));

        $headers->expires( $data->{expire_time} );
    }

    $headers->last_modified( $data->{create_time} )
        unless $c->res->status && $c->res->status == 304;
}

sub finalize {
    my $c = shift;

    # never cache POST requests
    return $c->next::method(@_) if ( $c->req->method eq "POST" );

    my $pc_config = $c->config->{'Plugin::PageCache'};

    my $hook_name = $pc_config->{cache_dispatch_hook} || $pc_config->{cache_hook};
    my $hook = $hook_name ? $c->can($hook_name) : undef;
    return $c->next::method(@_) if ( $hook && !$c->$hook() );

    return $c->next::method(@_)
      if ( $pc_config->{auto_check_user}
        && $c->can('user_exists')
        && $c->user_exists);
    return $c->next::method(@_) if ( scalar @{ $c->error } );

    # if we already served the current request from cache, we can skip the
    # rest of this method
    return $c->next::method(@_) if ( $c->_page_cache_used );

    if (!$c->_cache_page
        && scalar @{ $pc_config->{auto_cache} })
    {

        # is this page part of the auto_cache list?
        my $path = "/" . $c->req->path;

        # For performance, this should be moved to setup, and generate a hash.
        AUTO_CACHE:
        foreach my $auto (@{ $pc_config->{auto_cache} })
        {
            next if $auto =~ m/^\d$/;
            if ( $path =~ /^$auto$/ ) {
                $c->log->debug( "Auto-caching page $path" )
                    if ($pc_config->{debug});
                $c->cache_page;
                last AUTO_CACHE;
            }
        }
    }

    if ($c->_cache_page) {
        my $data = $c->_store_page_in_cache($c->_cache_page) ;

        # Check for If-Modified-Since
        $c->_page_cache_not_modified( $data ) if $data;
    }

    return $c->next::method(@_);
}


sub _store_page_in_cache {
    my ($c, $options) = @_;

    my $key = $c->_get_page_cache_key;
    my $pc_config = $c->config->{'Plugin::PageCache'};
    my $now = time();

    my $headers = $c->res->headers;

    # Cache some additional metadata along with the content
    # Some caches don't support expirations, so we do it manually
    my $data = {
        body => $c->res->body || undef,
        content_type => [ $c->res->content_type ] || undef,
        content_encoding => $c->res->content_encoding || undef,
        create_time      => $options->{last_modified}
            || $headers->last_modified
            || $now,
        expire_time => $c->_get_page_cache_expiration_time($options),
    };

    return undef if $data->{expire_time} <= $now;

    $c->log->debug(
        "Caching page $key for ". ($data->{expire_time} - time()) ." seconds"
    ) if ($pc_config->{debug});
    
    if ( $pc_config->{cache_headers} ) {
        $data->{headers} = {
            map { $_ => $headers->header($_) } $headers->header_field_names
        };
    }

    if ($pc_config->{index_page_key}) {
        # We can't simply use $key for $index_key because $key may have been
        # mangled by sha1 and/or a key_maker hook.  We include $key to ensure
        # unique entries in the index in cases where a given uri might produce
        # different results eg due to headers like language.
        $data->{index_key}  = '/'.$c->req->path;
        $data->{index_key} .= '?'.$c->req->uri->query if $c->req->uri->query;
        $data->{index_key} .= '#'.$key;
    }

    if (exists $options->{expires}) {
        $data->{expires} = $options->{expires}
    }

    my $cache = $c->cache; # curry the cache just once, here

    $cache->set( $key, $data );

    $c->_set_page_cache_headers( $data );  # don't forget the first time

    if ( $data->{index_key} ) {
        # Keep an index cache of all pages that have been cached, for use
        # with clear_cached_page. This is error prone. See KNOWN ISSUES.
        my $index_page_key = $pc_config->{index_page_key};
        my $index = $cache->get($index_page_key) || {};
        $index->{ $data->{index_key} } = $key;
        $cache->set($index_page_key, $index, $pc_config->{no_expire});
    }

    return $data;
}


sub setup {
    my $c = shift;

    $c->next::method(@_);

    # allow code using old config key to work
    if ( $c->config->{page_cache} and !$c->config->{'Plugin::PageCache'} ) {
        $c->config->{'Plugin::PageCache'} = delete $c->config->{page_cache};
    }

    my $pc_config = $c->config->{'Plugin::PageCache'} ||= {};

    $pc_config->{auto_cache}       ||= [];
    $pc_config->{expires}          ||= 60 * 5;
    $pc_config->{cache_headers}    ||= 0;
    $pc_config->{set_http_headers} ||= 0;
    $pc_config->{busy_lock}        ||= 0;
    $pc_config->{debug}            ||= $c->debug;

    # default the page key to include the app name to give some measure
    # of protection if the cache doesn't have a namespace set.
    $pc_config->{index_page_key} = "$c._page_cache_index"
        unless defined $pc_config->{index_page_key};

    if (not defined $pc_config->{disable_index}) {
        warn "Plugin::PageCache config does not include disable_index, which currently defaults false but may default true in future\n";
        $pc_config->{disable_index} = 0;
    }
    $pc_config->{index_page_key} = undef
        if $pc_config->{disable_index};

    # detect the cache plugin being used and set appropriate
    # never-expires syntax
    if ( $c->can('cache') ) {

        # Newer C::P::Cache, cannot call $c->cache as a package method
        if ( $c->isa('Catalyst::Plugin::Cache') ) {
            return;
        }

        my $cache = $c->cache; # curry the cache just once, here

        # Older Cache plugins
        if ( $cache->isa('Cache::FileCache') ) {
            $pc_config->{no_expire} = "never";
        }
        elsif ($cache->isa('Cache::Memcached')
            || $cache->isa('Cache::FastMmap'))
        {

          # Memcached defaults to 'never' when not given an expiration
          # In FastMmap, it's not possible to set an expiration
            $pc_config->{no_expire} = undef;
        }
    }
    else {
        die __PACKAGE__ . " requires a Catalyst::Plugin::Cache plugin.";
    }
}

sub _get_page_cache_key {
    my $c = shift;
    
    # We can't rely on the params after the user's code has run,
    # so we cache the key created during the initial dispatch phase
    # and reuse it at finalize time.
    return $c->_page_cache_key if ( $c->_page_cache_key );

    # override key if required, else use uri path
    my $keymaker = $c->config->{'Plugin::PageCache'}->{key_maker};
    my $key = $keymaker ? $keymaker->($c) : "/" . $c->req->path;
    
    # prepend language if I18N present.
    if ( $c->can('language') ) {
        $key = ':' . $c->language . ':' . $key;
    }

    # some caches have limits on the max key length (eg for memcached it's 250
    # minus the namespace length) so if the key is a non-trvial length then
    # replace the tail with a sha1. (We only replace the tail because it's
    # useful to be able to see the leading portion of the path in the debug logs)
    if (length($key) > 100) {
        substr($key, 100) = Digest::SHA1::sha1_hex($key); # 40 bytes
    }
    # Check for spaces as it's cheap insurance, just in case, for memcached
    $key =~ s/\s/~/g;

    # we always sha1 the parameters/query as they're typically long
    # and it also avoids issues like spaces in keys for memcached
    my $params_key;
    my $parameters = $c->req->parameters;
    if (%$parameters) {
        local $Storable::canonical = 1;
        $params_key = Storable::nfreeze($parameters);
    }
    elsif ( my $query = $c->req->uri->query ) {
        $params_key = $query;
    }
    # use sha1 to avoid problems with over-long params or params
    # containing values that can't be used as a key (eg spaces for memcached)
    $key .= '?' . Digest::SHA1::sha1_hex($params_key) # 40 bytes
        if $params_key;

    $c->_page_cache_key( $key );

    return $key;
}

1;
__END__