Catalyst::Plugin::HashedCookies - Tamper-resistant HTTP Cookies

 use Catalyst qw/HashedCookies/;
 MyApp->config->{hashedcookies} = {
     key       => $secret_key,
     algorithm => 'SHA1', # optional
     required  => 1,      # optional
 };
 MyApp->setup;

 # later, in another part of MyApp...

 print "this cookie tastes good!\n"
  if $c->request->valid_cookie('my_cookie_name');

package Catalyst::Plugin::HashedCookies;
BEGIN {
  $Catalyst::Plugin::HashedCookies::VERSION = '1.110231';
}

use strict;
use warnings FATAL => 'all';

use MRO::Compat;
use Symbol;
use Tie::IxHash;
use CGI::Simple::Cookie;
use Digest::HMAC_MD5;
use Digest::HMAC_SHA1;

{
    package Catalyst::Request::HashedCookies;
BEGIN {
  $Catalyst::Request::HashedCookies::VERSION = '1.110231';
}
    use base 'Catalyst::Request';

    __PACKAGE__->mk_accessors(qw/validhashedcookies invalidhashedcookies/);

    # reveal whether a hashed cookie passed its integrity check
    sub valid_cookie {
        my $self = shift;
        my $name = shift;

        return exists $self->validhashedcookies->{$name};
    }

    # reveal whether a hashed cookie passed its integrity check
    sub invalid_cookie {
        my $self = shift;
        my $name = shift;

        return exists $self->invalidhashedcookies->{$name};
    }
}

sub setup {
    my $self = shift;

    # fix request class - thanks once again to mst
    if ($self->request_class eq 'Catalyst::Request') {
        $self->request_class('Catalyst::Request::HashedCookies');
    }
    else {
        die 'Please make a Request subclass for your application which '.
            'isa Catalyst::Request::HashedCookies';
    }

    $self->config->{hashedcookies}->{algorithm} ||= 'SHA1';
    ( $self->config->{hashedcookies}->{algorithm} =~ m/^(?:SHA1|MD5)$/ )
      or die 'Request for unknown digest algorithm to '. __PACKAGE__;

    exists $self->config->{hashedcookies}->{required}
      or $self->config->{hashedcookies}->{required} = 1;
    # not checked - perl's handling of truth will make junk values 'work'

    defined $self->config->{hashedcookies}->{key}
      or die '"key" is a required configuration parameter to '. __PACKAGE__;

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


# remove and check hash in Cookie Values
sub prepare_cookies {
    my $c = shift;
    $c->next::method(@_);
    $c->request->validhashedcookies(   {} );
    $c->request->invalidhashedcookies( {} );

    my $hasher = 'Digest::HMAC_'. $c->config->{hashedcookies}->{algorithm};
    my $hmac   = $hasher->new( $c->config->{hashedcookies}->{key} );

    while ( my ( $name, $cgicookie ) = each %{ $c->request->cookies } ) {
        my @values = @{ [ $cgicookie->value ] };
        my $digest = '';

        # restore cookie to original Value set by user
        if ( scalar @values % 2 == 0 ) {
            my $t = Tie::IxHash->new(@values);
            my $d = $t->Indices('_hashedcookies_digest');
            my $p = $t->Indices('_hashedcookies_padding');

            if ( defined $d ) {
                $digest = $t->Values($d);
                splice( @values, $d * 2, 2 );
            }

            if ( defined $p ) {
                splice( @values, $p * 2, 1 );
            }

            $cgicookie->value( \@values );
        }

        my $required = $c->config->{hashedcookies}->{required};
        if ( not $digest and not $required ) {
            $c->log->debug("HashedCookies skipping cookie:      $name")
              if $c->debug;
            $hmac->reset;
            next;
        }

        # now, we either have no digest but one is required,
        # or we have a digest that needs checking

        # $c->log->debug( "HashedCookies is hashing: ". $cgicookie->as_string );
        $hmac->add( $cgicookie->as_string );
        my $result = $hmac->hexdigest;    # WARNING!!! $hmac has now been RESET

         # $c->log->debug( "HashedCookies retrieved digest: '$digest'" )
         #   if $c->debug;
         # $c->log->debug( "HashedCookies generated digest: '$result'" )
         #   if $c->debug;

        if ( $digest eq $result ) {
            $c->log->debug("HashedCookies adding valid cookie:  $name")
              if $c->debug;
            ++$c->request->validhashedcookies->{$name};
        }
        else {
            $c->log->debug("HashedCookies found INVALID cookie: $name")
              if $c->debug;
            ++$c->request->invalidhashedcookies->{$name};
        }

        $hmac->reset;
    }

    return $c;
}


# check for illegal parameters in cookie set by App, and raise hell if found
sub finalize {
    # need to hook in here, early in the finalize sequence, because Catalyst has
    # been written to check $c->error *before* it goes on to call finalize_headers
    # and hence finalize_cookies.
    my $c = shift;

    while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {

        # see finalize_cookies hook, below, for comments
        my $cgicookie = CGI::Simple::Cookie->new(
            -name  => $name,
            -value => $cookie->{value},
        );

        if (defined $cgicookie->value) {
            foreach ( @{ [ $cgicookie->value ] } ) {
                if (defined and m/^_hashedcookies_/) {
                    $c->log->debug('HashedCookies setting $c->error, illegal cookie param from App')
                        if $c->debug;
                    $c->error('Attempted use of restricted ("_hashedcookies_*") value in cookie');

                    # don't want to have dud cookie sent to client browser
                    delete $c->response->cookies->{$cgicookie->name};
                }
            }
        }
    }

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


# alter all Cookie Values to include a hash
sub finalize_cookies {
    my $c = shift;

    my $hasher = 'Digest::HMAC_'. $c->config->{hashedcookies}->{algorithm};
    my $hmac   = $hasher->new( $c->config->{hashedcookies}->{key} );

    while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {

        # creating a tmp CGI::Simple::Cookie is handy for as_string,
        # and also because we can consistenly use ->value as a list
        # 
        # only -name and -value are used because this is what CGI::Simple::Cookie->parse()
        # will pass back from an HTTP header - prepare_cookies needs identical hash
        my $cgicookie = CGI::Simple::Cookie->new(
            -name  => $name,
            -value => $cookie->{value},
        );

        # $c->log->debug( "HashedCookies is hashing: ". $cgicookie->as_string );
        $hmac->add( $cgicookie->as_string );

        # make sure that cookie ->value can be coerced into a hash upon retrieval
        if ( scalar @{ [ $cgicookie->value ] } % 2 == 1 ) {
            $cookie->{value} = [
                '_hashedcookies_padding' => @{ [ $cgicookie->value ] },
                '_hashedcookies_digest' => $hmac->hexdigest,
            ];
        }
        else {
            $cookie->{value} = [
                @{ [ $cgicookie->value ] },
                '_hashedcookies_digest' => $hmac->hexdigest,
            ];
        }

        $hmac->reset;
    }

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

# ABSTRACT: Tamper-resistant HTTP Cookies


1;

__END__