File Coverage

blib/lib/Apache/ASP/StateManager.pm
Criterion Covered Total %
statement 221 262 84.3
branch 95 158 60.1
condition 48 80 60.0
subroutine 10 10 100.0
pod 0 7 0.0
total 374 517 72.3


line stmt bran cond sub pod time code
1              
2             package Apache::ASP;
3              
4             # quickly decomped out of Apache::ASP so we could load the routines only
5             # when we are managing State objects
6              
7 13     13   6401 use Apache::ASP::State;
  13         44  
  13         412  
8              
9 13     13   125 use strict;
  13         27  
  13         490  
10 13         43847 use vars qw(
11             $CleanupGroups
12             $SessionIDLength $SessionTimeout $StateManager
13             $DefaultStateDB $DefaultStateSerializer
14 13     13   64 );
  13         27  
15              
16             $SessionTimeout = 20;
17             $StateManager = 10;
18              
19             # Some OS's have hashed directory lookups up to 16 bytes, so we leave room
20             # for .lock extension ... nevermind, security is more important, back to 32
21             # $SessionIDLength = 11;
22             $SessionIDLength = 32;
23             $DefaultStateDB = 'SDBM_File';
24             $DefaultStateSerializer = 'Data::Dumper';
25              
26             sub InitState {
27 28     28 0 64 my $self = shift;
28 28         150 my $r = $self->{r};
29 28         70 my $global_asa = $self->{GlobalASA};
30              
31             ## STATE INITS
32             # what percent of the session_timeout's time do we garbage collect
33             # state files and run programs like Session_OnEnd and Application_OnEnd
34 28         128 $self->{state_manager} = &config($self, 'StateManager', undef, $Apache::ASP::StateManager);
35              
36             # state is the path where state files are stored, like $Session, $Application, etc.
37 28         143 $self->{state_dir} = &config($self, 'StateDir', undef, $self->{global}.'/.state');
38 28         89 $self->{state_dir} =~ tr///; # untaint
39 28         94 $self->{session_state} = &config($self, 'AllowSessionState', undef, 1);
40 28         107 $self->{state_serialize} = &config($self, 'ApplicationSerialize');
41              
42 28 50       101 if($self->{state_db} = &config($self, 'StateDB')) {
43             # StateDB - Check StateDB module support
44 0 0       0 $Apache::ASP::State::DB{$self->{state_db}} ||
45             $self->Error("$self->{state_db} is not supported for StateDB, try: " .
46             join(", ", keys %Apache::ASP::State::DB));
47 0         0 $self->{state_db} =~ /^(.*)$/; # untaint
48 0         0 $self->{state_db} = $1; # untaint
49             # load the state database module && serializer
50 0         0 $self->LoadModule('StateDB', $self->{state_db});
51             }
52 28 50       122 if($self->{state_serializer} = &config($self, 'StateSerializer')) {
53 0         0 $self->{state_serializer} =~ tr///; # untaint
54 0         0 $self->LoadModule('StateSerializer', $self->{state_serializer});
55             }
56              
57             # INTERNAL tie to the application internal info
58 28         58 my %Internal;
59 28 50       188 tie(%Internal, 'Apache::ASP::State', $self, 'internal', 'server')
60             || $self->Error("can't tie to internal state");
61 28         118 my $internal = $self->{Internal} = bless \%Internal, 'Apache::ASP::State';
62 28 50       104 $self->{state_serialize} && $internal->LOCK;
63              
64             # APPLICATION create application object
65 28         121 $self->{app_state} = &config($self, 'AllowApplicationState', undef, 1);
66 28 50       122 if($self->{app_state}) {
67             # load at runtime for CGI environments, preloaded for mod_perl
68 28         7995 require Apache::ASP::Application;
69              
70 28 50       170 ($self->{Application} = &Apache::ASP::Application::new($self))
71             || $self->Error("can't get application state");
72 28 50       118 $self->{state_serialize} && $self->{Application}->Lock;
73              
74             } else {
75 0 0       0 $self->{dbg} && $self->Debug("no application allowed config");
76             }
77              
78             # SESSION if we are tracking state, set up the appropriate objects
79 28         71 my $session;
80 28 50       90 if($self->{session_state}) {
81             ## SESSION INITS
82 28         104 $self->{cookie_path} = &config($self, 'CookiePath', undef, '/');
83 28         90 $self->{cookie_domain} = &config($self, 'CookieDomain');
84 28         102 $self->{paranoid_session} = &config($self, 'ParanoidSession');
85 28         805 $self->{remote_ip} = $r->connection()->remote_ip();
86 28         1037 $self->{session_count} = &config($self, 'SessionCount');
87            
88             # cookieless session support, cascading values
89 28         104 $self->{session_url_parse_match} = &config($self, 'SessionQueryParseMatch');
90 28   66     165 $self->{session_url_parse} = $self->{session_url_parse_match} || &config($self, 'SessionQueryParse');
91 28   33     157 $self->{session_url_match} = $self->{session_url_parse_match} || &config($self, 'SessionQueryMatch');
92 28   100     301 $self->{session_url} = $self->{session_url_parse} || $self->{session_url_match} || &config($self, 'SessionQuery');
93 28         105 $self->{session_url_force} = &config($self, 'SessionQueryForce');
94            
95 28         104 $self->{session_serialize} = &config($self, 'SessionSerialize');
96 28         95 $self->{secure_session} = &config($self, 'SecureSession');
97             # session timeout in seconds since that is what we work with internally
98 28         115 $self->{session_timeout} = &config($self, 'SessionTimeout', undef, $SessionTimeout) * 60;
99 28   50     122 $self->{'ua'} = $self->{headers_in}->get('User-Agent') || 'UNKNOWN UA';
100             # refresh group by some increment smaller than session timeout
101             # to withstand DoS, bruteforce guessing attacks
102             # defaults to checking the group once every 2 minutes
103 28         152 $self->{group_refresh} = int($self->{session_timeout} / $self->{state_manager});
104            
105             # Session state is dependent on internal state
106              
107             # load at runtime for CGI environments, preloaded for mod_perl
108 28         6674 require Apache::ASP::Session;
109              
110 28   33     140 $session = $self->{Session} = &Apache::ASP::Session::new($self)
111             || $self->Die("can't create session");
112 28 50       114 $self->{state_serialize} && $session->Lock();
113            
114             } else {
115 0 0       0 $self->{dbg} && $self->Debug("no sessions allowed config");
116             }
117              
118             # update after long state init, possible with SessionSerialize config
119 28         182 $self->{Response}->IsClientConnected();
120              
121             # POSTPOSE STATE EVENTS, so we can delay the Response object creation
122             # until after the state objects are created
123 28 50       90 if($session) {
124 28         51 my $last_session_timeout;
125 28 50       117 if($session->Started()) {
126             # we only want one process purging at a time
127 28 50       107 if($self->{app_state}) {
128 28         111 $internal->LOCK();
129 28 100 100     6089 if(($last_session_timeout = $internal->{LastSessionTimeout} || 0) < time()) {
130 1         5 $internal->{'LastSessionTimeout'} = $self->{session_timeout} + time;
131 1         3 $internal->UNLOCK();
132 1         37 $self->{Application}->Lock;
133 1         239 my $obj = tied(%{$self->{Application}});
  1         4  
134 1 50       4 if($self->CleanupGroups('PURGE')) {
135 1 50       3 $last_session_timeout && $global_asa->ApplicationOnEnd();
136 1         5 $global_asa->ApplicationOnStart();
137             }
138 1         6 $self->{Application}->UnLock;
139             }
140 28         171 $internal->UNLOCK();
141             }
142 28         1360 $global_asa->SessionOnStart();
143             }
144              
145 28 50       111 if($self->{app_state}) {
146             # The last session timeout should only be updated every group_refresh period
147             # another optimization, rand() so not all at once either
148 28         108 $internal->LOCK();
149 28   66     5968 $last_session_timeout ||= $internal->{'LastSessionTimeout'};
150 28 100       228 if($last_session_timeout < $self->{session_timeout} + time +
151             (rand() * $self->{group_refresh} / 2))
152             {
153 4 50       24 $self->{dbg} && $self->Debug("updating LastSessionTimeout from $last_session_timeout");
154 4         26 $internal->{'LastSessionTimeout'} =
155             $self->{session_timeout} + time() + $self->{group_refresh};
156             }
157 28         418 $internal->UNLOCK();
158             }
159             }
160              
161 28         1271 $self;
162             }
163              
164             # Cleanup a state group, by default the group of the current session
165             # We do this currently in DESTROY, which happens after the current
166             # script has been executed, so that cleanup doesn't happen until
167             # after output to user
168             #
169             # We always exit unless there is a $Session defined, since we only
170             # cleanup groups of sessions if sessions are allowed for this script
171             sub CleanupGroup {
172 74     74 0 173 my($self, $group_id, $force) = @_;
173 74 50       200 return unless $self->{Session};
174              
175 74         96 my $asp = $self; # bad hack for some moved around code
176 74   100     168 $force ||= 0;
177              
178             # GET GROUP_ID
179 74         78 my $state;
180 74 50       199 unless($group_id) {
181 0         0 $state = $self->{Session}{_STATE};
182 0         0 $group_id = $state->GroupId();
183             }
184              
185             # we must have a group id to work with
186 74 50       146 $asp->Error("no group id") unless $group_id;
187 74         125 my $group_key = "GroupId" . $group_id;
188              
189             # cleanup timed out sessions, from current group
190 74         950 my $internal = $asp->{Internal};
191 74         222 $internal->LOCK();
192 74   100     11022 my $group_check = $internal->{$group_key} || 0;
193 74 50 66     427 unless($force || ($group_check < time())) {
194 0         0 $internal->UNLOCK();
195 0         0 return;
196             }
197            
198             # set the next group_check, randomize a bit to unclump the group checks,
199             # for 20 minute session timeout, had rand() / 2 + .5, but it was still
200             # too clumpy, going with pure rand() now, even if a bit less efficient
201              
202 74         238 my $next_check = int($asp->{group_refresh} * rand()) + 1;
203 74         369 $internal->{$group_key} = time() + $next_check;
204 74         276 $internal->UNLOCK();
205              
206             ## GET STATE for group
207 74   33     2882 $state ||= &Apache::ASP::State::new($asp, $group_id);
208 74   50     256 my $ids = $state->GroupMembers() || [];
209              
210             # don't return so we can't delete the empty group later
211             # return unless scalar(@$ids);
212              
213 74 50       201 $asp->{dbg} && $asp->Debug("group check $group_id, next in $next_check sec");
214 74         299 my $id = $self->{Session}->SessionID();
215 74         116 my $deleted = 0;
216 74         219 $internal->LOCK();
217 74 50       10448 $asp->{dbg} && $asp->Debug("checking group ids", $ids);
218 74         159 for my $id (@$ids) {
219 57         89 eval {
220              
221             # if($id eq $_) {
222             # $asp->{dbg} && $asp->Debug("skipping delete self", {id => $id});
223             # next;
224             # }
225            
226             # we lock the internal, so a session isn't being initialized
227             # while we are garbage collecting it... we release it every
228             # time so we don't starve session creation if this is a large
229             # directory that we are garbage collecting
230 57         285 my $idata = $internal->{$id};
231            
232             # do this check in case this data is corrupt, and not deserialized, correctly
233 57 50 33     404 unless(ref($idata) && (ref($idata) eq 'HASH')) {
234 0         0 $idata = {};
235             }
236              
237 57   50     172 my $timeout = $idata->{timeout} || 0;
238            
239 57 50       128 unless($timeout) {
240             # we don't have the timeout always, since this session
241             # may just have been created, just in case this is
242             # a corrupted session (does this happen still ??), we give it
243             # a timeout now, so we will be sure to clean it up
244             # eventualy
245 0         0 $idata->{timeout} = time() + $asp->{session_timeout};
246 0         0 $internal->{$id} = $idata;
247 0         0 $asp->Debug("resetting timeout for $id to $idata->{timeout}");
248 0         0 return; # no next in eval {}
249             }
250             # only delete sessions that have timed out
251 57 100       153 unless($timeout < time()) {
252 42 50       117 $asp->{dbg} && $asp->Debug("$id not timed out with $timeout");
253 42         108 return; # no next in eval {}
254             }
255            
256             # UPDATE & UNLOCK, as soon as we update internal, we may free it
257             # definately don't lock around SessionOnEnd, as it might take
258             # a while to process
259            
260             # set the timeout for this session forward so it won't
261             # get garbage collected by another process
262 15 50       45 $asp->{dbg} && $asp->Debug("resetting timeout for deletion lock on $id");
263 15         103 $internal->{$id} = {
264 15         22 %{$internal->{$id}},
265             'timeout' => time() + $asp->{session_timeout},
266             'end' => 1,
267             };
268            
269            
270             # unlock many times in case we are locked above this loop
271 15         93 for (1..3) { $internal->UNLOCK() }
  45         930  
272 15         183 $asp->{GlobalASA}->SessionOnEnd($id);
273 15         50 $internal->LOCK;
274            
275             # set up state
276 15         3028 my($member_state) = Apache::ASP::State::new($asp, $id);
277 15 50       70 if(my $count = $member_state->Delete()) {
278 15 50       10369 $asp->{dbg} &&
279             $asp->Debug("deleting session", {
280             session_id => $id,
281             files_deleted => $count,
282             });
283 15         30 $deleted++;
284 15         125 delete $internal->{$id};
285             } else {
286 0         0 $asp->Error("can't delete session id: $id");
287 0         0 return; # no next in eval {}
288             }
289             };
290 57 50       343 if($@) {
291 0         0 $asp->Error("error for cleanup of session id $id: $@");
292             }
293             }
294 74         232 $internal->UNLOCK();
295              
296             #### LEAVE DIRECTORIES, NASTY RACE CONDITION POTENTIAL
297             ## NOW PRUNE ONLY DIRECTORIES THAT WE DON'T NEED TO KEEP
298             ## FOR PERFORMANCE
299             # REMOVE DIRECTORY, LOCK
300             # if the directory is still empty, remove it, lock it
301             # down so no new sessions will be created in it while we
302             # are testing
303 74 100       2471 if($deleted == @$ids) {
304 43 50       221 if ($state->GroupId !~ /^[0]/) {
305 0         0 $asp->{Internal}->LOCK();
306 0         0 my $ids = $state->GroupMembers();
307 0 0       0 if(@{$ids} == 0) {
  0         0  
308 0         0 $self->Log("purging stale group ".$state->GroupId.", which should only happen ".
309             "after Apache::ASP upgrade to beyond 2.09");
310 0         0 $state->DeleteGroupId();
311             }
312 0         0 $asp->{Internal}->UNLOCK();
313             }
314             }
315              
316 74         323 $deleted;
317             }
318              
319             sub CleanupGroups {
320 34     34 0 97 my($self, $force) = @_;
321 34 50       167 return unless $self->{Session};
322              
323 34         63 my $cleanup = 0;
324 34         82 my $state_dir = $self->{state_dir};
325 34         111 my $internal = $self->{Internal};
326 34   100     173 $force ||= 0;
327              
328 34 50 66     258 $self->Debug("forcing groups cleanup") if ($self->{dbg} && $force);
329              
330             # each apache process has an internal time in which it
331             # did its last check, once we have passed that, we check
332             # $Internal for the last time the check was done. We
333             # break it up in this way so that locking on $Internal
334             # does not become another bottleneck for scripts
335 34 100 100     354 if($force || ($Apache::ASP::CleanupGroups{$state_dir} || 0) < time()) {
      100        
336             # /8 to keep it less bursty... since we check groups every group_refresh/2
337             # we'll average 1/4 of the groups everytime we check them on a busy server
338 17         89 $Apache::ASP::CleanupGroups{$state_dir} = time() + $self->{group_refresh}/8;
339 17 100       92 $self->{dbg} && $self->Debug("testing internal time for cleanup groups");
340 17 100       86 if($self->CleanupMaster) {
341 8         35 $internal->LOCK();
342 8 50 66     1587 if($force || ($internal->{CleanupGroups} < (time - $self->{group_refresh}/8))) {
343 8         49 $internal->{CleanupGroups} = time;
344 8         24 $cleanup = 1;
345             }
346 8         32 $internal->UNLOCK;
347             }
348             }
349 34 100       487 return unless $cleanup;
350              
351             # clean cache, so caching won't affect CleanupGroups() being called multiple times
352 8         24 $self->{internal_cached_keys} = undef;
353              
354             # only one process doing CleanupGroup at a time now, so OK
355             # lock around, necessary when keeping empty group directories
356 8         70 my $groups = $self->{Session}{_SELF}{'state'}->DefaultGroups();
357 8 50       44 $self->{dbg} && $self->Debug("groups ", $groups);
358 8         14 my($sum_active, $sum_deleted);
359 8         34 $internal->LOCK();
360 8         1644 my $start_cleanup = time;
361 8         18 for(@{$groups}) {
  8         25  
362 74         210 $sum_deleted = $self->CleanupGroup($_, $force);
363 74 50       332 if ($start_cleanup > time) {
364             # every second, take a breather in the lock management
365             # so that sessions can be created, and the like, so for
366             # long purges, the application will get sticky in 1 second
367             # bursts
368 0         0 $start_cleanup = time;
369 0         0 $internal->UNLOCK;
370 0         0 $internal->LOCK;
371 0 0       0 last unless $self->CleanupMaster;
372             }
373             }
374 8         36 $internal->UNLOCK();
375 8 50 0     218 $self->{dbg} && $self->Debug("cleanup groups", { deleted => $sum_deleted }) if $self->{dbg};
376              
377             # boolean true at least for master
378 8 100       66 $sum_deleted || 1;
379             }
380              
381             sub CleanupMaster {
382 17     17 0 36 my $self = shift;
383 17         44 my $internal = $self->{Internal};
384            
385 17         81 $internal->LOCK;
386 17   100     4017 my $master = $internal->{CleanupMaster} ||
387             {
388             ServerID => '',
389             PID => 0,
390             Checked => 0,
391             };
392              
393 17 100 66     168 my $is_master = (($master->{ServerID} eq $ServerID) and ($master->{PID} eq $$)) ? 1 : 0;
394 17 100       81 $self->{dbg} && $self->Debug(current_master => $master, is_master => $is_master );
395 17 100       135 my $stale_time = $is_master ? $self->{group_refresh} / 4 :
396             $self->{group_refresh} / 2 + int($self->{group_refresh} * rand() / 2) + 1;
397 17         42 $stale_time += $master->{Checked};
398            
399 17 100       106 if($stale_time < time()) {
    100          
400 4         37 $internal->{CleanupMaster} =
401             {
402             ServerID => $ServerID,
403             PID => $$,
404             Checked => time()
405             };
406 4         28 $internal->UNLOCK; # flush write
407 4 50       191 $self->{dbg} && $self->Debug("$stale_time time is stale, is_master $is_master", $master);
408            
409             # we are only worried about multiprocess NFS here ... if running not
410             # in mod_perl mode, probably just CGI mounted on local disk
411             # Only do this while in DESTROY() mode too, so we avoid Application_OnStart
412             # hang behavior.
413 4 50 33     54 if($^O !~ /Win/ && $ENV{MOD_PERL} && $self->{DESTROY}) {
      33        
414 0         0 $self->Debug("sleep for acquire master check in case of shared state");
415 0         0 sleep(1);
416             }
417            
418 4         22 my $master = $internal->{CleanupMaster}; # recheck after flush
419 4 50 33     54 my $is_master = (($master->{ServerID} eq $ServerID) and ($master->{PID} eq $$)) ? 1 : 0;
420 4 50       15 $self->{dbg} && $self->Debug("is_master $is_master after update $ServerID - $$");
421 4         27 $is_master;
422             } elsif($is_master) {
423 4         11 $master->{Checked} = time();
424 4         21 $internal->{CleanupMaster} = $master;
425 4         17 $internal->UNLOCK;
426 4 50       198 $self->{dbg} && $self->Debug("$stale_time time is fresh, is_master $is_master", $master);
427 4         22 1; # is master
428             } else {
429 9         45 $internal->UNLOCK;
430 9 100       464 $self->{dbg} && $self->Debug("$stale_time time is fresh, is_master $is_master", $master);
431 9         54 0; # not master
432             }
433             }
434              
435             # combo get / set
436             sub SessionId {
437 58     58 0 126 my($self, $id) = @_;
438              
439 58 100       166 if(defined $id) {
440 30 50       102 unless($self->{session_url_force}) {
441             # don't set the cookie when we are just using SessionQuery* configs
442 30 100       102 my $secure = $self->{secure_session} ? '; secure' : '';
443 30 100       106 my $domain = $self->{cookie_domain} ? '; domain='.$self->{cookie_domain} : '';
444 30         865 $self->{r}->err_headers_out->add('Set-Cookie', "$SessionCookieName=$id; path=$self->{cookie_path}".$domain.$secure);
445             }
446 30         101 $self->{session_id} = $id;
447             } else {
448             # if we have already parsed it out, return now
449             # quick session_id caching, mostly for use with
450             # cookie less url building
451 28 50       114 $self->{session_id} && return $self->{session_id};
452              
453 28         58 my $session_cookie = 0;
454              
455 28 50       108 unless($self->{session_url_force}) {
456             # don't read the cookie when we are just using SessionQuery* configs
457 28   50     866 my $cookie = $self->{r}->headers_in->{"Cookie"} || '';
458 28         444 my(@parts) = split(/\;\s*/, $cookie);
459 28         93 for(@parts) {
460 0         0 my($name, $value) = split(/\=/, $_, 2);
461 0 0       0 if($name eq $SessionCookieName) {
462 0         0 $id = $value;
463 0         0 $session_cookie = 1;
464 0 0       0 $self->{dbg} && $self->Debug("session id from cookie: $id");
465 0         0 last;
466             }
467             }
468             }
469              
470 28         42 my $session_from_url;
471 28 100 66     218 if(! defined($id) && $self->{session_url}) {
472 16         93 $id = delete $self->{Request}{QueryString}{$SessionCookieName};
473             # if there was more than one session id in the query string, then just
474             # take the first one
475 16 50       43 ref($id) =~ /ARRAY/ and ($id) = @$id;
476 16 50 66     55 $id && $self->{dbg} && $self->Debug("session id from query string: $id");
477 16         25 $session_from_url = 1;
478             }
479              
480             # SANTIZE the id against hacking
481 28 100       85 if(defined $id) {
482 2 50       13 if($id =~ /^[0-9a-z]{8,32}$/s) {
483             # at least 8 bytes, but less than 32 bytes
484 2         7 $self->{session_id} = $id;
485             } else {
486 0         0 $self->Log("passed in session id $id failed checks sanity checks");
487 0         0 $id = undef;
488             }
489             }
490              
491 28 100 100     166 if ($session_from_url && defined $id) {
492 2         10 $self->SessionId($id);
493             }
494              
495 28 100       109 if(defined $id) {
496 2         4 $self->{session_id} = $id;
497 2         6 $self->{session_cookie} = $session_cookie;
498             }
499             }
500              
501 58         212 $id;
502             }
503              
504             sub Secret {
505 28     28 0 53 my $self = shift;
506             # have enough data in here that even if srand() is seeded for the purpose
507             # of debugging an external program, should have decent behavior.
508 28         561 my $data = $self . $self->{remote_ip} . rand() . time() .
509             $self->{global} . $self->{'r'} . $self->{'filename'}.
510             $$ . $ServerID;
511 28         228 my $secret = substr(md5_hex($data), 0, $SessionIDLength);
512             # by having [0-1][0-f] as the first 2 chars, only 32 groups now, which remains
513             # efficient for inactive sites, even with empty groups
514 28         138 $secret =~ s/^(.)/0/;
515 28         101 $secret;
516             }
517              
518             sub RefreshSessionId {
519 28     28 0 71 my($self, $id, $reset) = @_;
520 28 50       98 $id || $self->Error("no id for refreshing");
521 28         67 my $internal = $self->{Internal};
522              
523 28         113 $internal->LOCK;
524 28         455 my $idata = $internal->{$id};
525 28 50 0     139 my $refresh_timeout = $reset ?
526             $self->{session_timeout} : $idata->{refresh_timeout} || $self->{session_timeout};
527 28         101 $idata->{'timeout'} = time() + $refresh_timeout;
528 28         201 $internal->{$id} = $idata;
529 28         135 $internal->UNLOCK;
530 28 100       261 $self->{dbg} && $self->Debug("refreshing $id with timeout $idata->{timeout}");
531              
532 28         106 1;
533             }
534              
535             1;