home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / StateManager.pm < prev    next >
Encoding:
Perl POD Document  |  2003-05-07  |  18.9 KB  |  536 lines
  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. use Apache::ASP::State;
  8.  
  9. use strict;
  10. use vars qw(
  11.   $CleanupGroups
  12.  $SessionIDLength $SessionTimeout $StateManager
  13.   $DefaultStateDB $DefaultStateSerializer
  14. );
  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.     my $self = shift;
  28.     my $r = $self->{r};
  29.     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.     $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.     $self->{state_dir}       = &config($self, 'StateDir', undef, $self->{global}.'/.state');
  38.     $self->{state_dir}       =~ tr///; # untaint
  39.     $self->{session_state}   = &config($self, 'AllowSessionState', undef, 1);
  40.     $self->{state_serialize} = &config($self, 'ApplicationSerialize');
  41.  
  42.     if($self->{state_db} = &config($self, 'StateDB')) {
  43.     # StateDB - Check StateDB module support 
  44.     $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.     $self->{state_db} =~ /^(.*)$/; # untaint
  48.     $self->{state_db} = $1; # untaint
  49.     # load the state database module && serializer
  50.     $self->LoadModule('StateDB', $self->{state_db});
  51.     }
  52.     if($self->{state_serializer} = &config($self, 'StateSerializer')) {
  53.     $self->{state_serializer} =~ tr///; # untaint
  54.     $self->LoadModule('StateSerializer', $self->{state_serializer});
  55.     }
  56.  
  57.     # INTERNAL tie to the application internal info
  58.     my %Internal;
  59.     tie(%Internal, 'Apache::ASP::State', $self, 'internal', 'server')
  60.       || $self->Error("can't tie to internal state");
  61.     my $internal = $self->{Internal} = bless \%Internal, 'Apache::ASP::State';
  62.     $self->{state_serialize} && $internal->LOCK;
  63.  
  64.     # APPLICATION create application object
  65.     $self->{app_state} = &config($self, 'AllowApplicationState', undef, 1);
  66.     if($self->{app_state}) {
  67.     # load at runtime for CGI environments, preloaded for mod_perl
  68.     require Apache::ASP::Application;
  69.  
  70.     ($self->{Application} = &Apache::ASP::Application::new($self)) 
  71.       || $self->Error("can't get application state");
  72.     $self->{state_serialize} && $self->{Application}->Lock;
  73.  
  74.     } else {
  75.     $self->{dbg} && $self->Debug("no application allowed config");
  76.     }
  77.  
  78.     # SESSION if we are tracking state, set up the appropriate objects
  79.     my $session;
  80.     if($self->{session_state}) {
  81.     ## SESSION INITS
  82.     $self->{cookie_path}       = &config($self, 'CookiePath', undef, '/');
  83.     $self->{cookie_domain}     = &config($self, 'CookieDomain');
  84.     $self->{paranoid_session}  = &config($self, 'ParanoidSession');
  85.     $self->{remote_ip}         = $r->connection()->remote_ip();
  86.     $self->{session_count}     = &config($self, 'SessionCount');
  87.     
  88.     # cookieless session support, cascading values
  89.     $self->{session_url_parse_match} = &config($self, 'SessionQueryParseMatch');
  90.     $self->{session_url_parse} = $self->{session_url_parse_match} || &config($self, 'SessionQueryParse');
  91.     $self->{session_url_match} = $self->{session_url_parse_match} || &config($self, 'SessionQueryMatch');
  92.     $self->{session_url} = $self->{session_url_parse} || $self->{session_url_match} || &config($self, 'SessionQuery');
  93.     $self->{session_url_force} = &config($self, 'SessionQueryForce');
  94.     
  95.     $self->{session_serialize} = &config($self, 'SessionSerialize');
  96.     $self->{secure_session}    = &config($self, 'SecureSession');
  97.     # session timeout in seconds since that is what we work with internally
  98.     $self->{session_timeout}   = &config($self, 'SessionTimeout', undef, $SessionTimeout) * 60;
  99.     $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.     $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.     require Apache::ASP::Session;
  109.  
  110.     $session = $self->{Session} = &Apache::ASP::Session::new($self)
  111.       || $self->Die("can't create session");
  112.     $self->{state_serialize} && $session->Lock();
  113.     
  114.     } else {
  115.     $self->{dbg} && $self->Debug("no sessions allowed config");
  116.     }
  117.  
  118.     # update after long state init, possible with SessionSerialize config
  119.     $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.     if($session) {
  124.     my $last_session_timeout;
  125.     if($session->Started()) {
  126.         # we only want one process purging at a time
  127.         if($self->{app_state}) {
  128.         $internal->LOCK();
  129.         if(($last_session_timeout = $internal->{LastSessionTimeout} || 0) < time()) {
  130.             $internal->{'LastSessionTimeout'} = $self->{session_timeout} + time;
  131.             $internal->UNLOCK();
  132.             $self->{Application}->Lock;
  133.             my $obj = tied(%{$self->{Application}});
  134.             if($self->CleanupGroups('PURGE')) {
  135.             $last_session_timeout && $global_asa->ApplicationOnEnd();
  136.             $global_asa->ApplicationOnStart();
  137.             }
  138.             $self->{Application}->UnLock;
  139.         } 
  140.         $internal->UNLOCK();
  141.         }
  142.         $global_asa->SessionOnStart();
  143.     }
  144.  
  145.     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.         $internal->LOCK();
  149.         $last_session_timeout ||= $internal->{'LastSessionTimeout'};
  150.         if($last_session_timeout < $self->{session_timeout} + time + 
  151.            (rand() * $self->{group_refresh} / 2)) 
  152.           {
  153.           $self->{dbg} && $self->Debug("updating LastSessionTimeout from $last_session_timeout");
  154.           $internal->{'LastSessionTimeout'} = 
  155.             $self->{session_timeout} + time() + $self->{group_refresh};
  156.           }
  157.         $internal->UNLOCK();
  158.     }
  159.     }
  160.  
  161.     $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.     my($self, $group_id, $force) = @_;
  173.     return unless $self->{Session};
  174.  
  175.     my $asp = $self; # bad hack for some moved around code
  176.     $force ||= 0;
  177.  
  178.     # GET GROUP_ID
  179.     my $state;
  180.     unless($group_id) {
  181.     $state = $self->{Session}{_STATE};
  182.     $group_id = $state->GroupId();
  183.     }
  184.  
  185.     # we must have a group id to work with
  186.     $asp->Error("no group id") unless $group_id;
  187.     my $group_key = "GroupId" . $group_id;
  188.  
  189.     # cleanup timed out sessions, from current group
  190.     my $internal = $asp->{Internal};
  191.     $internal->LOCK();
  192.     my $group_check = $internal->{$group_key} || 0;
  193.     unless($force || ($group_check < time())) {
  194.     $internal->UNLOCK();
  195.     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.     my $next_check = int($asp->{group_refresh} * rand()) + 1;
  203.     $internal->{$group_key} = time() + $next_check;
  204.     $internal->UNLOCK();
  205.  
  206.     ## GET STATE for group
  207.     $state ||= &Apache::ASP::State::new($asp, $group_id);
  208.     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.     $asp->{dbg} && $asp->Debug("group check $group_id, next in $next_check sec");
  214.     my $id = $self->{Session}->SessionID();
  215.     my $deleted = 0;
  216.     $internal->LOCK();
  217.     $asp->{dbg} && $asp->Debug("checking group ids", $ids);
  218.     for my $id (@$ids) {
  219.     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.         my $idata = $internal->{$id};
  231.         
  232.         # do this check in case this data is corrupt, and not deserialized, correctly
  233.         unless(ref($idata) && (ref($idata) eq 'HASH')) {
  234.         $idata = {};
  235.         }
  236.  
  237.         my $timeout = $idata->{timeout} || 0;
  238.         
  239.         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.         $idata->{timeout} = time() + $asp->{session_timeout};
  246.         $internal->{$id} = $idata;
  247.         $asp->Debug("resetting timeout for $id to $idata->{timeout}");
  248.         return; # no next in eval {}
  249.         }    
  250.         # only delete sessions that have timed out
  251.         unless($timeout < time()) {
  252.         $asp->{dbg} && $asp->Debug("$id not timed out with $timeout");
  253.         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.         $asp->{dbg} && $asp->Debug("resetting timeout for deletion lock on $id");
  263.         $internal->{$id} = {
  264.                 %{$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.         for (1..3) { $internal->UNLOCK() }
  272.         $asp->{GlobalASA}->SessionOnEnd($id);
  273.         $internal->LOCK;
  274.         
  275.         # set up state
  276.         my($member_state) = Apache::ASP::State::new($asp, $id);    
  277.         if(my $count = $member_state->Delete()) {
  278.         $asp->{dbg} && 
  279.           $asp->Debug("deleting session", {
  280.                            session_id => $id, 
  281.                            files_deleted => $count,
  282.                           });
  283.         $deleted++;
  284.         delete $internal->{$id};
  285.         } else {
  286.         $asp->Error("can't delete session id: $id");
  287.         return; # no next in eval {}
  288.         }
  289.     };
  290.     if($@) {
  291.         $asp->Error("error for cleanup of session id $id: $@");
  292.     }
  293.     }
  294.     $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.     if($deleted == @$ids) {
  304.     if ($state->GroupId !~ /^[0]/) {
  305.         $asp->{Internal}->LOCK();
  306.         my $ids = $state->GroupMembers();
  307.         if(@{$ids} == 0) {
  308.         $self->Log("purging stale group ".$state->GroupId.", which should only happen ".
  309.                "after Apache::ASP upgrade to beyond 2.09");
  310.         $state->DeleteGroupId();
  311.         }
  312.         $asp->{Internal}->UNLOCK();
  313.     }
  314.     }
  315.  
  316.     $deleted;
  317. }
  318.  
  319. sub CleanupGroups {
  320.     my($self, $force) = @_;
  321.     return unless $self->{Session};
  322.  
  323.     my $cleanup = 0;
  324.     my $state_dir = $self->{state_dir};
  325.     my $internal = $self->{Internal};
  326.     $force ||= 0;
  327.  
  328.     $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.     if($force || ($Apache::ASP::CleanupGroups{$state_dir} || 0) < time()) {
  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.     $Apache::ASP::CleanupGroups{$state_dir} = time() + $self->{group_refresh}/8;
  339.     $self->{dbg} && $self->Debug("testing internal time for cleanup groups");
  340.     if($self->CleanupMaster) {
  341.         $internal->LOCK();
  342.         if($force || ($internal->{CleanupGroups} < (time - $self->{group_refresh}/8))) {
  343.         $internal->{CleanupGroups} = time;
  344.         $cleanup = 1;
  345.         }
  346.         $internal->UNLOCK;
  347.     }
  348.     }
  349.     return unless $cleanup;
  350.  
  351.     # clean cache, so caching won't affect CleanupGroups() being called multiple times
  352.     $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.     my $groups = $self->{Session}{_SELF}{'state'}->DefaultGroups();
  357.     $self->{dbg} && $self->Debug("groups ", $groups);
  358.     my($sum_active, $sum_deleted);
  359.     $internal->LOCK();
  360.     my $start_cleanup = time;
  361.     for(@{$groups}) {
  362.     $sum_deleted = $self->CleanupGroup($_, $force);
  363.     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.         $start_cleanup = time;
  369.         $internal->UNLOCK;
  370.         $internal->LOCK;
  371.         last unless $self->CleanupMaster;
  372.     }
  373.     }
  374.     $internal->UNLOCK();
  375.     $self->{dbg} && $self->Debug("cleanup groups", { deleted => $sum_deleted }) if $self->{dbg};
  376.  
  377.     # boolean true at least for master
  378.     $sum_deleted || 1; 
  379. }
  380.  
  381. sub CleanupMaster {
  382.     my $self = shift;
  383.     my $internal = $self->{Internal};
  384.     
  385.     $internal->LOCK;
  386.     my $master = $internal->{CleanupMaster} || 
  387.       {
  388.        ServerID => '',
  389.        PID => 0,
  390.        Checked => 0,       
  391.       };
  392.  
  393.     my $is_master = (($master->{ServerID} eq $ServerID) and ($master->{PID} eq $$)) ? 1 : 0;
  394.     $self->{dbg} && $self->Debug(current_master => $master, is_master => $is_master );
  395.     my $stale_time = $is_master ? $self->{group_refresh} / 4 : 
  396.       $self->{group_refresh} / 2 + int($self->{group_refresh} * rand() / 2) + 1;
  397.     $stale_time += $master->{Checked};
  398.     
  399.     if($stale_time < time()) {
  400.     $internal->{CleanupMaster} =
  401.       {
  402.        ServerID => $ServerID,
  403.        PID => $$,
  404.        Checked => time()
  405.       };
  406.     $internal->UNLOCK; # flush write
  407.     $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.     if($^O !~ /Win/ && $ENV{MOD_PERL} && $self->{DESTROY}) {
  414.         $self->Debug("sleep for acquire master check in case of shared state");
  415.         sleep(1);
  416.     }
  417.     
  418.     my $master = $internal->{CleanupMaster}; # recheck after flush
  419.     my $is_master = (($master->{ServerID} eq $ServerID) and ($master->{PID} eq $$)) ? 1 : 0;
  420.     $self->{dbg} && $self->Debug("is_master $is_master after update $ServerID - $$");
  421.     $is_master;
  422.     } elsif($is_master) {
  423.     $master->{Checked} = time();
  424.     $internal->{CleanupMaster} = $master;
  425.     $internal->UNLOCK;
  426.     $self->{dbg} && $self->Debug("$stale_time time is fresh, is_master $is_master", $master);
  427.     1; # is master
  428.     } else {
  429.     $internal->UNLOCK;
  430.     $self->{dbg} && $self->Debug("$stale_time time is fresh, is_master $is_master", $master);
  431.     0; # not master
  432.     }
  433. }
  434.  
  435. # combo get / set
  436. sub SessionId {
  437.     my($self, $id) = @_;
  438.  
  439.     if(defined $id) {
  440.     unless($self->{session_url_force}) {
  441.         # don't set the cookie when we are just using SessionQuery* configs
  442.         my $secure = $self->{secure_session} ? '; secure' : '';
  443.         my $domain = $self->{cookie_domain}  ? '; domain='.$self->{cookie_domain} : '';
  444.         $self->{r}->err_headers_out->add('Set-Cookie', "$SessionCookieName=$id; path=$self->{cookie_path}".$domain.$secure);
  445.     }
  446.     $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.     $self->{session_id} && return $self->{session_id};
  452.  
  453.     my $session_cookie = 0;
  454.  
  455.     unless($self->{session_url_force}) {
  456.         # don't read the cookie when we are just using SessionQuery* configs
  457.         my $cookie = $self->{r}->headers_in->{"Cookie"} || '';
  458.         my(@parts) = split(/\;\s*/, $cookie);
  459.         for(@parts) {    
  460.         my($name, $value) = split(/\=/, $_, 2);
  461.         if($name eq $SessionCookieName) {
  462.             $id = $value;
  463.             $session_cookie = 1;
  464.             $self->{dbg} && $self->Debug("session id from cookie: $id");
  465.             last;
  466.         }
  467.         }
  468.     }
  469.  
  470.     my $session_from_url;
  471.     if(! defined($id) && $self->{session_url}) {
  472.         $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.         ref($id) =~ /ARRAY/ and ($id) = @$id;
  476.         $id && $self->{dbg} && $self->Debug("session id from query string: $id");
  477.         $session_from_url = 1;
  478.     }
  479.  
  480.     # SANTIZE the id against hacking
  481.     if(defined $id) {
  482.         if($id =~ /^[0-9a-z]{8,32}$/s) {
  483.         # at least 8 bytes, but less than 32 bytes
  484.         $self->{session_id} = $id;
  485.         } else {
  486.         $self->Log("passed in session id $id failed checks sanity checks");
  487.         $id = undef;        
  488.         }
  489.     }
  490.  
  491.     if ($session_from_url && defined $id) {
  492.         $self->SessionId($id);
  493.     }
  494.  
  495.     if(defined $id) {
  496.         $self->{session_id} = $id;
  497.         $self->{session_cookie} = $session_cookie;
  498.     }
  499.     }
  500.  
  501.     $id;
  502. }
  503.  
  504. sub Secret {
  505.     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.     my $data = $self . $self->{remote_ip} . rand() . time() . 
  509.       $self->{global} . $self->{'r'} . $self->{'filename'}.
  510.     $$ . $ServerID;
  511.     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.     $secret =~ s/^(.)/0/;
  515.     $secret;
  516. }
  517.  
  518. sub RefreshSessionId {
  519.     my($self, $id, $reset) = @_;
  520.     $id || $self->Error("no id for refreshing");
  521.     my $internal = $self->{Internal};
  522.  
  523.     $internal->LOCK;
  524.     my $idata = $internal->{$id};    
  525.     my $refresh_timeout = $reset ? 
  526.       $self->{session_timeout} : $idata->{refresh_timeout} || $self->{session_timeout};
  527.     $idata->{'timeout'} = time() + $refresh_timeout;
  528.     $internal->{$id} = $idata;    
  529.     $internal->UNLOCK;
  530.     $self->{dbg} && $self->Debug("refreshing $id with timeout $idata->{timeout}");
  531.  
  532.     1;
  533. }
  534.  
  535. 1;
  536.