File Coverage

blib/lib/Dancer2/Plugin/ConditionalCaching.pm

Criterion	Covered	Total	%
statement	46	144	31.9
branch	6	104	5.7
condition	14	66	21.2
subroutine	9	12	75.0
pod			n/a
total	75	326	23.0

use strictures 2;

package Dancer2::Plugin::ConditionalCaching;

# ABSTRACT: RFC7234 Caching

use Dancer2::Plugin;
use HTTP::Headers::Fancy;
use HTTP::Date qw(time2str str2time);
use HTTP::Exception;
use Scalar::Util qw(blessed);
use Time::HiRes qw(time);
use Math::Round qw(round);

our $VERSION = '0.001';    # VERSION

sub _instanceof {
    my ( $obj, @cls ) = @_;
    return 0 unless blessed $obj;
    foreach my $cls (@cls) {
        $cls = blessed $cls if blessed $cls;
        return 1 if $obj->isa($cls);
    }
    return 0;
}

sub _cmp_weak {
    my ( $a, $b, $w ) = @_;
    return unless defined $a;
    return unless defined $b;
    $w //= 0;
    if ($w) {
        if ( ref $b ) {
            return $a eq $$b;
        }
        else {
            return $a eq $b;
        }
    }
    else {
        return 0 if ref $b;
        return $a eq $b;
    }
}

register caching => sub {
    my $dsl  = shift;
    my %args = @_;

    my $get_or_head = $dsl->request->method =~ m{^(?:get|head)$}i;

    my $dry = delete $args{dry} // 0;

    my $force = delete $args{force} // 0;
    my $throw = delete $args{throw} // 0;
    my $check = delete $args{check} // 1;

    my $etag = delete $args{etag};
    my $weak = !!delete $args{weak};

    my $changed = delete $args{changed};
    my $expires = delete $args{expires};

    my $no_cache = ( ( delete $args{cache} // 1 ) == 0 );
    my $no_store = ( ( delete $args{store} // 1 ) == 0 );

    my $private = ( delete $args{private} // 0 );
    my $public  = ( delete $args{public}  // 0 );

    if ( $private and $public ) {
        warn "Cache-Control: private and public are mutually exclusive";
    }
    if ($no_cache) {
        if ($no_store) {
            warn "Cache-Control: no-cache and no-store are mutually exclusive";
        }
        if ($private) {
            warn "Cache-Control: no-cache and private are useless together";
        }
        if ($private) {
            warn "Cache-Control: no-cache and private are useless together";
        }
    }

    my %reqh = HTTP::Headers::Fancy::decode_hash( $dsl->request->headers );

    my %req_cc = HTTP::Headers::Fancy::split_field_hash( $reqh{CacheControl} );

    my ( $age, $fresh );

    $age   = time - $changed if defined $changed;
    $fresh = $expires - time if defined $expires;

    if ( defined $age and $age < 0 ) {
        warn("Age: 'changed' points to a timestamp in the future");
        $age = 0;
    }

    my %resp_cc = (
        ( NoCache => undef ) x !!$no_cache,
        ( NoStore => undef ) x !!$no_store,
        ( Private => undef ) x !!$private,
        ( Public  => undef ) x !!$public,
        MustRevalidate => undef,
        NoTransform    => undef,
    );

    if ($check) {
        if ( $req_cc{MaxAge} and defined $age ) {
            if ( $age > $req_cc{MaxAge} ) {
                $force = 1;
            }
        }
        if ( $req_cc{MinFresh} and defined $fresh ) {
            if ( $fresh < $req_cc{MinFresh} ) {
                $force = 1;
            }
        }
    }

    my $builder = sub {
        return unless defined $args{builder};
        my $sub;
        if ( ref $args{builder} eq 'CODE' ) {
            $sub = delete $args{builder};
        }
        else {
            my $data = delete $args{builder};
            $sub = sub { return $data };
        }
        my %subargs = ( %req_cc, Force => $force, );
        return $sub->(%subargs);
    };

    my %resph;

    if ( keys %resp_cc ) {
        $resph{CacheControl} = HTTP::Headers::Fancy::build_field_hash(%resp_cc);
    }
    if ( defined $age ) {
        $resph{Age} = round($age);
    }
    if ( defined $expires ) {
        $resph{Expires} = time2str( round($expires) );
    }
    if ( defined $changed ) {
        $resph{LastModified} = time2str( round($changed) );
    }
    if ( defined $etag ) {
        if ($weak) {
            $resph{Etag} = 'W/"' . $etag . '"';
        }
        else {
            $resph{Etag} = '"' . $etag . '"';
        }
    }

    if ( $get_or_head and !$dry ) {
        $dsl->response->header( HTTP::Headers::Fancy::encode_hash(%resph) );
    }

    unless ($check) {
        return $builder->();
    }

    my $if_match = ( exists $reqh{IfMatch} and defined $reqh{IfMatch} );
    my $if_match_any =
      ( $if_match and ( $reqh{IfMatch} =~ qr{^ \s* \* \s* $}xsi ) );
    my @if_match =
      $if_match_any
      ? ()
      : HTTP::Headers::Fancy::split_field_list( $reqh{IfMatch} );

    my $if_none_match =
      ( exists $reqh{IfNoneMatch} and defined $reqh{IfNoneMatch} );
    my $if_none_match_any =
      ( $if_none_match and ( $reqh{IfNoneMatch} =~ qr{^ \s* \* \s* $}xsi ) );
    my @if_none_match =
      $if_none_match_any
      ? ()
      : HTTP::Headers::Fancy::split_field_list( $reqh{IfNoneMatch} );

    my $if_modified_since   = str2time( $reqh{IfModifiedSince} );
    my $if_unmodified_since = str2time( $reqh{IfUnmodifiedSince} );

    if ($if_match) {
        my $xa = ( !!$if_match_any and !!$etag );
        my $xb = scalar grep { _cmp_weak( $etag, $_, $weak ) } @if_match;
        unless ( $xa or $xb ) {
            HTTP::Exception->throw(412) if $throw;
            return 412 if $dry;
            $dsl->send_error( 'Precondition Failed', 412 );
        }
    }
    elsif ( $if_unmodified_since and defined $changed ) {
        unless ( $if_unmodified_since > $changed ) {
            HTTP::Exception->throw(412) if $throw;
            return 412 if $dry;
            $dsl->send_error( 'Precondition Failed', 412 );
        }
    }
    if ($if_none_match) {
        my $xa = ( !!$if_none_match_any and !!$etag );
        my $xb = scalar grep { _cmp_weak( $etag, $_, $weak ) } @if_none_match;
        if ( $xa or $xb ) {
            if ($get_or_head) {
                HTTP::Exception->throw(304) if $throw;
                return 304 if $dry;
                $dsl->send_error( 'Not Modfied', 304 );
            }
            else {
                HTTP::Exception->throw(412) if $throw;
                return 412 if $dry;
                $dsl->send_error( 'Precondition Failed', 412 );
            }
        }
    }
    elsif ( $get_or_head and $if_modified_since and defined $changed ) {
        if ( $if_modified_since > $changed ) {
            HTTP::Exception->throw(304) if $throw;
            return 304 if $dry;
            $dsl->send_error( 'Not Modfied', 304 );
        }
    }

    return $builder->();
};

register_plugin;

1;

__END__