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; |