2014-02-24 18:21:41 +01:00
|
|
|
##@file
|
|
|
|
# Base package for LemonLDAP::NG session object
|
|
|
|
|
|
|
|
##@class
|
|
|
|
# Specify a session object, how to create/update/remove session
|
|
|
|
|
|
|
|
package Lemonldap::NG::Common::Session;
|
|
|
|
|
2016-03-17 23:19:44 +01:00
|
|
|
our $VERSION = '2.0.0';
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
use Lemonldap::NG::Common::Apache::Session;
|
2018-06-13 23:20:35 +02:00
|
|
|
|
|
|
|
# Workaround for another ModPerl/Mouse issue...
|
2018-06-13 23:10:40 +02:00
|
|
|
BEGIN {
|
|
|
|
require Mouse;
|
2018-06-14 06:19:27 +02:00
|
|
|
my $v = sprintf( "%d.%03d%03d", ( $Mouse::VERSION =~ /(\d+)/g ) );
|
|
|
|
if ( $v < 2.005001 and $Lemonldap::NG::Handler::Apache2::Main::VERSION ) {
|
2018-06-13 23:10:40 +02:00
|
|
|
require Moose;
|
|
|
|
Moose->import();
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
Mouse->import();
|
|
|
|
}
|
|
|
|
}
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
has 'id' => (
|
|
|
|
is => 'rw',
|
2014-02-25 22:49:29 +01:00
|
|
|
isa => 'Str|Undef',
|
|
|
|
);
|
|
|
|
|
|
|
|
has 'force' => (
|
|
|
|
is => 'rw',
|
|
|
|
isa => 'Bool',
|
|
|
|
default => 0,
|
2014-02-24 18:21:41 +01:00
|
|
|
);
|
|
|
|
|
|
|
|
has 'kind' => (
|
|
|
|
is => 'rw',
|
2014-06-29 14:56:08 +02:00
|
|
|
isa => 'Str|Undef',
|
2014-02-24 18:21:41 +01:00
|
|
|
);
|
|
|
|
|
|
|
|
has 'data' => (
|
2016-05-18 13:43:48 +02:00
|
|
|
is => 'rw',
|
|
|
|
isa => 'HashRef',
|
|
|
|
default => sub { {} },
|
2014-02-24 18:21:41 +01:00
|
|
|
);
|
|
|
|
|
|
|
|
has 'options' => (
|
|
|
|
is => 'rw',
|
|
|
|
isa => 'HashRef',
|
|
|
|
);
|
|
|
|
|
|
|
|
has 'storageModule' => (
|
|
|
|
is => 'ro',
|
|
|
|
isa => 'Str',
|
|
|
|
required => 1,
|
|
|
|
);
|
|
|
|
|
|
|
|
has 'storageModuleOptions' => (
|
2014-02-25 22:49:29 +01:00
|
|
|
is => 'ro',
|
|
|
|
isa => 'HashRef|Undef',
|
2014-02-24 18:21:41 +01:00
|
|
|
);
|
|
|
|
|
|
|
|
has 'cacheModule' => (
|
|
|
|
is => 'rw',
|
2014-02-25 22:49:29 +01:00
|
|
|
isa => 'Str|Undef',
|
2014-02-24 18:21:41 +01:00
|
|
|
);
|
|
|
|
|
|
|
|
has 'cacheModuleOptions' => (
|
|
|
|
is => 'rw',
|
2014-02-25 22:49:29 +01:00
|
|
|
isa => 'HashRef|Undef',
|
2014-02-24 18:21:41 +01:00
|
|
|
);
|
|
|
|
|
2014-07-24 17:37:12 +02:00
|
|
|
has 'error' => (
|
|
|
|
is => 'rw',
|
|
|
|
isa => 'Str|Undef',
|
|
|
|
);
|
|
|
|
|
2017-02-20 22:00:05 +01:00
|
|
|
has info => ( is => 'rw' );
|
|
|
|
|
2014-02-24 18:21:41 +01:00
|
|
|
sub BUILD {
|
2017-02-20 22:00:05 +01:00
|
|
|
my ($self) = @_;
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
# Load Apache::Session module
|
|
|
|
unless ( $self->storageModule->can('populate') ) {
|
|
|
|
eval "require " . $self->storageModule;
|
|
|
|
return undef if $@;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Register options for common Apache::Session module
|
|
|
|
my $moduleOptions = $self->storageModuleOptions || {};
|
|
|
|
my %options = (
|
2014-02-25 22:49:29 +01:00
|
|
|
%$moduleOptions,
|
2014-02-24 18:21:41 +01:00
|
|
|
backend => $self->storageModule,
|
|
|
|
localStorage => $self->cacheModule,
|
|
|
|
localStorageOptions => $self->cacheModuleOptions
|
|
|
|
);
|
|
|
|
|
|
|
|
$self->options( \%options );
|
|
|
|
|
|
|
|
my $data = $self->_tie_session;
|
|
|
|
|
2014-06-20 18:16:21 +02:00
|
|
|
# Is it a session creation request?
|
|
|
|
my $creation = 1
|
|
|
|
if ( !$self->id or ( $self->id and !$data and $self->force ) );
|
|
|
|
|
2014-02-25 22:49:29 +01:00
|
|
|
# If session id was submitted but session is not found
|
|
|
|
# And we want to force id
|
|
|
|
# Then use setId to create session
|
2014-06-20 18:16:21 +02:00
|
|
|
if ( $self->id and $creation ) {
|
2014-02-25 22:49:29 +01:00
|
|
|
$options{setId} = $self->id;
|
|
|
|
$self->options( \%options );
|
|
|
|
$self->id(undef);
|
2016-02-26 18:39:06 +01:00
|
|
|
$self->error(undef);
|
2014-02-25 22:49:29 +01:00
|
|
|
$data = $self->_tie_session;
|
|
|
|
}
|
|
|
|
|
2014-06-20 18:16:21 +02:00
|
|
|
# If session is created
|
|
|
|
# Then set session kind in session
|
|
|
|
if ( $creation and $self->kind ) {
|
|
|
|
$data->{_session_kind} = $self->kind;
|
|
|
|
}
|
|
|
|
|
2017-02-20 22:00:05 +01:00
|
|
|
if ( $self->{info} ) {
|
|
|
|
foreach ( keys %{ $self->{info} } ) {
|
2018-06-20 21:38:26 +02:00
|
|
|
if ( defined $self->{info}->{$_} ) {
|
|
|
|
$data->{$_} = $self->{info}->{$_};
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
delete $data->{$_};
|
|
|
|
}
|
2017-02-20 22:00:05 +01:00
|
|
|
}
|
|
|
|
delete $self->{info};
|
|
|
|
}
|
|
|
|
|
2014-06-20 18:16:21 +02:00
|
|
|
# Load session data into object
|
2014-02-24 18:21:41 +01:00
|
|
|
if ($data) {
|
2014-06-20 18:16:21 +02:00
|
|
|
$self->_save_data($data);
|
2014-02-24 18:21:41 +01:00
|
|
|
$self->kind( $data->{_session_kind} );
|
|
|
|
$self->id( $data->{_session_id} );
|
2014-06-20 18:16:21 +02:00
|
|
|
|
2014-02-24 18:21:41 +01:00
|
|
|
untie(%$data);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
sub _tie_session {
|
2017-02-20 22:00:05 +01:00
|
|
|
my $self = $_[0];
|
|
|
|
my $options = $_[1] || {};
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
my %h;
|
|
|
|
|
|
|
|
eval {
|
2017-02-27 21:48:00 +01:00
|
|
|
# SOAP/REST session module must be directly tied
|
2017-02-15 07:41:50 +01:00
|
|
|
if ( $self->storageModule =~ /^Lemonldap::NG::Common::Apache::Session/ )
|
2014-07-16 15:42:49 +02:00
|
|
|
{
|
|
|
|
tie %h, $self->storageModule, $self->id,
|
|
|
|
{ %{ $self->options }, %$options };
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
tie %h, 'Lemonldap::NG::Common::Apache::Session', $self->id,
|
|
|
|
{ %{ $self->options }, %$options };
|
|
|
|
}
|
2014-02-24 18:21:41 +01:00
|
|
|
};
|
|
|
|
|
2014-07-24 17:37:12 +02:00
|
|
|
if ( $@ or not tied(%h) ) {
|
|
|
|
my $msg = "Session cannot be tied";
|
|
|
|
$msg .= ": $@" if $@;
|
|
|
|
$self->error($msg);
|
|
|
|
return undef;
|
|
|
|
}
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
return \%h;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub _save_data {
|
|
|
|
my ( $self, $data ) = @_;
|
|
|
|
|
|
|
|
my %saved_data = %$data;
|
|
|
|
$self->data( \%saved_data );
|
|
|
|
}
|
|
|
|
|
|
|
|
sub update {
|
2017-02-20 22:00:05 +01:00
|
|
|
my ( $self, $infos, $tieOptions ) = @_;
|
2014-02-24 18:21:41 +01:00
|
|
|
|
2014-07-24 17:37:12 +02:00
|
|
|
unless ( ref $infos eq "HASH" ) {
|
|
|
|
$self->error("You need to provide a HASHREF");
|
|
|
|
return 0;
|
|
|
|
}
|
2014-02-24 18:21:41 +01:00
|
|
|
|
2014-07-03 11:33:19 +02:00
|
|
|
my $data = $self->_tie_session($tieOptions);
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
if ($data) {
|
|
|
|
foreach ( keys %$infos ) {
|
|
|
|
if ( defined $infos->{$_} ) {
|
|
|
|
$data->{$_} = $infos->{$_};
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
delete $data->{$_};
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
$self->_save_data($data);
|
|
|
|
|
|
|
|
untie(%$data);
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
|
2014-07-24 17:37:12 +02:00
|
|
|
$self->error("No data found in session");
|
2014-02-24 18:21:41 +01:00
|
|
|
return 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub remove {
|
2017-02-20 22:00:05 +01:00
|
|
|
my ( $self, $tieOptions ) = @_;
|
2014-02-24 18:21:41 +01:00
|
|
|
|
2014-07-03 11:33:19 +02:00
|
|
|
my $data = $self->_tie_session($tieOptions);
|
2014-02-24 18:21:41 +01:00
|
|
|
|
|
|
|
eval { tied(%$data)->delete(); };
|
|
|
|
|
2014-07-24 17:37:12 +02:00
|
|
|
if ($@) {
|
|
|
|
$self->error("Unable to delete session: $@");
|
|
|
|
return 0;
|
|
|
|
}
|
|
|
|
|
2014-02-24 18:21:41 +01:00
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
|
|
|
|
no Mouse;
|
|
|
|
|
|
|
|
1;
|