File Coverage

blib/lib/Dancer2/Core/Role/SessionFactory.pm

Criterion	Covered	Total	%
statement	96	103	93.2
branch	20	30	66.6
condition	4	9	44.4
subroutine	20	22	90.9
pod	10	12	83.3
total	150	176	85.2

package Dancer2::Core::Role::SessionFactory;
# ABSTRACT: Role for session factories
$Dancer2::Core::Role::SessionFactory::VERSION = '2.0.1';
use Moo::Role;
with 'Dancer2::Core::Role::Engine';

use Carp 'croak';
use Dancer2::Core::Session;
use Dancer2::Core::Types;
use Digest::SHA 'sha1';
use List::Util 'shuffle';
use MIME::Base64 'encode_base64url';
use Module::Runtime 'require_module';
use Ref::Util qw< is_ref is_arrayref is_hashref >;

sub hook_aliases { +{} }
sub supported_hooks {
    qw/
      engine.session.before_retrieve
      engine.session.after_retrieve

      engine.session.before_create
      engine.session.after_create

      engine.session.before_change_id
      engine.session.after_change_id

      engine.session.before_destroy
      engine.session.after_destroy

      engine.session.before_flush
      engine.session.after_flush
      /;
}

sub _build_type {
    'SessionFactory';
}    # XXX vs 'Session'?  Unused, so I can't tell -- xdg

has log_cb => (
    is      => 'ro',
    isa     => CodeRef,
    default => sub { sub {1} },
);

has cookie_name => (
    is      => 'ro',
    isa     => Str,
    default => sub {'dancer.session'},
);

has cookie_domain => (
    is        => 'ro',
    isa       => Str,
    predicate => 1,
);

has cookie_path => (
    is      => 'ro',
    isa     => Str,
    default => sub {"/"},
);

has cookie_duration => (
    is        => 'ro',
    isa       => Str,
    predicate => 1,
);

has session_duration => (
    is        => 'ro',
    isa       => Num,
    predicate => 1,
);

has is_secure => (
    is      => 'rw',
    isa     => Bool,
    default => sub {0},
);

has is_http_only => (
    is      => 'rw',
    isa     => Bool,
    default => sub {1},
);

has cookie_same_site => (
    is        => 'ro',
    isa       => Str,
    predicate => 1,
    coerce    => sub { ucfirst $_[0] },
);

sub create {
    my ($self) = @_;

    my %args = ( id => $self->generate_id, );

    $args{expires} = $self->cookie_duration
      if $self->has_cookie_duration;

    my $session = Dancer2::Core::Session->new(%args);

    $self->execute_hook( 'engine.session.before_create', $session );

    # XXX why do we _flush now?  Seems unnecessary -- xdg, 2013-03-03
    eval { $self->_flush( $session->id, $session->data ) };
    croak "Unable to create a new session: $@"
      if $@;

    $self->execute_hook( 'engine.session.after_create', $session );
    return $session;
}

{
    my $COUNTER     = 0;
    my $CPRNG_AVAIL = eval { require_module('Math::Random::ISAAC::XS'); 1; } &&
                      eval { require_module('Crypt::URandom'); 1; };

    # don't initialize until generate_id is called so the ISAAC algorithm
    # is seeded after any pre-forking
    my $CPRNG;

    # prepend epoch seconds so session ID is roughly monotonic
    sub generate_id {
        my ($self) = @_;

        if ($CPRNG_AVAIL) {
            $CPRNG ||= Math::Random::ISAAC::XS->new(
                map { unpack( "N", Crypt::URandom::urandom(4) ) } 1 .. 256 );

            # include $$ to ensure $CPRNG wasn't forked by accident
            return encode_base64url(
                pack(
                    "N6",
                    time,          $$,            $CPRNG->irand,
                    $CPRNG->irand, $CPRNG->irand, $CPRNG->irand
                )
            );
        }
        else {
            my $seed = (
                rand(1_000_000_000)   # a random number
                  . __FILE__          # the absolute path as a secret key
                  . $COUNTER++        # impossible to have two consecutive dups
                  . $$         # the process ID as another private constant
                  . "$self"    # the instance's memory address for more entropy
                  . join( '', shuffle( 'a' .. 'z', 'A' .. 'Z', 0 .. 9 ) )

                  # a shuffled list of 62 chars, another random component
            );
            return encode_base64url( pack( "Na*", time, sha1($seed) ) );
        }

    }
}

sub validate_id {
    my ($self, $id) = @_;
    return $id =~ m/^[A-Za-z0-9_\-~]+$/;
}

requires '_retrieve';

sub retrieve {
    my ( $self, %params ) = @_;
    my $id = $params{id};

    $self->execute_hook( 'engine.session.before_retrieve', $id );

    my $data;
    # validate format of session id before attempt to retrieve
    my $rc = eval {
        $self->validate_id($id) && ( $data = $self->_retrieve($id) );
    };
    croak "Unable to retrieve session with id '$id'"
      if ! $rc;

    my %args = ( id => $id, );

    $args{data} = $data
      if $data and is_hashref($data);

    $args{expires} = $self->cookie_duration
      if $self->has_cookie_duration;

    my $session = Dancer2::Core::Session->new(%args);

    $self->execute_hook( 'engine.session.after_retrieve', $session );
    return $session;
}

# XXX eventually we could perhaps require '_change_id'?

sub change_id {
    my ( $self, %params ) = @_;
    my $session = $params{session};
    my $old_id  = $session->id;

    $self->execute_hook( 'engine.session.before_change_id', $old_id );

    my $new_id = $self->generate_id;
    $session->id( $new_id );

    eval { $self->_change_id( $old_id, $new_id ) };
    croak "Unable to change session id for session with id $old_id: $@"
      if $@;

    $self->execute_hook( 'engine.session.after_change_id', $new_id );
}

requires '_destroy';

sub destroy {
    my ( $self, %params ) = @_;
    my $id = $params{id};
    $self->execute_hook( 'engine.session.before_destroy', $id );

    eval { $self->_destroy($id) };
    croak "Unable to destroy session with id '$id': $@"
      if $@;

    $self->execute_hook( 'engine.session.after_destroy', $id );
    return $id;
}

requires '_flush';

sub flush {
    my ( $self, %params ) = @_;
    my $session = $params{session};
    $self->execute_hook( 'engine.session.before_flush', $session );

    eval { $self->_flush( $session->id, $session->data ) };
    croak "Unable to flush session: $@"
      if $@;

    $self->execute_hook( 'engine.session.after_flush', $session );
    return $session->id;
}

sub set_cookie_header {
    my ( $self, %params ) = @_;
    $params{response}->push_header(
        'Set-Cookie',
        $self->cookie( session => $params{session} )->to_header
    );
}

sub cookie {
    my ( $self, %params ) = @_;
    my $session = $params{session};
    croak "cookie() requires a valid 'session' parameter"
      unless is_ref($session) && $session->isa("Dancer2::Core::Session");

    my %cookie = (
        value     => $session->id,
        name      => $self->cookie_name,
        path      => $self->cookie_path,
        secure    => $self->is_secure,
        http_only => $self->is_http_only,
    );

    $cookie{same_site} = $self->cookie_same_site
      if $self->has_cookie_same_site;

    $cookie{domain} = $self->cookie_domain
      if $self->has_cookie_domain;

    if ( my $expires = $session->expires ) {
        $cookie{expires} = $expires;
    }

    return Dancer2::Core::Cookie->new(%cookie);
}

requires '_sessions';

sub sessions {
    my ($self) = @_;
    my $sessions = $self->_sessions;

    croak "_sessions() should return an array ref"
      unless is_arrayref($sessions);

    return $sessions;
}

1;

__END__