File Coverage

blib/lib/Apache/ASP/Session.pm
Criterion Covered Total %
statement 60 142 42.3
branch 20 64 31.2
condition 0 15 0.0
subroutine 11 20 55.0
pod 0 8 0.0
total 91 249 36.5


line stmt bran cond sub pod time code
1              
2             package Apache::ASP::Session;
3              
4 6     6   79 use Apache::ASP::State;
  6         80  
  6         133  
5              
6 6     6   94 use strict;
  6         104  
  6         101  
7 6     6   89 no strict qw(refs);
  6         53  
  6         109  
8 6     6   96 use vars qw(@ISA);
  6         86  
  6         108  
9             @ISA = qw(Apache::ASP::Collection);
10              
11             # allow to pass in id so we can cleanup other sessions with
12             # the session manager
13             sub new {
14 7     7 0 82     my($asp, $id, $perms, $no_error) = @_;
15 7         68     my($state, %self, $started);
16 7         138     my $internal = $asp->{Internal};
17              
18             # if we are passing in the id, then we are doing a
19             # quick session lookup and can bypass the normal checks
20             # this is useful for the session manager and such
21 7 50       90     if($id) {
22 0         0 $internal->LOCK;
23 0         0 $state = Apache::ASP::State::new($asp, $id, undef, $perms, $no_error);
24             # $state->Set() || $asp->Error("session state get failed");
25 0 0       0 if($state) {
26 0         0 tie %self, 'Apache::ASP::Session',
27             {
28             state=>$state, 
29             asp=>$asp, 
30             id=>$id,
31             };
32 0         0 $internal->UNLOCK;
33 0         0 return bless \%self;
34             } else {
35 0         0 $internal->UNLOCK;
36 0         0 return;
37             }
38                 }
39              
40             # lock down so no conflict with garbage collection
41 7         106     $internal->LOCK();
42 7 50       204     if($id = $asp->SessionId()) {
43 0         0 my $idata = $internal->{$id};
44             # $asp->Debug("internal data for session $id", $idata);
45 0 0 0     0 if($idata && ! $idata->{'end'} ) {
46             # user is authentic, since the id is in our internal hash
47 0 0       0 if($idata->{timeout} > time()) {
48             # refresh and unlock as early as possible to not conflict
49             # with garbage collection
50 0         0 $asp->RefreshSessionId($id);
51 0         0 $state = Apache::ASP::State::new($asp, $id);
52 0         0 $internal->UNLOCK();
53              
54             # session not expired
55 0 0       0 $asp->{dbg} &&
56             $asp->Debug("session not expired",{'time'=>time(), timeout=>$idata->{timeout}});
57              
58 0 0       0 if($asp->{paranoid_session}) {
59 0         0 local $^W = 0;
60             # by testing for whether UA was set to begin with, we
61             # allow a smooth upgrade to ParanoidSessions
62 0 0       0 $state->WriteLock() if $asp->{session_serialize};
63 0         0 my $state_ua = $state->FETCH('_UA');
64 0 0 0     0 if(defined($state_ua) and $state_ua ne $asp->{'ua'}) {
65 0         0 $asp->Log("[security] hacker guessed id $id; ".
66             "user-agent ($asp->{'ua'}) does not match ($state_ua); ".
67             "destroying session & establishing new session id"
68             );
69 0         0 $state->Init();
70 0         0 undef $state;
71 0         0 goto NEW_SESSION_ID;
72             }
73             }
74              
75 0         0 $started = 0;
76             } else {
77             # expired, get & reset
78 0         0 $internal->{$id} = { %{$internal->{$id}}, 'end' => 1 };
  0         0  
79 0         0 $internal->UNLOCK();
80              
81             # remove this section, allow lazy cleanup, this caused a bug
82             # in which sessions cleared in this way, but didn't have their files cleaned up
83             # would have their timeout restored later
84             #
85             # $asp->Debug("session $id timed out, clearing");
86             # $asp->{GlobalASA}->SessionOnEnd($id);
87             # $internal->LOCK();
88             # delete $internal->{$id};
89             # $internal->UNLOCK();
90            
91             # we need to create a new state now after the clobbering
92             # with SessionOnEnd
93 0         0 goto NEW_SESSION_ID;
94             }
95             } else {
96             # never seen before, maybe session garbage collected already
97             # or coming in from querystringed search engine
98              
99             # wish we could do more
100             # but proxying + nat prevents us from securing via ip address
101 0         0 goto NEW_SESSION_ID;
102             }
103                 } else {
104             # give user new session id, we must lock this portion to avoid
105             # concurrent identical session key creation, this is the
106             # only critical part of the session manager
107              
108 7         66       NEW_SESSION_ID:
109             my($trys);
110 7         144 for(1..10) {
111 7         69 $trys++;
112 7         97 $id = $asp->Secret();
113              
114 7 50       119 if($internal->{$id}) {
115 0         0 $id = '';
116             } else {
117 7         150 last;
118             }
119             }
120              
121 7 50       168 $id && $asp->RefreshSessionId($id, {});
122 7         93 $asp->{Internal}->UNLOCK();
123              
124 7 50       85 $asp->Log("[security] secret algorithm is no good with $trys trys")
125             if ($trys > 3);
126 7 50       85 $asp->Error("no unique secret generated")
127             unless $id;
128              
129 7 50       85 $asp->{dbg} && $asp->Debug("new session id $id");
130 7         93 $asp->SessionId($id);
131              
132 7         153 $state = &Apache::ASP::State::new($asp, $id);
133             # $state->Set() || $asp->Error("session state set failed");
134              
135 7 50       100 if($asp->{paranoid_session}) {
136 0         0 $asp->Debug("storing user-agent $asp->{'ua'}");
137 0         0 $state->STORE('_UA', $asp->{'ua'});
138             }
139 7         74 $started = 1;
140                 }
141              
142 7 50       122     if(! $state) {
143 0         0 $asp->Error("can't get state for id $id");
144 0         0 return;
145                 }
146              
147 7 50       83     $state->WriteLock() if $asp->{session_serialize};
148 7         106     $asp->Debug("tieing session $id");
149 7         83     tie %self, 'Apache::ASP::Session',
150                 {
151             state=>$state, 
152             asp=>$asp, 
153             id=>$id,
154             started=>$started,
155                 };
156              
157 7 50       273     if($started) {
158 7 50       98 $asp->{dbg} && $asp->Debug("clearing starting session");
159 7 50       135 if($state->Size > 0) {
160 0 0       0 $asp->{dbg} && $asp->Debug("clearing data in old session $id");
161 0         0 %self = ();
162             }
163                 }
164              
165 7         134     bless \%self;
166             }
167              
168             sub TIEHASH {
169 7     7   75     my($package, $self) = @_;
170 7         69     bless $self;
171             }       
172              
173             # stub so we don't have to test for it in autoload
174             sub DESTROY {
175 15     15   163     my $self = shift;
176              
177             # wrapped in eval to suppress odd global destruction error messages
178             # in perl 5.6.0, --jc 5/28/2001
179 15 100       156     return unless eval { $self->{state} };
  15         524  
180              
181 7         95     $self->{state}->DESTROY;
182 7         75     undef $self->{state};
183 7         70     %$self = ();
184             }
185              
186             # don't need to skip DESTROY since we have it here
187             # return if ($AUTOLOAD =~ /DESTROY/);
188             sub AUTOLOAD {
189 0     0   0     my $self = shift;
190 0         0     my $AUTOLOAD = $Apache::ASP::Session::AUTOLOAD;
191 0         0     $AUTOLOAD =~ s/^(.*)::(.*?)$/$2/o;
192 0         0     $self->{state}->$AUTOLOAD(@_);
193             }
194              
195             sub FETCH {
196 3     3   32     my($self, $index) = @_;
197              
198             # putting these comparisons in a regexp was a little
199             # slower than keeping them in these 'eq' statements
200 3 100       66     if($index eq '_SELF') {
    50          
    50          
    0          
201 2         21 $self;
202                 } elsif($index eq '_STATE') {
203 0         0 $self->{state};
204                 } elsif($index eq 'SessionID') {
205 1         12 $self->{id};
206                 } elsif($index eq 'Timeout') {
207 0         0 $self->Timeout();
208                 } else {
209 0         0 $self->{state}->FETCH($index);
210                 }
211             }
212              
213             sub STORE {
214 7     7   116     my($self, $index, $value) = @_;
215 7 50       84     if($index eq 'Timeout') {
216 0         0 $self->Timeout($value);
217                 } else {
218 7         105 $self->{state}->STORE($index, $value);
219                 }
220             }
221              
222             # firstkey and nextkey skip the _UA key so the user
223             # we need to keep the ua info in the session db itself,
224             # so we are not dependent on writes going through to Internal
225             # for this very critical informatioh. _UA is used for security
226             # validation / the user's user agent.
227             sub FIRSTKEY {
228 0     0   0     my $self = shift;
229 0         0     my $value = $self->{state}->FIRSTKEY();
230 0 0 0     0     if(defined $value and $value eq '_UA') {
231 0         0 $self->{state}->NEXTKEY($value);
232                 } else {
233 0         0 $value;
234                 }
235             }
236              
237             sub NEXTKEY {
238 0     0   0     my($self, $key) = @_;
239 0         0     my $value = $self->{state}->NEXTKEY($key);
240 0 0 0     0     if(defined($value) && ($value eq '_UA')) {
241 0         0 $self->{state}->NEXTKEY($value);
242                 } else {
243 0         0 $value;
244                 }
245             }
246              
247             sub CLEAR {
248 0     0   0     my $state = shift->{state};
249 0         0     my $ua = $state->FETCH('_UA');
250 0         0     my $rv = $state->CLEAR();
251 0 0       0     $ua && $state->STORE('_UA', $ua);
252 0         0     $rv;
253             }
254              
255             sub SessionID {
256 14     14 0 133     my $self = shift;
257 14         237     tied(%$self)->{id};
258             }
259              
260             sub Timeout {
261 0     0 0 0     my($self, $minutes) = @_;
262              
263 0 0       0     if(tied(%$self)) {
264 0         0 $self = tied(%$self);
265                 }
266              
267 0 0       0     if($minutes) {
268 0         0 $self->{asp}{Internal}->LOCK;
269 0         0 my($internal_session) = $self->{asp}{Internal}{$self->{id}};
270 0         0 $internal_session->{refresh_timeout} = $minutes * 60;
271 0         0 $internal_session->{timeout} = time() + $minutes * 60;
272 0         0 $self->{asp}{Internal}{$self->{id}} = $internal_session;
273 0         0 $self->{asp}{Internal}->UNLOCK;
274                 } else {
275 0         0 my($refresh) = $self->{asp}{Internal}{$self->{id}}{refresh_timeout};
276 0   0     0 $refresh ||= $self->{asp}{session_timeout};
277 0         0 $refresh / 60;
278                 }
279             }    
280              
281             sub Abandon {
282 0     0 0 0     shift->Timeout(-1);
283             }
284              
285             sub TTL {
286 0     0 0 0     my $self = shift;
287 0         0     $self = tied(%$self);
288             # time to live is current timeout - time... positive means
289             # session is still active, returns ttl in seconds
290 0         0     my $timeout = $self->{asp}{Internal}{$self->{id}}{timeout};
291 0         0     my $ttl = $timeout - time();
292             }
293              
294             sub Started {
295 7     7 0 251     my $self = shift;
296 7         101     tied(%$self)->{started};
297             }
298              
299             # we provide these, since session serialize is not
300             # the default... locking around writes will also be faster,
301             # since there will be only one tie to the database and
302             # one flush per lock set
303 0     0 0   sub Lock { tied(%{$_[0]})->{state}->WriteLock(); }
  0            
304 0     0 0   sub UnLock { tied(%{$_[0]})->{state}->UnLock(); }
  0            
305              
306             1;
307