File Coverage

blib/lib/Dancer2/Session/Redis.pm

Criterion	Covered	Total	%
statement	54	83	65.0
branch	8	48	16.6
condition	0	18	0.0
subroutine	14	17	82.3
pod			n/a
total	76	166	45.7

package Dancer2::Session::Redis;
use strictures 1;
# ABSTRACT: Perl Dancer2 session provider for storing session data within key-value-store Redis.
#
# This file is part of Dancer2-Session-Redis
#
# This software is Copyright (c) 2016 by BURNERSK .
#
# This is free software, licensed under:
#
#   The MIT (X11) License
#

BEGIN {
  our $VERSION = '0.006'; # VERSION: generated by DZP::OurPkgVersion
}

use Carp qw( carp croak );
use Types::Standard qw( Maybe Undef InstanceOf );
use Moo;
use Redis;
use Safe::Isa;
use Try::Tiny;
use Type::Tiny;

with 'Dancer2::Core::Role::SessionFactory';


############################################################################

my $TYPE_SERIALIZATIONOBJECT = Type::Tiny->new(
  name       => 'SerializationObject',
  constraint => sub { $_->$_call_if_object( 'does' => 'Dancer2::Session::Redis::SerializationRole' ) },
  message => sub { qq{$_ does not consume a SerializationRole} },
);

has redis_server        => ( is => 'ro' );
has redis_sock          => ( is => 'ro' );
has redis_password      => ( is => 'ro' );
has redis_reconnect     => ( is => 'ro' );
has redis_on_connect    => ( is => 'ro' );
has redis_every         => ( is => 'ro' );
has redis_debug         => ( is => 'ro' );
has redis_name          => ( is => 'ro' );
has redis_key           => ( is => 'ro', default => 'session:%s' );
has redis_serialization => ( is => 'ro' );
has redis_test_mock     => ( is => 'ro', default => sub { $ENV{DANCER_SESSION_REDIS_TEST_MOCK} || 0 } );

has _serialization => (
  is      => 'lazy',
  isa     => Maybe [ $TYPE_SERIALIZATIONOBJECT ],
);

sub _build__serialization {
    my ($dsl1) = @_;
    my $serialization;
    return unless $dsl1->redis_serialization;

    # Setup serialization.
    if ( my $serialization_module = delete $dsl1->redis_serialization->{module} ) {
      $serialization_module =~ s/^/Dancer2::Session::Redis::Serialization::/
        if $serialization_module !~ m/^Dancer2::Session::Redis::Serialization::/;
      croak qq{Invalid serialization module: $serialization_module}
        if $serialization_module !~ m/^Dancer2::Session::Redis::Serialization::[a-zA-Z][a-zA-Z0-9_]*$/;
      try {
        eval "require $serialization_module" or croak $@;
        $serialization = "$serialization_module"->new( %{ $dsl1->redis_serialization } );
      }
      catch {
        croak(qq{Unable to set up serialization '$serialization_module': $_});
      };
    }
    return $serialization;
}

has _redis => (
  is      => 'lazy',
  isa     => InstanceOf ['Redis'] | InstanceOf ['t::TestApp::RedisMock'],
);

sub _build__redis {
    my ($dsl2) = @_;

    if ( $dsl2->redis_test_mock ) {
      require t::TestApp::RedisMock;
      return t::TestApp::RedisMock->new;
    }

    # Build Redis->new settings.
    my %opts = (
      ( $dsl2->redis_server    ? ( server    => $dsl2->redis_server )    : () ),
      ( $dsl2->redis_sock      ? ( sock      => $dsl2->redis_sock )      : () ),
      ( $dsl2->redis_password  ? ( password  => $dsl2->redis_password )  : () ),
      ( $dsl2->redis_reconnect ? ( reconnect => $dsl2->redis_reconnect ) : () ),
      ( $dsl2->redis_every     ? ( every     => $dsl2->redis_every )     : () ),
      ( $dsl2->redis_name      ? ( name      => $dsl2->redis_name )      : () ),
      ( $dsl2->redis_debug     ? ( debug     => $dsl2->redis_debug )     : () ),
    );

    # Cleanup settings.
    delete $opts{server} if $opts{sock};   # prefer UNIX/Linux sockets.
    delete $opts{sock}   if $opts{server};
    delete $opts{password} if exists $opts{password} && ( !defined $opts{password} || $opts{password} eq '' );
    delete $opts{name} unless $opts{name};

    # Validate reconnect settings.
    if ( ( exists $opts{reconnect} || exists $opts{every} ) && ( !$opts{reconnect} || !$opts{every} ) ) {
      croak(q{Incomplete Redis configuration for 'reconnect' and 'every', skipping...});
      delete $opts{reconnect};
      delete $opts{every};
    }

    # Validate on_connect settings.
    if ( $dsl2->redis_on_connect ) {
      if ( !$dsl2->redis_on_connect ) {
        croak(q{Invalid Redis configuration for 'on_connect', skipping...});
      }
      else {
        $opts{on_connect} = $dsl2->redis_on_connect;
      }
    }

    # Validate connection settings.
    croak(q{Incomplete Redis configuration: required is either 'server' or 'sock'})
      if !$opts{server} && !$opts{sock};

    croak(q{Incomplete Redis configuration: session_duration is required})
      unless $dsl2->has_session_duration;

    return Redis->new(%opts);
}

############################################################################

# Get session data.
sub _retrieve {
  my ( $dsl, $session_id ) = @_;
  my $key = sprintf $dsl->redis_key, $session_id;
  my $data = $dsl->_redis->get($key);
  if ( my $serialization = $dsl->_serialization ) {
    $data = $serialization->decode($data);
  }
  $dsl->_redis->expire( $key => $dsl->session_duration );
  return $data;
}

# Set session data.
sub _flush {
  my ( $dsl, $session_id, $data ) = @_;
  my $key = sprintf $dsl->redis_key, $session_id;
  if ( my $serialization = $dsl->_serialization ) {
    $data = $serialization->encode($data);
  }
  $dsl->_redis->set( $key => $data );
  $dsl->_redis->expire( $key => $dsl->session_duration );
  return;
}

# Delete session data.
sub _destroy {
  my ( $dsl, $session_id ) = @_;
  my $key = sprintf $dsl->redis_key, $session_id;
  $dsl->_redis->del($key);
  return;
}

# Get all session ids.
sub _sessions {
  my ($dsl) = @_;
  my $key = sprintf $dsl->redis_key, '*';
  my $key_pattern = quotemeta sprintf $dsl->redis_key, '';
  my @keys = $dsl->_redis->keys($key);
  return [ map { my $a = $_; $a =~ s/^$key_pattern(.*)$/$1/; $a } @keys ];
}

############################################################################


1;

__END__