File Coverage

blib/lib/Dancer/Session/Abstract.pm

Criterion	Covered	Total	%
statement	58	63	92.0
branch	12	20	60.0
condition			n/a
subroutine	20	21	95.2
pod	12	14	85.7
total	102	118	86.4

package Dancer::Session::Abstract;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: abstract class for session engine
$Dancer::Session::Abstract::VERSION = '1.3514_04'; # TRIAL
$Dancer::Session::Abstract::VERSION = '1.351404';
use strict;
use warnings;
use Carp;

use base 'Dancer::Engine';

use Dancer::Config 'setting';
use Dancer::Cookies;
use File::Spec;

__PACKAGE__->attributes('id');

# args: ($class, $id)
# receives a session id and should return a session object if found, or undef
# otherwise.
sub retrieve {
    confess "retrieve not implemented";
}

# args: ($class)
# create a new empty session, flush it and return it.
sub create {
    confess "create not implemented";
}

# args: ($self)
# write the (serialized) current session to the session storage
sub flush {
    confess "flush not implemented";
}

# args: ($self)
# remove the session from the session storage
sub destroy {
    confess "destroy not implemented";
}

# does nothing in most cases (exception is YAML)
sub reset {
    return;
}

# if subclass overrides to true, flush will not be called after write
# and subclass or application must call flush (perhaps in an after hook)
sub is_lazy { 0 };

# This is the default constructor for the session object, the only mandatory
# attribute is 'id'. The whole object should be serialized by the session
# engine.
# If you override this constructor, remember to call $self->SUPER::init() so
# that the session ID is still generated.
sub init {
    my ($self) = @_;
    if (!$self->id) {
        $self->id(build_id());
    }
}

# this method can be overwritten in any Dancer::Session::* module
sub session_name {
    setting('session_name') || 'dancer.session';
}

# May be overriden if session key value pairs aren't stored in the
# session object's hash
sub get_value {
    my ( $self, $key ) = @_;
    return $self->{$key};
}

# May be overriden if session key value pairs aren't stored in the
# session object's hash
sub set_value {
    my ( $self, $key, $value ) = @_;
    $self->{$key} = $value;
}


# Methods below this line should not be overloaded.

# we try to make the best random number
# with native Perl 5 code.
# to rebuild a session id, an attacker should know:
# - the running PID of the server
# - the current timestamp of the time it was built
# - the path of the installation directory
# - guess the correct number between 0 and 1000000000
# - should be able to reproduce that 3 times
sub build_id {
    my $session_id = "";
    foreach my $seed (rand(1000), rand(1000), rand(1000)) {
        my $c = 0;
        $c += ord($_) for (split //, File::Spec->rel2abs(File::Spec->curdir));
        my $current = int($seed * 1000000000) + time + $$ + $c;
        $session_id .= $current;
    }
    return $session_id;
}

sub read_session_id {
    my ($class) = @_;

    my $name = $class->session_name();
    my $c    = Dancer::Cookies->cookies->{$name};
    return unless defined $c;
    if ($class->validate_session_id($c->value)) {
        return $c->value;
    } else {
        warn "Rejecting invalid session ID ". $c->value;
        return;
    }
}

# Validate session ID (base64 chars plus hyphen by default) to avoid potential
# issues, e.g. if the ID is used insecurely elsewhere.  If a session provider
# expects more unusual IDs, it can override this class method with one that
# validates according to that provider's expectation of how a session ID should
# look.
sub validate_session_id {
    my ($class, $id) = @_;
    return $id =~ m{^[A-Za-z0-9_\-~]+$};
}

sub write_session_id {
    my ($class, $id) = @_;

    my $name = $class->session_name();

    # If we've already pushed the appropriate cookie to the response, then we
    # don't need to do any more
    if (my $cookie = Dancer::Cookies->cookie($name)) {
        if ($cookie eq $id) {
            return;
        }
    }

    my %cookie = (
        name   => $name,
        value  => $id,
        domain => setting('session_domain'),
        secure => setting('session_secure'),
        http_only => defined(setting("session_is_http_only")) ?
                     setting("session_is_http_only") : 1,
        same_site => defined(setting("session_same_site")) ?
                    setting("session_same_site") : 'None',
    );
    if (my $expires = setting('session_expires')) {
        # It's # of seconds from the current time
        # Otherwise just feed it through.
        $expires = Dancer::Cookie::_epoch_to_gmtstring(time + $expires) if $expires =~ /^\d+$/;
        $cookie{expires} = $expires;
    }

    my $c = Dancer::Cookie->new(%cookie);
    Dancer::Cookies->set_cookie_object($name => $c);
}

1;

__END__