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) 2014 by BURNERSK <burnersk@cpan.org>.
#
# This is free software, licensed under:
#
#   The MIT (X11) License
#

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

use Carp qw( carp croak );
use Dancer2::Core::Types qw( Undef AnyOf 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     => AnyOf [ Undef, $TYPE_SERIALIZATIONOBJECT ],
  builder => sub {
    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     => AnyOf [ InstanceOf ['Redis'], InstanceOf ['t::TestApp::RedisMock'] ],
  builder => sub {
    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};

    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 { $_ =~ s/^$key_pattern(.*)$/$1/r } @keys ];
}

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


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Dancer2::Session::Redis - Perl Dancer2 session provider for storing session data within key-value-store Redis.

=head1 VERSION

version 0.002

=head1 SYNOPSIS

In your I<config.yml>:

    engines:
      session:
        Redis:
          # Browser cookie key for session id.
          cookie_name: "session_id"
          # Browser cookie expiration timeout (since last visit).
          cookie_duration: 86400
          # Redis session expiration timeout (since last visit).
          session_duration: 86400
          # Browser only sends cookie over https connection when set to true.
          is_secure: 0
          # Browser do not pass session cookie to JavaScript when set to true.
          is_http_only: 0
          # if you use TCP/IP:
          redis_server: "localhost:6379"
          # if you use UNIX/Linux sockets:
          redis_sock: "/path/to/sock"
          # (optional) Redis password used with auth:
          redis_password: "Very secure password 123!"
          # (optional) Reconnect up to 60 seconds (reconnect) every 5000 milliseconds (every):
          redis_reconnect: 60
          redis_every: 5000
          # (optional) Redis connection name (NOT the Redis database ID):
          redis_name: "my_connection_name"
          # (optional) Function called on Redis connect:
          redis_on_connect: "MyDancer2App::redis_on_connect"
          # (optional) Use serialization for storing values other than simple scalars with Redis:
          redis_serialization:
            # Use Sereal as serialization module:
            module: "Dancer2::Session::Redis::Serialization::Sereal"
            # Serialization module configuration:
            # Use snappy compression
            compression: "snappy"

=head1 DESCRIPTION

This L<Perl Dancer2|Dancer2> session provider for storing session data
within key-value-store Redis.

It uses the L<Redis> module to communicate internally with the
Redis server. It also provides serialization features to store values which
are more than just simple scalars (I<strings>). By default there is no
serialization used.

=head2 SEREAL

In order to use the supplied
L<Sereal broker|Dancer2::Session::Redis::Serialization::Sereal> you have to
install L<Sereal::Decoder> and L<Sereal::Encoder>. Both modules listed as
runtime recommends with Dancer2::Session::Redis.

=head1 DEPENDENCIES

For some reason (need to be identified) Dancer2::Session::Redis requires
Perl v5.13.2. Perl 5.12 and 5.10 aren't testet. They might work or not.

=head1 SEE ALSO

=over

=item L<Dancer2>

=item L<Redis>

=item L<Sereal>

=back

=head1 AUTHOR

BURNERSK <burnersk@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2014 by BURNERSK <burnersk@cpan.org>.

This is free software, licensed under:

  The MIT (X11) License

=cut
