File Coverage

lib/RPC/Switch/Client/Tiny/SessionCache.pm

Criterion	Covered	Total	%
statement	133	166	80.1
branch	50	80	62.5
condition	4	9	44.4
subroutine	21	24	87.5
pod	0	17	0.0
total	208	296	70.2

# Session cache for RPC::Switch::Client::Tiny
#
package RPC::Switch::Client::Tiny::SessionCache;

use strict;
use warnings;
use Time::HiRes qw(time);
use Time::Local;

our $VERSION = 1.22;

sub new {
	my ($class, %args) = @_;
	my $self = bless {
		%args,
		active    => {}, # active async sessions
		lru       => {}, # lru list for sessions
		expiring  => [], # sorted session expire list
		per_user  => {}, # active sessions per user (optional)
	}, $class;
	$self->{lru}{prev} = $self->{lru}{next} = $self->{lru};
	$self->{session_expire} = 60 unless $self->{session_expire};
	$self->{session_idle} = 1 unless $self->{session_idle};
	$self->{session_persist_user} = '' unless $self->{session_persist_user};
	$self->{max_user_session} = 0 unless $self->{max_user_session};
	return $self;
}

sub bin_search {
	my ($array, $cmp, $key) = @_;
	my ($lo, $hi) = (0, $#{$array});
	my $found;

	# If more than one element matches, return index to last one.
	#
	while ($lo <= $hi) {
		my $mid = int(($lo + $hi) / 2);
		my $ret = $cmp->($key, $array->[$mid]);

		if ($ret == 0) {
			$found = $mid;
		}
		if ($ret < 0) {
			$hi = $mid - 1;
		} else {
			$lo = $mid + 1;
		}
	}
	if (defined $found) {
		return (1, $found);
	}
        return (0, $lo);
}

sub _expire_find_session_idx {
	my ($self, $session, $idx) = @_;

	do {
		if ($self->{expiring}[$idx]->{id} eq $session->{id}) {
			return $idx;
		}
		last if (--$idx < 0);
	} while ($self->{expiring}[$idx]->{expiretime} eq $session->{expiretime});
	return;
}

sub expire_insert {
	my ($self, $session) = @_;

	# Sort expire list in ascending order.
	# (mostly appends if all sessions have the same validity)
	#
	my ($found, $idx) = bin_search($self->{expiring}, sub { $_[0]->{expiretime} - $_[1]->{expiretime} }, $session);
	if ($found) {
		# Update expire entry if session exists.
		# (there should be just one session per id)
		#
		my $sessionidx = $self->_expire_find_session_idx($session, $idx);
		if (defined $sessionidx) {
			$self->{expiring}[$sessionidx] = $session;
			return;
		}
		splice(@{$self->{expiring}}, $idx+1, 0, $session);
	} else {
		splice(@{$self->{expiring}}, $idx, 0, $session);
	}
}

sub expire_remove {
	my ($self, $session) = @_;

	# Remove can take a lot of processing if it is called
	# for long lists on every session drop.
	#
	my ($found, $idx) = bin_search($self->{expiring}, sub { $_[0]->{expiretime} - $_[1]->{expiretime} }, $session);
	if ($found) {
		my $sessionidx = $self->_expire_find_session_idx($session, $idx);
		if (defined $sessionidx) {
			splice(@{$self->{expiring}}, $sessionidx, 1);
		}
	}
}

sub expire_regenerate {
	my ($self, $sessionlist) = @_;
	$self->{expiring} = [sort { $a->{expiretime} - $b->{expiretime} } @$sessionlist];
}

sub list_empty {
	my ($head) = @_;
        return $head->{next} == $head;
}

sub list_add {
	my ($prev, $elem) = @_;
	$prev->{next}{prev} = $elem;
	$elem->{next} = $prev->{next};
	$elem->{prev} = $prev;
	$prev->{next} = $elem;
}

sub list_del {
	my ($elem) = @_;
	$elem->{next}{prev} = $elem->{prev};
	$elem->{prev}{next} = $elem->{next};
	delete $elem->{prev};
	delete $elem->{next};
}

sub session_put {
	my ($self, $child) = @_;
	my %runtime = (exists $child->{runtime}) ? (runtime => $child->{runtime}) : ();

	return unless exists $child->{session};

	if (exists $self->{active}{$child->{session}{id}}) {
		return; # don't allow double sessions
	}
	my $diff = $child->{session}{expiretime} - time();
	if ($diff < 0) {
		return; # session expired
	}
	if ($self->{max_user_session} && exists $child->{session}{user}) {
		my $user = $child->{session}{user};
		if (exists $self->{per_user}{$user}) {
			my $cnt = scalar keys %{$self->{per_user}{$user}};
			if ($cnt >= $self->{max_user_session}) {
				return; # too many user sessions
			}
		}
		$self->{per_user}{$user}{$child->{session}{id}} = 1;
	}
	$self->{trace_cb}->('PUT', {pid => $child->{pid}, id => $child->{id}, session => $child->{session}{id}, %runtime}) if $self->{trace_cb};
	$self->{active}{$child->{session}{id}} = $child;
	list_add($self->{lru}{prev}, $child);
	delete $child->{runtime};
	return 1;
}

sub session_get {
	my ($self, $session_id, $msg_id, $msg_vci) = @_;
	my %id = (defined $msg_id) ? (id => $msg_id) : ();
	my %vci = (defined $msg_vci) ? (vci => $msg_vci) : ();

	if (exists $self->{active}{$session_id}) {
		my $child = delete $self->{active}{$session_id};
		list_del($child);

		if ($self->{max_user_session} && exists $child->{session}{user}) {
			my $user = $child->{session}{user};
			if (exists $self->{per_user}{$user}) {
				delete $self->{per_user}{$user}{$child->{session}{id}};
				if (scalar keys %{$self->{per_user}{$user}} == 0) {
					delete $self->{per_user}{$user};
				}
			}
		}

		my $stoptime = sprintf "%.02f", time() - $child->{start};
		$self->{trace_cb}->('GET', {pid => $child->{pid}, %id, %vci, session => $session_id, stoptime => $stoptime}) if $self->{trace_cb};
		return $child;
	}
	return;
}

sub session_get_per_user {
	my ($self, $user, $msg_id, $msg_vci) = @_;

	if ($self->{max_user_session}) {
		foreach my $session_id (keys %{$self->{per_user}{$user}}) {
			return $self->session_get($session_id, $msg_id, $msg_vci);
		}
	}
	return;
}

sub session_get_per_user_idle {
	my ($self, $child) = @_;

	return unless exists $child->{session};

	if ($self->{max_user_session} && exists $child->{session}{user}) {
		my $user = $child->{session}{user};
		foreach my $session_id (keys %{$self->{per_user}{$user}}) {
			if (exists $self->{active}{$session_id}) {
				my $other_child = $self->{active}{$session_id};
				my $idle = time() - $other_child->{start};
				if ($idle >= $self->{session_idle}) {
					return $self->session_get($session_id);
				}
			}
		}
	}
	return;
}

sub parse_isotime {
	my ($isotime) = @_;
	my ($yy,$mm,$dd,$h,$m,$s,$msec) = $isotime =~
		/^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})(\.\d+)?Z$/;
	return unless defined $s;

        my $time = timegm($s,$m,$h,$dd,$mm-1,$yy-1900);
        return $time;
}

sub session_new {
	my ($self, $set_session) = @_;
	my $expiretime;

	if (exists $set_session->{expires}) {
		$expiretime = parse_isotime($set_session->{expires});
	}
	# set default expire in seconds
	$expiretime = time() + $self->{session_expire} unless $expiretime;
	my $session = {id => $set_session->{id}, expiretime => $expiretime};
	$session->{user} = $set_session->{user} if exists $set_session->{user};
	return $session;
}

sub lru_list {
	my ($self) = @_;
	my @list = ();

	for (my $elem = $self->{lru}{next}; $elem != $self->{lru}; $elem = $elem->{next}) {
		push(@list, $elem);
	}
	return \@list;
}

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

	unless (list_empty($self->{lru})) {
		my $child = $self->{lru}{next};
		return $self->session_get($child->{session}{id});
	}
	return;
}

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

	# Use sorted expire list to expire sessions.
	#
	while (scalar @{$self->{expiring}}) {
		my $session = $self->{expiring}[0];
		my $diff = $session->{expiretime} - time();
		return if ($diff >= 0);

		$session = shift @{$self->{expiring}};
		my $child = $self->session_get($session->{id});
		return $child if $child;
	}
	return;
}

1;

__END__