File Coverage

blib/lib/Apache/ASP/StateManager.pm
Criterion Covered Total %
statement 194 262 74.0
branch 73 158 46.2
condition 39 82 47.6
subroutine 10 10 100.0
pod 0 7 0.0
total 316 519 60.9


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 6     6   141 use Apache::ASP::State;
  6         82  
  6         157  
8              
9 6     6   119 use strict;
  6         57  
  6         148  
10 6         104 use vars qw(
11             $CleanupGroups
12             $SessionIDLength $SessionTimeout $StateManager
13             $DefaultStateDB $DefaultStateSerializer
14 6     6   93 );
  6         55  
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 7     7 0 78     my $self = shift;
28 7         84     my $r = $self->{r};
29 7         78     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 7         99     $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 7         106     $self->{state_dir} = &config($self, 'StateDir', undef, $self->{global}.'/.state');
38 7         81     $self->{state_dir} =~ tr///; # untaint
39 7         92     $self->{session_state} = &config($self, 'AllowSessionState', undef, 1);
40 7         91     $self->{state_serialize} = &config($self, 'ApplicationSerialize');
41              
42 7 50       90     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 7 50       89     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 7         367     my %Internal;
59 7 50       97     tie(%Internal, 'Apache::ASP::State', $self, 'internal', 'server')
60                   || $self->Error("can't tie to internal state");
61 7         171     my $internal = $self->{Internal} = bless \%Internal, 'Apache::ASP::State';
62 7 50       153     $self->{state_serialize} && $internal->LOCK;
63              
64             # APPLICATION create application object
65 7         96     $self->{app_state} = &config($self, 'AllowApplicationState', undef, 1);
66 7 50       88     if($self->{app_state}) {
67             # load at runtime for CGI environments, preloaded for mod_perl
68 7         210 require Apache::ASP::Application;
69              
70 7 50       99 ($self->{Application} = &Apache::ASP::Application::new($self))
71             || $self->Error("can't get application state");
72 7 50       147 $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 7         64     my $session;
80 7 50       89     if($self->{session_state}) {
81             ## SESSION INITS
82 7         111 $self->{cookie_path}       = &config($self, 'CookiePath', undef, '/');
83 7         137 $self->{cookie_domain}     = &config($self, 'CookieDomain');
84 7         90 $self->{paranoid_session}  = &config($self, 'ParanoidSession');
85 7         161 $self->{remote_ip}         = $r->connection()->remote_ip();
86 7         122 $self->{session_count}     = &config($self, 'SessionCount');
87            
88             # cookieless session support, cascading values
89 7         119 $self->{session_url_parse_match} = &config($self, 'SessionQueryParseMatch');
90 7   33     147 $self->{session_url_parse} = $self->{session_url_parse_match} || &config($self, 'SessionQueryParse');
91 7   33     110 $self->{session_url_match} = $self->{session_url_parse_match} || &config($self, 'SessionQueryMatch');
92 7   33     147 $self->{session_url} = $self->{session_url_parse} || $self->{session_url_match} || &config($self, 'SessionQuery');
      33        
93 7         85 $self->{session_url_force} = &config($self, 'SessionQueryForce');
94            
95 7         86 $self->{session_serialize} = &config($self, 'SessionSerialize');
96 7         87 $self->{secure_session}    = &config($self, 'SecureSession');
97             # session timeout in seconds since that is what we work with internally
98 7         91 $self->{session_timeout}   = &config($self, 'SessionTimeout', undef, $SessionTimeout) * 60;
99 7   50     108 $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 7         139 $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 7         289 require Apache::ASP::Session;
109              
110 7   33     108 $session = $self->{Session} = &Apache::ASP::Session::new($self)
111             || $self->Die("can't create session");
112 7 50       94 $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 7         124     $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 7 50       77     if($session) {
124 7         68 my $last_session_timeout;
125 7 50       331 if($session->Started()) {
126             # we only want one process purging at a time
127 7 50       86 if($self->{app_state}) {
128 7         96 $internal->LOCK();
129 7 100 100     378 if(($last_session_timeout = $internal->{LastSessionTimeout} || 0) < time()) {
130 1         15 $internal->{'LastSessionTimeout'} = $self->{session_timeout} + time;
131 1         48 $internal->UNLOCK();
132 1         14 $self->{Application}->Lock;
133 1         10 my $obj = tied(%{$self->{Application}});
  1         12  
134 1 50       15 if($self->CleanupGroups('PURGE')) {
135 1 50       13 $last_session_timeout && $global_asa->ApplicationOnEnd();
136 1         17 $global_asa->ApplicationOnStart();
137             }
138 1         16 $self->{Application}->UnLock;
139             } 
140 7         458 $internal->UNLOCK();
141             }
142 7         107 $global_asa->SessionOnStart();
143             }
144              
145 7 50       102 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 7         99 $internal->LOCK();
149 7   100     90 $last_session_timeout ||= $internal->{'LastSessionTimeout'};
150 7 100       327 if($last_session_timeout < $self->{session_timeout} + time +
151             (rand() * $self->{group_refresh} / 2))
152             {
153 2 50       26 $self->{dbg} && $self->Debug("updating LastSessionTimeout from $last_session_timeout");
154 2         27 $internal->{'LastSessionTimeout'} =
155             $self->{session_timeout} + time() + $self->{group_refresh};
156             }
157 7         108 $internal->UNLOCK();
158             }
159                 }
160              
161 7         98     $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 6     6 0 62     my($self, $group_id, $force) = @_;
173 6 50       67     return unless $self->{Session};
174              
175 6         52     my $asp = $self; # bad hack for some moved around code
176 6   100     61     $force ||= 0;
177              
178             # GET GROUP_ID
179 6         50     my $state;
180 6 50       59     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 6 50       59     $asp->Error("no group id") unless $group_id;
187 6         57     my $group_key = "GroupId" . $group_id;
188              
189             # cleanup timed out sessions, from current group
190 6         55     my $internal = $asp->{Internal};
191 6         68     $internal->LOCK();
192 6   100     76     my $group_check = $internal->{$group_key} || 0;
193 6 50 66     237     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 6         82     my $next_check = int($asp->{group_refresh} * rand()) + 1;
203 6         73     $internal->{$group_key} = time() + $next_check;
204 6         99     $internal->UNLOCK();
205              
206             ## GET STATE for group
207 6   33     84     $state ||= &Apache::ASP::State::new($asp, $group_id);
208 6   50     74     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 6 50       3889     $asp->{dbg} && $asp->Debug("group check $group_id, next in $next_check sec");
214 6         88     my $id = $self->{Session}->SessionID();
215 6         119     my $deleted = 0;
216 6         73     $internal->LOCK();
217 6 50       65     $asp->{dbg} && $asp->Debug("checking group ids", $ids);
218 6         59     for my $id (@$ids) {
219 7         97 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 7         100 my $idata = $internal->{$id};
231            
232             # do this check in case this data is corrupt, and not deserialized, correctly
233 7 50 33     140 unless(ref($idata) && (ref($idata) eq 'HASH')) {
234 0         0 $idata = {};
235             }
236              
237 7   50     76 my $timeout = $idata->{timeout} || 0;
238            
239 7 50       70 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 7 50       129 unless($timeout < time()) {
252 7 50       73 $asp->{dbg} && $asp->Debug("$id not timed out with $timeout");
253 7         77 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 0 0       0 $asp->{dbg} && $asp->Debug("resetting timeout for deletion lock on $id");
263 0         0 $internal->{$id} = {
264 0         0 %{$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 0         0 for (1..3) { $internal->UNLOCK() }
  0         0  
272 0         0 $asp->{GlobalASA}->SessionOnEnd($id);
273 0         0 $internal->LOCK;
274            
275             # set up state
276 0         0 my($member_state) = Apache::ASP::State::new($asp, $id);
277 0 0       0 if(my $count = $member_state->Delete()) {
278 0 0       0 $asp->{dbg} &&
279             $asp->Debug("deleting session", {
280             session_id => $id,
281             files_deleted => $count,
282             });
283 0         0 $deleted++;
284 0         0 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 7 50       78 if($@) {
291 0         0 $asp->Error("error for cleanup of session id $id: $@");
292             }
293                 }
294 6         76     $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 6 50       65     if($deleted == @$ids) {
304 0 0       0 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 6         62     $deleted;
317             }
318              
319             sub CleanupGroups {
320 8     8 0 181     my($self, $force) = @_;
321 8 50       187     return unless $self->{Session};
322              
323 8         91     my $cleanup = 0;
324 8         87     my $state_dir = $self->{state_dir};
325 8         80     my $internal = $self->{Internal};
326 8   100     160     $force ||= 0;
327              
328 8 50 33     106     $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 8 100 100     239     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 6         129 $Apache::ASP::CleanupGroups{$state_dir} = time() + $self->{group_refresh}/8;
339 6 50       94 $self->{dbg} && $self->Debug("testing internal time for cleanup groups");
340 6 100       77 if($self->CleanupMaster) {
341 2         29 $internal->LOCK();
342 2 50 66     32 if($force || ($internal->{CleanupGroups} < (time - $self->{group_refresh}/8))) {
343 2         25 $internal->{CleanupGroups} = time;
344 2         28 $cleanup = 1;
345             }
346 2         28 $internal->UNLOCK;
347             }
348                 }
349 8 100       116     return unless $cleanup;
350              
351             # clean cache, so caching won't affect CleanupGroups() being called multiple times
352 2         25     $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 2         28     my $groups = $self->{Session}{_SELF}{'state'}->DefaultGroups();
357 2 50       38     $self->{dbg} && $self->Debug("groups ", $groups);
358 2         19     my($sum_active, $sum_deleted);
359 2         25     $internal->LOCK();
360 2         33     my $start_cleanup = time;
361 2         20     for(@{$groups}) {
  2         23  
362 6         73 $sum_deleted = $self->CleanupGroup($_, $force);
363 6 50       218 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 2         28     $internal->UNLOCK();
375 2 50 0     27     $self->{dbg} && $self->Debug("cleanup groups", { deleted => $sum_deleted }) if $self->{dbg};
376              
377             # boolean true at least for master
378 2 50       41     $sum_deleted || 1;
379             }
380              
381             sub CleanupMaster {
382 6     6 0 60     my $self = shift;
383 6         59     my $internal = $self->{Internal};
384                 
385 6         86     $internal->LOCK;
386 6   100     86     my $master = $internal->{CleanupMaster} ||
387                   {
388                    ServerID => '',
389                    PID => 0,
390                    Checked => 0,
391                   };
392              
393 6 50 33     176     my $is_master = (($master->{ServerID} eq $ServerID) and ($master->{PID} eq $$)) ? 1 : 0;
394 6 50       115     $self->{dbg} && $self->Debug(current_master => $master, is_master => $is_master );
395 6 50       117     my $stale_time = $is_master ? $self->{group_refresh} / 4 :
396                   $self->{group_refresh} / 2 + int($self->{group_refresh} * rand() / 2) + 1;
397 6         64     $stale_time += $master->{Checked};
398                 
399 6 100       126     if($stale_time < time()) {
    50          
400 2         32 $internal->{CleanupMaster} =
401             {
402             ServerID => $ServerID,
403             PID => $$,
404             Checked => time()
405             };
406 2         38 $internal->UNLOCK; # flush write
407 2 50       26 $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 2 50 33     49 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 2         27 my $master = $internal->{CleanupMaster}; # recheck after flush
419 2 50 33     221 my $is_master = (($master->{ServerID} eq $ServerID) and ($master->{PID} eq $$)) ? 1 : 0;
420 2 50       26 $self->{dbg} && $self->Debug("is_master $is_master after update $ServerID - $$");
421 2         35 $is_master;
422                 } elsif($is_master) {
423 0         0 $master->{Checked} = time();
424 0         0 $internal->{CleanupMaster} = $master;
425 0         0 $internal->UNLOCK;
426 0 0       0 $self->{dbg} && $self->Debug("$stale_time time is fresh, is_master $is_master", $master);
427 0         0 1; # is master
428                 } else {
429 4         56 $internal->UNLOCK;
430 4 50       47 $self->{dbg} && $self->Debug("$stale_time time is fresh, is_master $is_master", $master);
431 4         68 0; # not master
432                 }
433             }
434              
435             # combo get / set
436             sub SessionId {
437 14     14 0 155     my($self, $id) = @_;
438              
439 14 100       190     if(defined $id) {
440 7 50       88 unless($self->{session_url_force}) {
441             # don't set the cookie when we are just using SessionQuery* configs
442 7 100       123 my $secure = $self->{secure_session} ? '; secure' : '';
443 7 100       127 my $domain = $self->{cookie_domain} ? '; domain='.$self->{cookie_domain} : '';
444 7         133 $self->{r}->err_headers_out->add('Set-Cookie', "$SessionCookieName=$id; path=$self->{cookie_path}".$domain.$secure);
445             }
446 7         83 $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 7 50       91 $self->{session_id} && return $self->{session_id};
452              
453 7         70 my $session_cookie = 0;
454              
455 7 50       132 unless($self->{session_url_force}) {
456             # don't read the cookie when we are just using SessionQuery* configs
457 7   50     109 my $cookie = $self->{r}->headers_in->{"Cookie"} || '';
458 7         84 my(@parts) = split(/\;\s*/, $cookie);
459 7         151 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 7         69 my $session_from_url;
471 7 50 33     171 if(! defined($id) && $self->{session_url}) {
472 0         0 $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 0 0       0 ref($id) =~ /ARRAY/ and ($id) = @$id;
476 0 0 0     0 $id && $self->{dbg} && $self->Debug("session id from query string: $id");
477 0         0 $session_from_url = 1;
478             }
479              
480             # SANTIZE the id against hacking
481 7 50       143 if(defined $id) {
482 0 0       0 if($id =~ /^[0-9a-z]{8,32}$/s) {
483             # at least 8 bytes, but less than 32 bytes
484 0         0 $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 7 50 33     92 if ($session_from_url && defined $id) {
492 0         0 $self->SessionId($id);
493             }
494              
495 7 50       829 if(defined $id) {
496 0         0 $self->{session_id} = $id;
497 0         0 $self->{session_cookie} = $session_cookie;
498             }
499                 }
500              
501 14         186     $id;
502             }
503              
504             sub Secret {
505 7     7 0 69     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 7         385     my $data = $self . $self->{remote_ip} . rand() . time() .
509                   $self->{global} . $self->{'r'} . $self->{'filename'}.
510             $$ . $ServerID;
511 7         264     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 7         101     $secret =~ s/^(.)/0/;
515 7         88     $secret;
516             }
517              
518             sub RefreshSessionId {
519 7     7 0 78     my($self, $id, $reset) = @_;
520 7 50       80     $id || $self->Error("no id for refreshing");
521 7         73     my $internal = $self->{Internal};
522              
523 7         88     $internal->LOCK;
524 7         88     my $idata = $internal->{$id};
525 7 50 0     119     my $refresh_timeout = $reset ?
526                   $self->{session_timeout} : $idata->{refresh_timeout} || $self->{session_timeout};
527 7         137     $idata->{'timeout'} = time() + $refresh_timeout;
528 7         86     $internal->{$id} = $idata;
529 7         117     $internal->UNLOCK;
530 7 50       83     $self->{dbg} && $self->Debug("refreshing $id with timeout $idata->{timeout}");
531              
532 7         124     1;
533             }
534              
535             1;
536