File Coverage

blib/lib/LWPx/UserAgent/Cached.pm

Criterion	Covered	Total	%
statement	72	77	93.5
branch	18	32	56.2
condition	2	15	13.3
subroutine	16	17	94.1
pod	0	2	0.0
total	108	143	75.5

package LWPx::UserAgent::Cached;

# ABSTRACT: Subclass of LWP::UserAgent that caches HTTP GET requests

use strict;
use warnings;
use utf8;
our $VERSION = '0.010';

## no critic (Bangs::ProhibitCommentedOutCode)

#pod =head1 SYNOPSIS
#pod
#pod     use LWPx::UserAgent::Cached;
#pod     use CHI;
#pod
#pod     my $ua = LWPx::UserAgent::Cached->new(
#pod         cache => CHI->new(
#pod             driver => 'File', root_dir => '/tmp/cache', expires_in => '1d',
#pod         ),
#pod     );
#pod     $ua->get('http://www.perl.org/');
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module borrows the caching logic from
#pod L|WWW::Mechanize::Cached> but
#pod without inheriting from
#pod L|WWW::Mechanize>; instead it is just
#pod a direct subclass of
#pod L|LWP::UserAgent>.
#pod
#pod =head2 HTTP/1.1 cache operation
#pod
#pod Full HTTP/1.1 cache compliance is a work in progress. As of version 0.006 we
#pod have limited support for HTTP/1.1 C/C headers, as well as
#pod C and C C directives (both on request and
#pod response) and the C request header.
#pod
#pod =head1 SEE ALSO
#pod
#pod =over
#pod
#pod =item L|LWP::UserAgent>
#pod
#pod Parent of this class.
#pod
#pod =item L|WWW::Mechanize::Cached>
#pod
#pod Inspiration for this class.
#pod
#pod =back
#pod
#pod =cut

use CHI;
use HTTP::Status qw(HTTP_OK HTTP_MOVED_PERMANENTLY HTTP_NOT_MODIFIED);
use List::Util 1.33 'any';
use Moo 1.004005;
use Types::Standard qw(Bool HasMethods HashRef InstanceOf Maybe);
use namespace::clean;
extends 'LWP::UserAgent';

#pod =attr cache
#pod
#pod Settable at construction, defaults to using
#pod L|CHI::Driver::RawMemory> with
#pod an instance-specific hash datastore and a namespace with the current
#pod package name. You can use your own caching object here as long as it has
#pod C and C methods.
#pod
#pod =cut

has cache => (
    is      => 'lazy',
    isa     => HasMethods [qw(get set)],
    default => sub {
        CHI->new(
            serializer => 'Sereal',
            driver     => 'RawMemory',
            datastore  => $_[0]->_cache_datastore,
            namespace  => __PACKAGE__,
        );
    },
);
has _cache_datastore =>
    ( is => 'lazy', isa => HashRef, default => sub { {} } );

#pod =attr is_cached
#pod
#pod Read-only accessor that indicates if the current request is cached or not.
#pod
#pod =cut

has is_cached =>
    ( is => 'rwp', isa => Maybe [Bool], init_arg => undef, default => undef );

#pod =attr cache_undef_content_length
#pod
#pod Settable at construction or anytime thereafter, indicates whether we should
#pod cache content even if the HTTP C header is missing or
#pod undefined. Defaults to false.
#pod
#pod =cut

has cache_undef_content_length => ( is => 'rw', isa => Bool, default => 0 );

#pod =attr cache_zero_content_length
#pod
#pod Settable at construction or anytime thereafter, indicates whether we should
#pod cache content even if the HTTP C header is zero. Defaults to
#pod false.
#pod
#pod =cut

has cache_zero_content_length => ( is => 'rw', isa => Bool, default => 0 );

#pod =attr cache_mismatch_content_length
#pod
#pod Settable at construction or anytime thereafter, indicates whether we should
#pod cache content even if the length of the data does not match the HTTP
#pod C header. Defaults to true.
#pod
#pod =cut

has cache_mismatch_content_length =>
    ( is => 'rw', isa => Bool, default => 1 );

#pod =attr ref_in_cache_key
#pod
#pod Settable at construction or anytime thereafter, indicates whether we should
#pod store the HTTP referrer in the cache key. Defaults to false.
#pod
#pod =cut

has ref_in_cache_key => ( is => 'rw', isa => Bool, default => 0 );

#pod =attr positive_cache
#pod
#pod Settable at construction or anytime thereafter, indicates whether we should
#pod only cache positive responses (HTTP response codes from C<200> to C<300>
#pod inclusive) or cache everything. Defaults to true.
#pod
#pod =cut

has positive_cache => ( is => 'rw', isa => Bool, default => 1 );

#pod =attr ignore_headers
#pod
#pod Settable at construction or anytime thereafter, indicates whether we should
#pod ignore C, C, and
#pod C HTTP headers when deciding whether to cache a response.
#pod Defaults to false.
#pod
#pod B This option is potentially dangerous, as it ignores the
#pod explicit instructions from the server and thus can lead to returning stale
#pod content.
#pod
#pod =cut

has ignore_headers => ( is => 'rw', isa => Bool, default => 0 );

#pod =head1 HANDLERS
#pod
#pod This module works by adding C, C and
#pod C L
#pod that run on successful HTTP C requests.
#pod If you need to modify or remove these handlers you may use LWP::UserAgent's
#pod L.
#pod
#pod =for Pod::Coverage BUILD
#pod
#pod =cut

sub BUILD {
    my $self = shift;

    $self->add_handler( request_send => \&_get_cache, ( m_method => 'GET' ) );
    $self->add_handler(
        response_done => \&_set_cache,
        ( m_method => 'GET', m_code => 2 ),
    );
    $self->add_handler(
        response_header => \&_get_not_modified,
        ( m_method => 'GET', m_code => HTTP_NOT_MODIFIED ),
    );

    return;
}

# load from cache on each GET request
sub _get_cache {
    my ( $request, $self ) = @_;
    $self->_set_is_cached(0);

    my $clone = $request->clone;
    if ( not $self->ref_in_cache_key ) { $clone->header( Referer => undef ) }
    return if $self->_no_cache_header_directives($request);

    return if not my $response = $self->cache->get( $clone->as_string );
    return
        if $response->code < HTTP_OK
        or $response->code > HTTP_MOVED_PERMANENTLY;

    if ( $response->header('etag') ) {
        $clone->header( if_none_match => $response->header('etag') );
        $response = $self->request($clone);
    }
    return if $self->_no_cache_header_directives($response);

    $self->_set_is_cached(1);
    return $response;
}

sub _get_not_modified {
    my ( $response, $self ) = @_;
    $self->_set_is_cached(0);

    my $request = $response->request->clone;
    $request->remove_header(qw(if_modified_since if_none_match));

    my $cached_response = $self->cache->get( $request->as_string );
    $response->content( $cached_response->decoded_content );

    $self->_set_is_cached(1);
    return;
}

# save to cache after successful GET
sub _set_cache {
    my ( $response, $self ) = @_;
    return if not $response;

    if (not($response->header('client-transfer-encoding')
            and any { 'chunked' eq $_ }
            $response->header('client-transfer-encoding')
        )
        )
    {
        for ( $response->header('size') ) {
            return
                if not defined and $self->cache_undef_content_length;
            return
                if 0 == $_
                and not $self->cache_zero_content_length;
            return
                if $_ != length $response->content
                and not $self->cache_mismatch_content_length;
        }
    }

    for my $message ( $response, $response->request ) {
        return if $self->_no_cache_header_directives($message);
    }

    $response->decode;
    $self->cache->set( $response->request->as_string => $response );
    return;
}

sub _no_cache_header_directives {
    my ( $self, $message ) = @_;
    return if $self->ignore_headers;

    for my $header_name (qw(pragma cache_control)) {
        if ( my @directives = $message->header($header_name) ) {
            return 1 if any {/\A no- (?: cache | store ) /xms} @directives;
        }
    }
    return;
}

#pod =for Pod::Coverage FOREIGNBUILDARGS
#pod
#pod =cut

## no critic (Subroutines::RequireArgUnpacking)
sub FOREIGNBUILDARGS {
    shift;
    return 'HASH' eq ref $_[0] ? %{ $_[0] } : @_;
}

1;

__END__