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


line stmt bran cond sub pod time code
1             # Session cache for RPC::Switch::Client::Tiny
2             #
3             package RPC::Switch::Client::Tiny::SessionCache;
4              
5 21     21   100008 use strict;
  21         51  
  21         594  
6 21     21   106 use warnings;
  21         46  
  21         572  
7 21     21   129 use Time::HiRes qw(time);
  21         63  
  21         108  
8 21     21   11767 use Time::Local;
  21         46568  
  21         42258  
9              
10             our $VERSION = 1.22;
11              
12             sub new {
13 12     12 0 3112 my ($class, %args) = @_;
14 12         183 my $self = bless {
15             %args,
16             active => {}, # active async sessions
17             lru => {}, # lru list for sessions
18             expiring => [], # sorted session expire list
19             per_user => {}, # active sessions per user (optional)
20             }, $class;
21 12         227 $self->{lru}{prev} = $self->{lru}{next} = $self->{lru};
22 12 100       113 $self->{session_expire} = 60 unless $self->{session_expire};
23 12 50       77 $self->{session_idle} = 1 unless $self->{session_idle};
24 12 50       157 $self->{session_persist_user} = '' unless $self->{session_persist_user};
25 12 100       61 $self->{max_user_session} = 0 unless $self->{max_user_session};
26 12         96 return $self;
27             }
28              
29             sub bin_search {
30 23     23 0 103 my ($array, $cmp, $key) = @_;
31 23         44 my ($lo, $hi) = (0, $#{$array});
  23         51  
32 23         55 my $found;
33              
34             # If more than one element matches, return index to last one.
35             #
36 23         74 while ($lo <= $hi) {
37 39         77 my $mid = int(($lo + $hi) / 2);
38 39         94 my $ret = $cmp->($key, $array->[$mid]);
39              
40 39 100       87 if ($ret == 0) {
41 7         11 $found = $mid;
42             }
43 39 100       70 if ($ret < 0) {
44 16         31 $hi = $mid - 1;
45             } else {
46 23         51 $lo = $mid + 1;
47             }
48             }
49 23 100       64 if (defined $found) {
50 7         16 return (1, $found);
51             }
52 16         38 return (0, $lo);
53             }
54              
55             sub _expire_find_session_idx {
56 7     7   14 my ($self, $session, $idx) = @_;
57              
58             do {
59 7 50       18 if ($self->{expiring}[$idx]->{id} eq $session->{id}) {
60 7         13 return $idx;
61             }
62 0 0       0 last if (--$idx < 0);
63 7         9 } while ($self->{expiring}[$idx]->{expiretime} eq $session->{expiretime});
64 0         0 return;
65             }
66              
67             sub expire_insert {
68 23     23 0 123 my ($self, $session) = @_;
69              
70             # Sort expire list in ascending order.
71             # (mostly appends if all sessions have the same validity)
72             #
73 23     39   244 my ($found, $idx) = bin_search($self->{expiring}, sub { $_[0]->{expiretime} - $_[1]->{expiretime} }, $session);
  39         84  
74 23 100       96 if ($found) {
75             # Update expire entry if session exists.
76             # (there should be just one session per id)
77             #
78 7         15 my $sessionidx = $self->_expire_find_session_idx($session, $idx);
79 7 50       16 if (defined $sessionidx) {
80 7         14 $self->{expiring}[$sessionidx] = $session;
81 7         14 return;
82             }
83 0         0 splice(@{$self->{expiring}}, $idx+1, 0, $session);
  0         0  
84             } else {
85 16         23 splice(@{$self->{expiring}}, $idx, 0, $session);
  16         59  
86             }
87             }
88              
89             sub expire_remove {
90 0     0 0 0 my ($self, $session) = @_;
91              
92             # Remove can take a lot of processing if it is called
93             # for long lists on every session drop.
94             #
95 0     0   0 my ($found, $idx) = bin_search($self->{expiring}, sub { $_[0]->{expiretime} - $_[1]->{expiretime} }, $session);
  0         0  
96 0 0       0 if ($found) {
97 0         0 my $sessionidx = $self->_expire_find_session_idx($session, $idx);
98 0 0       0 if (defined $sessionidx) {
99 0         0 splice(@{$self->{expiring}}, $sessionidx, 1);
  0         0  
100             }
101             }
102             }
103              
104             sub expire_regenerate {
105 1     1 0 28 my ($self, $sessionlist) = @_;
106 1         6 $self->{expiring} = [sort { $a->{expiretime} - $b->{expiretime} } @$sessionlist];
  12         23  
107             }
108              
109             sub list_empty {
110 2     2 0 5 my ($head) = @_;
111 2         10 return $head->{next} == $head;
112             }
113              
114             sub list_add {
115 17     17 0 38 my ($prev, $elem) = @_;
116 17         30 $prev->{next}{prev} = $elem;
117 17         59 $elem->{next} = $prev->{next};
118 17         35 $elem->{prev} = $prev;
119 17         29 $prev->{next} = $elem;
120             }
121              
122             sub list_del {
123 12     12 0 33 my ($elem) = @_;
124 12         210 $elem->{next}{prev} = $elem->{prev};
125 12         33 $elem->{prev}{next} = $elem->{next};
126 12         26 delete $elem->{prev};
127 12         26 delete $elem->{next};
128             }
129              
130             sub session_put {
131 24     24 0 118 my ($self, $child) = @_;
132 24 100       101 my %runtime = (exists $child->{runtime}) ? (runtime => $child->{runtime}) : ();
133              
134 24 50       58 return unless exists $child->{session};
135              
136 24 100       72 if (exists $self->{active}{$child->{session}{id}}) {
137 3         21 return; # don't allow double sessions
138             }
139 21         72 my $diff = $child->{session}{expiretime} - time();
140 21 100       62 if ($diff < 0) {
141 2         12 return; # session expired
142             }
143 19 50 66     56 if ($self->{max_user_session} && exists $child->{session}{user}) {
144 4         8 my $user = $child->{session}{user};
145 4 100       10 if (exists $self->{per_user}{$user}) {
146 3         10 my $cnt = scalar keys %{$self->{per_user}{$user}};
  3         9  
147 3 100       8 if ($cnt >= $self->{max_user_session}) {
148 2         6 return; # too many user sessions
149             }
150             }
151 2         7 $self->{per_user}{$user}{$child->{session}{id}} = 1;
152             }
153 17 100       75 $self->{trace_cb}->('PUT', {pid => $child->{pid}, id => $child->{id}, session => $child->{session}{id}, %runtime}) if $self->{trace_cb};
154 17         491 $self->{active}{$child->{session}{id}} = $child;
155 17         58 list_add($self->{lru}{prev}, $child);
156 17         35 delete $child->{runtime};
157 17         95 return 1;
158             }
159              
160             sub session_get {
161 28     28 0 684 my ($self, $session_id, $msg_id, $msg_vci) = @_;
162 28 100       172 my %id = (defined $msg_id) ? (id => $msg_id) : ();
163 28 100       261 my %vci = (defined $msg_vci) ? (vci => $msg_vci) : ();
164              
165 28 100       92 if (exists $self->{active}{$session_id}) {
166 12         43 my $child = delete $self->{active}{$session_id};
167 12         60 list_del($child);
168              
169 12 0 33     32 if ($self->{max_user_session} && exists $child->{session}{user}) {
170 0         0 my $user = $child->{session}{user};
171 0 0       0 if (exists $self->{per_user}{$user}) {
172 0         0 delete $self->{per_user}{$user}{$child->{session}{id}};
173 0 0       0 if (scalar keys %{$self->{per_user}{$user}} == 0) {
  0         0  
174 0         0 delete $self->{per_user}{$user};
175             }
176             }
177             }
178              
179 12         137 my $stoptime = sprintf "%.02f", time() - $child->{start};
180 12 100       74 $self->{trace_cb}->('GET', {pid => $child->{pid}, %id, %vci, session => $session_id, stoptime => $stoptime}) if $self->{trace_cb};
181 12         261 return $child;
182             }
183 16         134 return;
184             }
185              
186             sub session_get_per_user {
187 0     0 0 0 my ($self, $user, $msg_id, $msg_vci) = @_;
188              
189 0 0       0 if ($self->{max_user_session}) {
190 0         0 foreach my $session_id (keys %{$self->{per_user}{$user}}) {
  0         0  
191 0         0 return $self->session_get($session_id, $msg_id, $msg_vci);
192             }
193             }
194 0         0 return;
195             }
196              
197             sub session_get_per_user_idle {
198 5     5 0 17 my ($self, $child) = @_;
199              
200 5 50       17 return unless exists $child->{session};
201              
202 5 0 33     14 if ($self->{max_user_session} && exists $child->{session}{user}) {
203 0         0 my $user = $child->{session}{user};
204 0         0 foreach my $session_id (keys %{$self->{per_user}{$user}}) {
  0         0  
205 0 0       0 if (exists $self->{active}{$session_id}) {
206 0         0 my $other_child = $self->{active}{$session_id};
207 0         0 my $idle = time() - $other_child->{start};
208 0 0       0 if ($idle >= $self->{session_idle}) {
209 0         0 return $self->session_get($session_id);
210             }
211             }
212             }
213             }
214 5         18 return;
215             }
216              
217             sub parse_isotime {
218 3     3 0 13 my ($isotime) = @_;
219 3         44 my ($yy,$mm,$dd,$h,$m,$s,$msec) = $isotime =~
220             /^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})(\.\d+)?Z$/;
221 3 50       24 return unless defined $s;
222              
223 3         58 my $time = timegm($s,$m,$h,$dd,$mm-1,$yy-1900);
224 3         168 return $time;
225             }
226              
227             sub session_new {
228 18     18 0 215 my ($self, $set_session) = @_;
229 18         64 my $expiretime;
230              
231 18 100       58 if (exists $set_session->{expires}) {
232 3         34 $expiretime = parse_isotime($set_session->{expires});
233             }
234             # set default expire in seconds
235 18 100       98 $expiretime = time() + $self->{session_expire} unless $expiretime;
236 18         91 my $session = {id => $set_session->{id}, expiretime => $expiretime};
237 18 100       61 $session->{user} = $set_session->{user} if exists $set_session->{user};
238 18         59 return $session;
239             }
240              
241             sub lru_list {
242 2     2 0 448 my ($self) = @_;
243 2         5 my @list = ();
244              
245 2         12 for (my $elem = $self->{lru}{next}; $elem != $self->{lru}; $elem = $elem->{next}) {
246 4         14 push(@list, $elem);
247             }
248 2         7 return \@list;
249             }
250              
251             sub lru_dequeue {
252 2     2 0 22 my ($self) = @_;
253              
254 2 50       7 unless (list_empty($self->{lru})) {
255 2         5 my $child = $self->{lru}{next};
256 2         7 return $self->session_get($child->{session}{id});
257             }
258 0         0 return;
259             }
260              
261             sub expired_dequeue {
262 60     60 0 150 my ($self) = @_;
263              
264             # Use sorted expire list to expire sessions.
265             #
266 60         106 while (scalar @{$self->{expiring}}) {
  62         225  
267 14         34 my $session = $self->{expiring}[0];
268 14         44 my $diff = $session->{expiretime} - time();
269 14 100       75 return if ($diff >= 0);
270              
271 2         22 $session = shift @{$self->{expiring}};
  2         7  
272 2         10 my $child = $self->session_get($session->{id});
273 2 50       11 return $child if $child;
274             }
275 48         388 return;
276             }
277              
278             1;
279              
280             __END__