File Coverage

blib/lib/Dancer2/Session/DatabasePlugin.pm

Criterion	Covered	Total	%
statement	47	96	48.9
branch	0	16	0.0
condition	0	3	0.0
subroutine	21	31	67.7
pod	1	17	5.8
total	69	163	42.3

package Dancer2::Session::DatabasePlugin;

use Modern::Perl;
use Moo;
use Data::Dumper;
use Dancer2::Core::Types;
use Dancer2::Plugin::Database;
use Carp qw(croak);
use Ref::Util qw(is_plain_hashref);
use Storable qw(nfreeze thaw);
with 'Dancer2::Core::Role::SessionFactory';
our $VERSION="1.0014";

our $HANDLE_SQL_STRING=\&stub_function;
our $HANDLE_EXECUTE=\&handle_execute;
sub stub_function { }

sub handle_execute {
  my ($name,$sth,@args)=@_;
  $sth->execute(@args);
}

our $CACHE={};

our $FREEZE=\&nfreeze;
our $THAW=\&thaw;

has no_create=>(
  ias=>HashRef,
  is=>'ro',
  default=>sub { return {}},
);

has cache =>(
  isa=>Bool,
  is=>'rw',
  default=>0,
);

has cache_sth=>(
  isa=>Bool,
  is=>'ro',
  default=>0,
);

has sth_cache=>(
  isa=>HashRef,
  default=>sub { $CACHE },
  is=>'ro',
);

has connection=>(
  isa=>Str,
  is=>'rw',
  default=>'foo',
  required=>1,
);

has session_table=>(
  isa=>Str,
  required=>1,
  is=>'rw',
  default=>'SESSIONS',
);

has id_column=>(
  isa=>Str,
  required=>1,
  is=>'rw',
  default=>'SESSION_ID',
);

has data_column=>(
  isa=>Str,
  required=>1,
  is=>'rw',
  default=>'SESSION_DATA',
);

has dbh=>(
  is=>'rw',
);

=head1 NAME

Dancer2::Session::DatabasePlugin - Dancer2 Session implementation for databases

=head1 SYNOPSIS

  use Dancer2;
  use Dancer2::Plugin::Database;
  use Dancer2::Plugin::SessionDatabase;

=head1 DESCRIPTION

This class extends Dancer2::Core::Role::SessionFactory, and makes use of Dancer2::Plugin::Database for managing database connections.

=head1 CONFIGURATION

The session should be set to "DatabasePlugin" in order to use this session engine in your Dancer2 Application.

  session: "DatabasePlugin"

  engines:
    session:
      DatabasePlugin:
        cache: 0 # default 0, when 1 statement handles are cached
        connection: "foo"
        session_table: "SESSIONS"
        id_column:     "SESSION_ID"
        data_column:   "SESSION_DATA"
        cache_sth:     0 # default 0, when set to 1 statement handles are cached

  plugins:
    Database:
      connections:
        foo:
          driver:   "SQLite"
          database: "foo.sqlite"

=head1 Expected Schema

The code was developed to use a table with 2 columns: SESSION_ID, SESSION_DATA, additional columns will not impact the code. No records are deleted unless the session destroy is called, so cleanup is something that may need to be done over time.

The sql statements are generated based on the configuration options, session_table, id_column, and data_column.

=head2 Example Schema

Testing and development was done using SQLite3.

Create statement is as follows:

  create table sessions (session_id varchar unique,session_data blob);

=head1 How Queries are generated

All queries are generated using sprintf statements against constatins.

=head2 Column SESSION_ID

This column must have constraint defining the values as unique.  The id is a string representing the current session, internals from Dancer2::Core::Session seems to return a 32 byte long string.  It is highly recommended this column be indexed.

=head2 Column SESSION_DATA

This field is expected to be a BLOB or binary data type, although a large text field should work.  The data being written to this column is generated by using Storable::nfreeze($ref).

=head1 SQL Statements

All SQL Statements are generated based on the given configuration.

=head2 Insert

Default Query Shown:

  INSERT into SESSIONS (SESSION_ID,SESSION_DATA) values (?,?)

Sprintf Template:

  INSERT into %s (%s,%s) values (?,?)

=cut

sub INSERT { 'INSERT into %s (%s,%s) values (?,?)' }

sub create_flush_query {
  my ($self)=@_;
  return sprintf $self->INSERT,$self->session_table,$self->id_column,$self->data_column;
}

=head2 Update Existing session

Default Query Shown:

  UPDATE SESSIONS SET SESSION_DATA=? WHERE SESSION_ID=?

Sprintf Template:

  UPDATE %s SET %s=? WHERE %s=?

=cut

sub UPDATE { 'UPDATE %s SET %s=? WHERE %s=?' }

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

  my $query=sprintf $self->UPDATE,$self->session_table,$self->data_column,$self->id_column;
}

=head2 Delete

Default Query Shown:

  DELETE FROM SESSIONS WHERE SESSION_ID=?

Sprintf Template:

  DELETE FROM %s WHERE %s=?

=cut

sub DELETE { 'DELETE FROM %s WHERE %s=?' }

sub create_destroy_query {
  my ($self)=@_;
  my $query=sprintf $self->DELETE,$self->session_table,$self->id_column;
  return $query;
}

=head2 SELECT Current Session

Default Query Shown:

  SELECT SESSION_DATA FROM SESSIONS WHERE SESSION_ID=?

Sprintf Template:

  SELECT %s FROM %s WHERE %s=?

=cut

sub SELECT { 'SELECT %s FROM %s WHERE %s=?' }

sub create_retrieve_query {
  my ($self)=@_;
  my $query=sprintf $self->SELECT,$self->data_column,$self->session_table,$self->id_column;
  return $query;
}

=head2 SELECT All Session Keys

Default Query Shown:

  SELECT SESSION_ID FROM SESSIONS

Sprintf Template

  SELECT %s FROM %s

=cut

sub SELECT_ALL { 'SELECT %s FROM %s' }

sub create_sessions_query {
  my ($self)=@_;
  my $query=sprintf $self->SELECT_ALL,$self->id_column,$self->session_table;
  return $query;
}

=head2 Rename Session

Default Query Shown:

  UPDATE SESSIONS SET SESSION_ID=? WHERE SESSION_ID=?

Sprintf Template:

  UPDATE %s SET %s=? WHERE %s=?

=cut

sub RENAME { 'UPDATE %s SET %s=? WHERE %s=?' }

sub create_change_query {
  my ($self)=@_;
  my $query=sprintf $self->RENAME,$self->session_table,$self->id_column,$self->id_column;
  return $query;
}

sub get_sth($) {
  my ($self,$method)=@_;

  if($self->no_create->{$method}) {
    return undef;
  }
  return $self->sth_cache->{$method} if $self->cache && exists $self->sth_cache->{$method};

  my $query=$self->$method;
  my $sth;
  $HANDLE_SQL_STRING->($method,$query,$self->get_dbh,$sth);
  $sth=$self->get_dbh->prepare($query) unless defined($sth);

  # only cache the statement handle if we are told too
  return $sth unless $self->cache_sth;
  return $sth unless $self->cache;
  return $self->sth_cache->{$method}=$sth;
}

sub _sessions {
  my ($self) = @_;
  my $data=[];
  my $sth=$self->get_sth('create_sessions_query');$HANDLE_EXECUTE->('create_sessions_query',$sth,);

  while(my $row=$sth->fetchtow_arrayref) {
    push @{$data},@{$row};
  }

  return $data;
}

sub find_session {
  my ( $self, $id ) = @_;

  my $sth=$self->get_sth('create_retrieve_query');$HANDLE_EXECUTE->('create_retrieve_query',$sth,$id);
  my ($s)=$sth->fetchrow_array;
  return $s;
}

sub _retrieve {
  my ( $self, $id ) = @_;
  my $s=$self->find_session($id);

  return undef unless defined($s);

  return $THAW->($s);
}

sub _change_id {
  my ( $self, $old_id, $new_id ) = @_;
  my $sth=$self->get_sth('create_change_query');$HANDLE_EXECUTE->('create_change_query',$sth,$new_id,$old_id);
}

sub _destroy {
  my ( $self, $id ) = @_;

  my $sth=$self->get_sth('create_destroy_query');$HANDLE_EXECUTE->('create_destroy_query',$sth,$id);
}

sub _flush {
  my ( $self, $id, $data ) = @_;

  $data={} unless is_plain_hashref $data;

  my $s=$self->find_session($id);
  my $string=$FREEZE->($data);

  if(defined($s)) {
    my $sth=$self->get_sth('create_update_query');$HANDLE_EXECUTE->('create_update_query',$sth,$string,$id);
  } else {
    my $sth=$self->get_sth('create_flush_query');$HANDLE_EXECUTE->('create_flush_query',$sth,$id,$string);
  }
}

sub get_dbh {
  my ($self)=@_;
  #return Dancer2::Plugin::SessionDatabase::DBC($self->connection);
  $self->execute_hook( 'engine.session.before_db', $self );

  return $self->dbh;
}

=head1 hooks created

This package supports the default session engine hooks along with the following addtional hooks documented in this section.

=cut

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

      engine.session.before_db
      /;
}

=head2 engine.session.before_db

This hook is run before the session engine calls the database function from Dancer2::Plugin::Database.

  hook=>'engine.session.before_db'=>sub {
    my ($session)=@_;
  };

Note: This hook is used by Dancer2::Plugin::SessionDatabase to set the database handle in the session object at runtime.

=head1 hooks used in Dancer2::Plugin::Database

This package makes use of hooks provdied by Dancer2::Database::Plugin.

=head2 "database_connection_lost"

This hook is used to clear the existing database statement handle cache.

=head2 "database_error"

This hook is used to clear the existing database statement handle cache.

=head1 Notes

=head2 Database Acces Pre-Fork

If you access sessions preforking, you will need to reset the statement handle session cache.

Example:


=head3 Clearing the Statement Handle Cache

The following code snippit will reset the built in statement handle cache to empty.

  %{$Dancer2::Session::DatabasePlugin::CACHE}=();

=head3 Clearing the Database Connection

To release the current database session, use the following code snippet.

$Dancer2::Plugin::SessionDatabase::DBH=undef;

=head1 Specal Examples

=head2 Changing the freeze and thaw functions

Your database may not support globs or glob syntax, when this is the case it is possible to set a new subrouteens in place that handle the freezing and thawing of data.

=head3 Freeze

The nfreeze code reference is stored here

  $Dancer2::Session::DatabasePlugin::FREEZE

=head3 Thaw

The thaw code reference is stored here

  $Dancer2::Session::DatabasePlugin::THAW

=head2 Oracle in general

Oracle has some odd quirks, here is an example configuration that may help solve more than a few problems.

  Database:
    connections:
      myoracledb:
        driver: "Oracle:(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = my.oracle.server.com)(PORT = 1521)) (CONNECT_DATA = (SERVER = DEDICATED) (SERVICE_NAME=ORACLE.SERVICE.COM)))"
        username: OracleUser
        password: 'xxxxxxx'
        dbi_params:
           RaiseError: 1
           AutoCommit: 1
           FetchHashKeyName: 'NAME_uc'
           LongReadLen: 1000000

=head2 The manual bind example ( Oracle and the like )

Some databases require manual binds for blob.  Here is an example of how to do this for Oracle.

  use DBD::Oracle qw(:ora_types);
  use Dancer2;
  use Dancer2::Plugin::Database;
  use Dancer2::Plugin::SessionDatabase;

  $Dancer2::Session::DatabasePlugin::HANDLE_EXECUTE=sub {
    my ($name,$sth,@bind)=@_;
    if($name eq 'create_update_query') {
      my ($string,$id)=@bind;
      $sth->bind_param(1,$string,{ora_type => ORA_BLOB });
      $sth->bind_param(2,$id,{ora_type => ORA_VARCHAR2});
      $sth->execute();
    } elsif($name eq 'create_flush_query') {
      my ($id,$string)=@bind;
      $sth->bind_param(1,$id,{ora_type => ORA_VARCHAR2});
      $sth->bind_param(2,$string,{ora_type => ORA_BLOB });
      $sth->execute();
    } else {
      $sth->execute(@bind);
    }
  };

=head2 Completly Changing an SQL statement

Sometimes you may want to replace the query created with something entierly new.  To do this you will need to set $HANDLE_SQL_STRING function refrerence.

  use Dancer2;
  use Dancer2::Plugin::Database;
  use Dancer2::Plugin::SessionDatabase;

  $Dancer2::Session::DatabasePlugin::HANDLE_SQL_STRING=sub {
    my ($name)=@_;
    if($name eq 'query_to_alter') {
      $_[1]='some new sql statement';
    }
  };

=head2 DBD::Sybase MSSQL FreeTDS Example

This example represents how to deal with some of the strange limitations when connecting via MSSQL via DBD::Sybase with FreeTDS.

The limitations are as follows: DBD::Sybase does not support multiple open statement handls when AuttoCommit is true.  DBD::Sybase doesn't handle placeholders properly, and has some issues with binary data as well.

=head3 Session Configuration

In our session configuration we need to do the following: Disable statement handle caching and turn off the standard query generation code for the following functions: [create_update_query,create_flush_query].

  engines:
    session:
     DatabasePlugin:
       connection: "myconnection"
       session_table: "SESSIONS"
       id_column:     "SESSION_ID"
       data_column:   "SESSION_DATA"
       # Disable Caching of Statement handles
       cache: 0
       # skip internal Statment handler creation code for the following
       no_create:
         create_update_query: 1
         create_flush_query: 1

=head3 Database Configuration

Our example database has AutoCommit Disabled.

  plugins:
    Database:
      connections:
        socmon:
          driver:   Sybase
          server:   SOCMON_DEV
          username: username
          password: xxx
          database: myconnection
          dbi_params:
             RaiseError: 1
             AutoCommit: 1
             FetchHashKeyName: 'NAME_lc'

=head3 MSSQL Table Creation

MSSQL has some odd quirks when it comes to binary data, so in this case we will use varchar(max).

  create table SESSIONS (
    session_id varchar(32) ,
    session_data varchar(max),
    l astUpdate TimeStamp,
    CONSTRAINT AK_session_id UNIQUE(session_id)
  )

=head3 Code Example

Finnaly in your Dancer2 App we add the following code.

  use JSON qw(to_json from_jsom);

  $Dancer2::Session::DatabasePlugin::FREEZE=\&to_json;
  $Dancer2::Session::DatabasePlugin::THAW=\&from_json;

  $Dancer2::Session::DatabasePlugin::HANDLE_EXECUTE=sub {
    my ($name,$sth,@bind)=@_;
    if($name eq 'create_update_query') {
      my ($string,$id)=@bind;
      $string=~ s/'/''/g;
      $id=~ s/'/''/g;
      $Dancer2::Plugin::SessionDatabase::DBH->do("update sessions set session_data='$string' where session_id='$id'");
    } elsif($name eq 'create_flush_query') {
      my ($id,$string)=@bind;
      $string=~ s/'/''/g;
      $id=~ s/'/''/g;
      $Dancer2::Plugin::SessionDatabase::DBH->do("insert into sessions (session_data,session_id) values ('$string','$id')");
    } else {
      $sth->execute(@bind);
    }
  };

=head1 See Also

Dancer2::Plugin::Database
Dancer2::Session::YAML

=head1 LICENSE

This softare is distributed under the Perl 5 License.

=head1 AUTHOR

Michael Shipper <[e-mail]>

=cut

1;