File Coverage

blib/lib/Dancer/Session/DBIC.pm

Criterion	Covered	Total	%
statement	66	91	72.5
branch	11	26	42.3
condition	3	6	50.0
subroutine	16	18	88.8
pod	4	4	100.0
total	100	145	68.9

package Dancer::Session::DBIC;

=head1 NAME

Dancer::Session::DBIC - DBIx::Class session engine for Dancer

=head1 VERSION

0.004

=head1 DESCRIPTION

This module implements a session engine for Dancer by serializing the session,
and storing it in a database via L. The default serialization method is L,
though one can specify any serialization format you want. L and L are
viable alternatives.

JSON was chosen as the default serialization format, as it is fast, terse, and portable.

=head1 SYNOPSIS

Example configuration:

    session: "DBIC"
    session_options:
      dsn:      "DBI:mysql:database=testing;host=127.0.0.1;port=3306" # DBI Data Source Name
      schema_class:    "Interchange6::Schema"  # DBIx::Class schema
      user:     "user"      # Username used to connect to the database
      pass: "password"  # Password to connect to the database
      resultset: "MySession" # DBIx::Class resultset, defaults to Session
      id_column: "my_session_id" # defaults to sessions_id
      data_column: "my_session_data" # defaults to session_data

In conjunction with L, you can simply use the schema
object provided by this plugin in your application:

    set session_options => {schema => schema};

Custom serializer / deserializer can be specified as follows:

    set 'session_options' => {
        schema       => schema,
        serializer   => sub { YAML::Dump(@_); },
        deserializer => sub { YAML::Load(@_); },
    };

=head1 SESSION EXPIRATION

A timestamp field that updates when a session is updated is recommended, so you can expire sessions server-side as well as client-side.

This session engine will not automagically remove expired sessions on the server, but with a timestamp field as above, you should be able to to do this manually.

=cut

use strict;
use parent 'Dancer::Session::Abstract';

use Dancer qw(:syntax !load);
use DBIx::Class;
use Try::Tiny;
use Module::Load;
use Scalar::Util qw(blessed);

our $VERSION = '0.004';

my %dbic_handles;

=head1 METHODS

=head2 create()

Creates a new session. Returns the session object.

=cut

sub create {
    return Dancer::Session::DBIC->new->flush;
}


=head2 flush()

Write the session to the database. Returns the session object.

=cut

sub flush {
    my $self = shift;
    my $handle = $self->_dbic;

    my %session_data = ($handle->{id_column} => $self->id,
                        $handle->{data_column} => $self->_serialize,
                       );

    my $session = $self->_rset->update_or_create(\%session_data);

    return $self;
}

=head2 retrieve($id)

Look for a session with the given id.

Returns the session object if found, C if not. Logs a debug-level warning
if the session was found, but could not be deserialized.

=cut

sub retrieve {
    my ($self, $session_id) = @_;
    my $session_object;

    $session_object = $self->_rset->find($session_id);

    # Bail early if we know we have no session data at all
    if (!defined $session_object) {
        debug "Could not retrieve session ID: $session_id";
        return;
    }

    my $session_data = $session_object->session_data;

    # No way to check that it's valid JSON other than trying to deserialize it
    my $session = try {
        $self->_deserialize($session_data);
    } catch {
        debug "Could not deserialize session ID: $session_id - $_";
        return;
    };

    bless $session, __PACKAGE__ if $session;
}


=head2 destroy()

Remove the current session object from the database.

=cut

sub destroy {
    my $self = shift;

    if (!defined $self->id) {
        debug "No session ID passed to destroy method";
        return;
    }

    $self->_rset->find($self->id)->delete;
}

# Creates and connects schema

sub _dbic {
    my $self = shift;

    # To be fork safe and thread safe, use a combination of the PID and TID (if
    # running with use threads) to make sure no two processes/threads share
    # handles.  Implementation based on DBIx::Connector by David E. Wheeler.
    my $pid_tid = $$;
    $pid_tid .= '_' . threads->tid if $INC{'threads.pm'};

    # OK, see if we have a matching handle
    my $handle = $dbic_handles{$pid_tid};

    if ($handle->{schema}) {
        return $handle;
    }

    my $settings = setting('session_options');

    # Prefer an active schema over a schema class.
    if (defined $settings->{schema}) {
        if (blessed $settings->{schema}) {
            $handle->{schema} = $settings->{schema};
        }
        else {
            $handle->{schema} = $settings->{schema}->();
        }
    }
    elsif (! defined $settings->{schema_class}) {
        die "No schema class defined.";
    }
    else {
        my $schema_class = $settings->{schema_class};

        $handle->{schema} = $self->_load_schema_class($schema_class,
                                                      $settings->{dsn},
                                                      $settings->{user},
                                                      $settings->{pass});
    }

    $handle->{resultset} = $settings->{resultset} || 'Session';
    $handle->{id_column} = $settings->{id_column} || 'sessions_id';
    $handle->{data_column} = $settings->{data_column} || 'session_data';

    $dbic_handles{$pid_tid} = $handle;

    return $handle;
}

# Returns specific resultset
sub _rset {
    my ($self, $name) = @_;

    my $handle = $self->_dbic;

    return $handle->{schema}->resultset($handle->{resultset});
}

# Loads schema class
sub _load_schema_class {
    my ($self, $schema_class, @conn_info) = @_;
    my ($schema_object);

    if ($schema_class) {
        $schema_class =~ s/-/::/g;
        eval { load $schema_class };
        die "Could not load schema_class $schema_class: $@" if $@;
        $schema_object = $schema_class->connect(@conn_info);
    } else {
        my $dbic_loader = 'DBIx::Class::Schema::Loader';
        eval { load $dbic_loader };
        die "You must provide a schema_class option or install $dbic_loader."
            if $@;
        $dbic_loader->naming('v7');
        $schema_object = DBIx::Class::Schema::Loader->connect(@conn_info);
    }

    return $schema_object;
}

# Default Serialize method
sub _serialize {
    my $self = shift;
    my $settings = setting('session_options');

    if (defined $settings->{serializer}) {
        return $settings->{serializer}->({%$self});
    }

    # A session is by definition ephemeral - Store it compactly
    # This is the Dancer function, not from JSON.pm
    return to_json({%$self}, { pretty => 0 });
}


# Default Deserialize method
sub _deserialize {
    my ($self, $json) = @_;
    my $settings = setting('session_options');

    if (defined $settings->{deserializer}) {
        return $settings->{deserializer}->($json);
    }

    # This is the Dancer function, not from JSON.pm
    return from_json($json, { utf8 => 0});
}

=head1 SEE ALSO

L, L

=head1 AUTHOR

Stefan Hornburg (Racke)

=head1 ACKNOWLEDGEMENTS

Based on code from L written by James Aitken
and code from L written by Naveed Massjouni.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) Stefan Hornburg.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut


1;