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 / Session.pm < prev    next >
Encoding:
Perl POD Document  |  2003-03-25  |  7.9 KB  |  307 lines
  1.  
  2. package Apache::ASP::Session;
  3.  
  4. use Apache::ASP::State;
  5.  
  6. use strict;
  7. no strict qw(refs);
  8. use vars qw(@ISA);
  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.     my($asp, $id, $perms, $no_error) = @_;
  15.     my($state, %self, $started);
  16.     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.     if($id) {
  22.     $internal->LOCK;
  23.     $state = Apache::ASP::State::new($asp, $id, undef, $perms, $no_error);
  24.     #    $state->Set() || $asp->Error("session state get failed");
  25.     if($state) {
  26.         tie %self, 'Apache::ASP::Session', 
  27.         {
  28.          state=>$state, 
  29.          asp=>$asp, 
  30.          id=>$id,
  31.         };
  32.         $internal->UNLOCK;
  33.         return bless \%self;
  34.     } else {
  35.         $internal->UNLOCK;
  36.         return;
  37.     }
  38.     }
  39.  
  40.     # lock down so no conflict with garbage collection
  41.     $internal->LOCK();
  42.     if($id = $asp->SessionId()) {
  43.     my $idata = $internal->{$id};
  44.     #    $asp->Debug("internal data for session $id", $idata);
  45.     if($idata && ! $idata->{'end'} ) {
  46.         # user is authentic, since the id is in our internal hash
  47.         if($idata->{timeout} > time()) {
  48.         # refresh and unlock as early as possible to not conflict 
  49.         # with garbage collection
  50.         $asp->RefreshSessionId($id);
  51.         $state = Apache::ASP::State::new($asp, $id);
  52.         $internal->UNLOCK();
  53.  
  54.         # session not expired
  55.         $asp->{dbg} && 
  56.           $asp->Debug("session not expired",{'time'=>time(), timeout=>$idata->{timeout}});
  57.  
  58.         if($asp->{paranoid_session}) {
  59.             local $^W = 0;
  60.             # by testing for whether UA was set to begin with, we 
  61.             # allow a smooth upgrade to ParanoidSessions
  62.             $state->WriteLock() if $asp->{session_serialize};
  63.             my $state_ua = $state->FETCH('_UA');
  64.             if(defined($state_ua) and $state_ua ne $asp->{'ua'}) {
  65.             $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.             $state->Init();
  70.             undef $state;
  71.             goto NEW_SESSION_ID;            
  72.             }
  73.         }
  74.  
  75.         $started = 0;
  76.         } else {
  77.         # expired, get & reset
  78.         $internal->{$id} = { %{$internal->{$id}}, 'end' => 1 };
  79.         $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.         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.         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.       NEW_SESSION_ID:
  109.     my($trys);
  110.     for(1..10) {
  111.         $trys++;
  112.         $id = $asp->Secret();
  113.  
  114.         if($internal->{$id}) {
  115.         $id = '';
  116.         } else {
  117.         last;
  118.         }
  119.     }
  120.  
  121.     $id && $asp->RefreshSessionId($id, {});
  122.     $asp->{Internal}->UNLOCK();    
  123.  
  124.     $asp->Log("[security] secret algorithm is no good with $trys trys")
  125.         if ($trys > 3);
  126.     $asp->Error("no unique secret generated")
  127.         unless $id;
  128.  
  129.     $asp->{dbg} && $asp->Debug("new session id $id");
  130.     $asp->SessionId($id);
  131.  
  132.     $state = &Apache::ASP::State::new($asp, $id);
  133. #    $state->Set() || $asp->Error("session state set failed");
  134.  
  135.     if($asp->{paranoid_session}) {
  136.         $asp->Debug("storing user-agent $asp->{'ua'}");
  137.         $state->STORE('_UA', $asp->{'ua'});
  138.     }
  139.     $started = 1;
  140.     }
  141.  
  142.     if(! $state) {
  143.     $asp->Error("can't get state for id $id");
  144.     return;
  145.     }
  146.  
  147.     $state->WriteLock() if $asp->{session_serialize};
  148.     $asp->Debug("tieing session $id");
  149.     tie %self, 'Apache::ASP::Session',
  150.     {
  151.     state=>$state, 
  152.     asp=>$asp, 
  153.     id=>$id,
  154.     started=>$started,
  155.     };
  156.  
  157.     if($started) {
  158.     $asp->{dbg} && $asp->Debug("clearing starting session");
  159.     if($state->Size > 0) {
  160.         $asp->{dbg} && $asp->Debug("clearing data in old session $id");
  161.         %self = ();
  162.     }
  163.     }
  164.  
  165.     bless \%self;
  166. }    
  167.  
  168. sub TIEHASH { 
  169.     my($package, $self) = @_;
  170.     bless $self;
  171. }       
  172.  
  173. # stub so we don't have to test for it in autoload
  174. sub DESTROY {
  175.     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.     return unless eval { $self->{state} };
  180.  
  181.     $self->{state}->DESTROY;
  182.     undef $self->{state};
  183.     %$self = ();
  184. }
  185.  
  186. # don't need to skip DESTROY since we have it here
  187. # return if ($AUTOLOAD =~ /DESTROY/);
  188. sub AUTOLOAD {
  189.     my $self = shift;
  190.     my $AUTOLOAD = $Apache::ASP::Session::AUTOLOAD;
  191.     $AUTOLOAD =~ s/^(.*)::(.*?)$/$2/o;
  192.     $self->{state}->$AUTOLOAD(@_);
  193. }
  194.  
  195. sub FETCH {
  196.     my($self, $index) = @_;
  197.  
  198.     # putting these comparisons in a regexp was a little
  199.     # slower than keeping them in these 'eq' statements
  200.     if($index eq '_SELF') {
  201.     $self;
  202.     } elsif($index eq '_STATE') {
  203.     $self->{state};
  204.     } elsif($index eq 'SessionID') {
  205.     $self->{id};
  206.     } elsif($index eq 'Timeout') {
  207.     $self->Timeout();
  208.     } else {
  209.     $self->{state}->FETCH($index);
  210.     }
  211. }
  212.  
  213. sub STORE {
  214.     my($self, $index, $value) = @_;
  215.     if($index eq 'Timeout') {
  216.     $self->Timeout($value);
  217.     } else {    
  218.     $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.     my $self = shift;
  229.     my $value = $self->{state}->FIRSTKEY();
  230.     if(defined $value and $value eq '_UA') {
  231.     $self->{state}->NEXTKEY($value);
  232.     } else {
  233.     $value;
  234.     }
  235. }
  236.  
  237. sub NEXTKEY {
  238.     my($self, $key) = @_;
  239.     my $value = $self->{state}->NEXTKEY($key);
  240.     if(defined($value) && ($value eq '_UA')) {
  241.     $self->{state}->NEXTKEY($value);
  242.     } else {
  243.     $value;
  244.     }    
  245. }
  246.  
  247. sub CLEAR {
  248.     my $state = shift->{state};
  249.     my $ua = $state->FETCH('_UA');
  250.     my $rv = $state->CLEAR();
  251.     $ua && $state->STORE('_UA', $ua);
  252.     $rv;
  253. }
  254.  
  255. sub SessionID {
  256.     my $self = shift;
  257.     tied(%$self)->{id};
  258. }
  259.  
  260. sub Timeout {
  261.     my($self, $minutes) = @_;
  262.  
  263.     if(tied(%$self)) {
  264.     $self = tied(%$self);
  265.     }
  266.  
  267.     if($minutes) {
  268.     $self->{asp}{Internal}->LOCK;
  269.     my($internal_session) = $self->{asp}{Internal}{$self->{id}};
  270.     $internal_session->{refresh_timeout} = $minutes * 60;
  271.     $internal_session->{timeout} = time() + $minutes * 60;
  272.     $self->{asp}{Internal}{$self->{id}} = $internal_session;
  273.     $self->{asp}{Internal}->UNLOCK;
  274.     } else {
  275.     my($refresh) = $self->{asp}{Internal}{$self->{id}}{refresh_timeout};
  276.     $refresh ||= $self->{asp}{session_timeout};
  277.     $refresh / 60;
  278.     }
  279. }    
  280.  
  281. sub Abandon {
  282.     shift->Timeout(-1);
  283. }
  284.  
  285. sub TTL {
  286.     my $self = shift;
  287.     $self = tied(%$self);
  288.     # time to live is current timeout - time... positive means
  289.     # session is still active, returns ttl in seconds
  290.     my $timeout = $self->{asp}{Internal}{$self->{id}}{timeout};
  291.     my $ttl = $timeout - time();
  292. }
  293.  
  294. sub Started {
  295.     my $self = shift;
  296.     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. sub Lock { tied(%{$_[0]})->{state}->WriteLock(); }
  304. sub UnLock { tied(%{$_[0]})->{state}->UnLock(); }
  305.  
  306. 1;
  307.