File Coverage

blib/lib/Dancer/Session/DBIC.pm

Criterion	Covered	Total	%
statement	66	93	70.9
branch	12	30	40.0
condition	3	6	50.0
subroutine	16	18	88.8
pod	4	4	100.0
total	101	151	66.8

package Dancer::Session::DBIC;

=head1 NAME

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

=head1 VERSION

0.005

=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, either by
providing the name of the schema used by the plugin in the config:

    session_options:
        schema: default

Or by passing the schema object directly in the code:

    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.

=head1 RESULT CLASS EXAMPLE

This result class would work as-is with the default values of C.
It uses L to auto-set the C
and C timestamps.

    package MySchema::Result::Session;

    use strict;
    use warnings;

    use base 'DBIx::Class::Core';

    __PACKAGE__->load_components(qw(TimeStamp));

    __PACKAGE__->table('sessions');

    __PACKAGE__->add_columns(
        sessions_id => {
            data_type => 'varchar', size => 255
        },
        session_data => {
            data_type => 'text'
        },
        created => {
            data_type => 'datetime', set_on_create => 1
        },
        last_modified => {
            data_type => 'datetime', set_on_create => 1, set_on_update => 1
        },
    );

    __PACKAGE__->set_primary_key('sessions_id');

    1;

=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.005';

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 ( my $schema = $settings->{schema}) {
        if (blessed $schema) {
            $handle->{schema} = $schema;
        }
        elsif( ref $schema ) {
            $handle->{schema} = $schema->();
        }
        else {
            die "can't use named schema: Dancer::Plugin::DBIC not loaded\n"
                unless $Dancer::Plugin::DBIC::VERSION;
            $handle->{schema} = Dancer::Plugin::DBIC::schema($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, convert_blessed => 1 });
}


# 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.

Enhancements provided by:

Yanick Champoux (GH #6, #7).
Peter Mottram (GH #5).

=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;