File Coverage

blib/lib/Apache2/ASP/SessionStateManager.pm

Criterion	Covered	Total	%
statement	33	132	25.0
branch	0	14	0.0
condition	0	4	0.0
subroutine	11	23	47.8
pod	1	11	9.0
total	45	184	24.4

package Apache2::ASP::SessionStateManager;

use strict;
use warnings 'all';
use base 'Ima::DBI';
use Digest::MD5 'md5_hex';
use Storable qw( freeze thaw );
use HTTP::Date qw( time2iso str2time );
use Scalar::Util 'weaken';


#==============================================================================
sub new
{
  my ($class, %args) = @_;

  my $s = bless {}, $class;
  my $conn = $s->context->config->data_connections->session;

  local $^W = 0;
  __PACKAGE__->set_db('Main',
    $conn->dsn,
    $conn->username,
    $conn->password
  );

  # Prepare our Session:
  if( my $id = $s->parse_session_id() )
  {
    if( $s->verify_session_id( $id ) )
    {
      $s->{SessionID} = $id;
      return $s->retrieve( $id );
    }
    else
    {
      $s->{SessionID} = $s->new_session_id();
      $s->write_session_cookie();
      return $s->create( $s->{SessionID} );
    }# end if()
  }
  else
  {
    $s->{SessionID} = $s->new_session_id();
    $s->write_session_cookie();
    return $s->create( $s->{SessionID} );
  }# end if()
}# end new()


#==============================================================================
sub context
{
  $Apache2::ASP::HTTPContext::ClassName->current;
}# end context()


#==============================================================================
sub parse_session_id
{
  my ($s) = @_;

  my $cookiename = $s->context->config->data_connections->session->cookie_name;

  no warnings 'uninitialized';
  if( my ($id) = $ENV{HTTP_COOKIE} =~ m/\b$cookiename\=([a-f0-9]+)\b/ )
  {
    return $id;
  }
  elsif( ($id) = $s->context->r->headers_in->{Cookie} =~ m/\b$cookiename\=([a-f0-9]+)\b/ )
  {
    return $id;
  }
  else
  {
    return;
  }# end if()
}# end parse_session_id()


#==============================================================================
# Returns true if the session exists and has not timed out:
sub verify_session_id
{
  my ($s, $id) = @_;

  my $range_start = time() - ( $s->context->config->data_connections->session->session_timeout * 60 );
  local $s->db_Main->{AutoCommit} = 1;
  my $sth = $s->db_Main->prepare_cached(<<"");
    SELECT COUNT(*)
    FROM asp_sessions
    WHERE session_id = ?
    AND modified_on BETWEEN ? AND ?

  $sth->execute( $id, time2iso($range_start), time2iso() );
  my ($active) = $sth->fetchrow();
  $sth->finish();

  return $active;
}# end verify_session_id()


#==============================================================================
sub create
{
  my ($s, $id) = @_;

  local $s->db_Main->{AutoCommit} = 1;
  my $sth = $s->db_Main->prepare_cached(<<"");
    INSERT INTO asp_sessions (
      session_id,
      session_data,
      created_on,
      modified_on
    )
    VALUES (
      ?, ?, ?, ?
    )

  my $now = time2iso();

  no warnings 'uninitialized';
  $s->{__signature} = md5_hex(
    join ":",
      map { "$_:$s->{$_}" }
        grep { $_ ne '__signature' } sort keys(%$s)
  );

  my %clone = %$s;

  $sth->execute(
    $id,
    freeze( \%clone ),
    $now,
    $now,
  );
  $sth->finish();

  return $s->retrieve( $id );
}# end create()


#==============================================================================
sub retrieve
{
  my ($s, $id) = @_;

  local $s->db_Main->{AutoCommit} = 1;
  my $sth = $s->db_Main->prepare_cached(<<"");
    SELECT session_data, modified_on
    FROM asp_sessions
    WHERE session_id = ?

  my $now = time2iso();
  $sth->execute( $id );
  my ($data, $modified_on) = $sth->fetchrow;
  $data = thaw($data) || { SessionID => $id };
  $sth->finish();

  if( time() - str2time($modified_on) >= ( $s->context->config->data_connections->session->session_timeout * 59 ) )
  {
    local $s->db_Main->{AutoCommit} = 1;
    my $sth = $s->db_Main->prepare_cached(<<"");
    UPDATE asp_sessions SET
      modified_on = ?
    WHERE session_id = ?

    $sth->execute( time2iso(), $id );
    $sth->finish();
  }# end if()

  undef(%$s);
  $s = bless $data, ref($s);
  weaken($s);

  no warnings 'uninitialized';

  my @keys = sort keys(%$s);

  my $sig = md5_hex(
    join ":",
      map { "$_:$s->{$_}" }
        grep { $_ ne '__signature' } @keys
  );

  $s->{__signature} = $sig;

  return $s;
}# end retrieve()


#==============================================================================
sub save
{
  my ($s) = @_;

  no warnings 'uninitialized';
  return if $s->{__signature} eq md5_hex(
    join ":", map { "$_:$s->{$_}" }
                grep { $_ ne '__signature' } sort keys(%$s)
  );
  $s->{__signature} = md5_hex(
    join ":",
      map { "$_:$s->{$_}" }
        grep { $_ ne '__signature' } sort keys(%$s)
  );

  local $s->db_Main->{AutoCommit} = 1;
  my $sth = $s->db_Main->prepare_cached(<<"");
    UPDATE asp_sessions SET
      session_data = ?,
      modified_on = ?
    WHERE session_id = ?

  my %clone = %$s;
  my $data = freeze( \%clone );
  $sth->execute( $data, time2iso(), $s->{SessionID} );
  $sth->finish();

  1;
}# end save()


#=========================================================================
sub reset
{
  my ($s) = @_;

  # Remove everything *but* our important parts:
  my %saves = map { $_ => 1 } qw/ SessionID /;
  delete( $s->{$_} ) foreach grep { ! $saves{$_} } keys(%$s);
  $s->save;
}# end reset()


#==============================================================================
sub new_session_id
{
  my $s = shift;
  md5_hex( $s->context->config->web->application_name . rand() );
}# end new_session_id()


#==============================================================================
sub write_session_cookie
{
  my $s = shift;

  my $state = $s->context->config->data_connections->session;
  my $cookiename = $state->cookie_name;
  $s->context->response->AddHeader(
    'Set-Cookie' =>  "$cookiename=$s->{SessionID}; path=/;" #; domain=" . $state->cookie_domain
  );

  # If we weren't given an HTTP cookie value, set it here.
  # This prevents subsequent calls to 'parse_session_id()' to fail:
  $ENV{HTTP_COOKIE} ||= '';
  if( $ENV{HTTP_COOKIE} !~ m/\b$cookiename\=.*?\b/ )
  {
    my @cookies = split /;/, $ENV{HTTP_COOKIE};
    push @cookies, "$cookiename=$s->{SessionID}";
    $ENV{HTTP_COOKIE} = join ';', @cookies;
  }# end if()

  1;
}# end write_session_cookie()


#==============================================================================
sub dbh
{
  my $s = shift;
  return $s->db_Main;
}# end dbh()


#==============================================================================
sub DESTROY
{
  my $s = shift;

  delete($s->{$_}) foreach keys(%$s);
}# end DESTROY()

1;# return true:

__END__