File Coverage

blib/lib/HTTP/Session2/Base.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	12	12	100.0
condition			n/a
subroutine	20	20	100.0
pod	5	11	45.4
total	99	105	94.2

package HTTP::Session2::Base;
use strict;
use warnings;
use utf8;
use 5.008_001;

use Digest::SHA;
use Carp ();

use Mouse;

has env => (
    is => 'ro',
    required => 1,
);

has session_cookie => (
    is => 'ro',
    lazy => 1,
    default => sub {
        +{
            httponly => 1,
            secure   => 0,
            name     => 'hss_session',
            path     => '/',
        },
    },
    # Need shallow copy
    trigger => sub {
        my $self = shift;
        $self->{session_cookie} = +{%{$self->{session_cookie}}};
    },
);

has xsrf_cookie => (
    is => 'ro',
    lazy => 1,
    default => sub {
        # httponly must be false. AngularJS need to read this value.
        +{
            httponly => 0,
            secure   => 0,
            name     => 'XSRF-TOKEN',
            path     => '/',
        },
    },
    # Need shallow copy
    trigger => sub {
        my $self = shift;
        $self->{xsrf_cookie} = +{%{$self->{xsrf_cookie}}};
    },
);

has hmac_function => (
    is => 'ro',
    default => sub { \&Digest::SHA::sha1_hex },
);

has is_dirty => (
    is => 'rw',
    default => sub { 0 },
);

has is_fresh => (
    is => 'rw',
    default => sub { 0 },
);

has necessary_to_send => (
    is => 'rw',
    default => sub { 0 },
);

has secret => (
    is => 'ro',
    required => 1,
    trigger => sub {
        my ($self, $secret) = @_;
        if (length($secret) < 20) {
            Carp::cluck("Secret string too short");
        }
    },
);

no Mouse;

sub _data {
    my $self = shift;
    unless ($self->{_data}) {
        $self->load_or_create();
    }
    $self->{_data};
}

sub id {
    my $self = shift;
    unless ($self->{id}) {
        $self->load_or_create();
    }
    $self->{id};
}

sub load_or_create {
    my $self = shift;
    $self->load_session() || $self->create_session();
}

sub load_session   { die "Abstract method" }
sub create_session { die "Abstract method" }

sub set {
    my ($self, $key, $value) = @_;
    $self->_data->{$key} = $value;
    $self->is_dirty(1);
}

sub get {
    my ($self, $key) = @_;
    $self->_data->{$key};
}

sub remove {
    my ($self, $key) = @_;
    $self->is_dirty(1);
    delete $self->_data->{$key};
}

sub validate_xsrf_token {
    my ($self, $token) = @_;

    # If user does not have any session data, user don't need a XSRF protection.
    return 1 unless %{$self->_data};
    return 0 unless defined $token;
    return 1 if $token eq $self->xsrf_token;
    return 0;
}

sub finalize_plack_response {
    my ($self, $res) = @_;

    my @cookies = $self->finalize();
    while (my ($name, $cookie) = splice @cookies, 0, 2) {
        my $baked = Cookie::Baker::bake_cookie( $name, $cookie );
        $res->headers->push_header('Set-Cookie' => $baked);
    }
}

sub finalize_psgi_response {
    my ($self, $res) = @_;
    my @cookies = $self->finalize();
    while (my ($name, $cookie) = splice @cookies, 0, 2) {
        my $baked = Cookie::Baker::bake_cookie( $name, $cookie );
        push @{$res->[1]}, (
            'Set-Cookie' => $baked,
        );
    }
}

sub finalize { die "Abstract method" }

1;
__END__