File Coverage

SecSess.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             #
2             # SecSess.pm - Perl module for Apache secure session management
3             #
4             # $Id: SecSess.pm,v 1.17 2002/05/22 05:40:33 pliam Exp $
5             #
6              
7             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
8             # Apache::SecSess
9             # Copyright (c) 2001, 2002 John Pliam (pliam@atbash.com)
10             # This is open-source software.
11             # See file 'COPYING' in original distribution for complete details.
12             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
13              
14             package Apache::SecSess;
15 1     1   14898 use strict;
  1         3  
  1         41  
16              
17 1     1   857 use MIME::Base64;
  1         872  
  1         75  
18 1     1   11697 use Apache::Constants qw(:common :response M_GET M_POST);
  0            
  0            
19             use Apache::Log;
20             use Apache::URI;
21             use Apache::SecSess::Wrapper;
22              
23             use vars qw($VERSION);
24              
25             $VERSION = sprintf("%d.%02d", (q$Name: SecSess_Release_0_09 $ =~ /\d+/g));
26              
27             sub new {
28             my $class = shift;
29             my $self = {@_};
30             bless($self, $class);
31             $self->_init;
32             }
33              
34             sub _init {
35             my $self = shift;
36              
37             my $wrapper = Apache::SecSess::Wrapper->new(
38             file => $self->{secretFile}
39             );
40             unless (defined($wrapper)) { die "Cannot instantiate wrapper"; }
41             $self->{wrapper} = $wrapper;
42              
43             return $self;
44             }
45              
46             ## authenticate session
47             sub authen ($$) {
48             my($self, $r) = @_;
49             my $log = $r->log;
50             my($cred, $resp, $msg);
51              
52             ## don't perform in subrequests
53             unless ($r->is_initial_req) { return OK; }
54              
55             $log->debug(ref($self), "->authen():");
56              
57             $cred = $self->getCredentials($r);
58             $resp = $self->validateCredentials($r, $cred);
59             if (ref($resp)) {
60             if ($msg = $resp->{message}) { $log->info($msg); }
61             unless ($resp->{uri}) { return SERVER_ERROR; }
62             $r->header_out(Location => $resp->{uri});
63             return REDIRECT;
64             }
65             return OK;
66             }
67              
68             ## authorize request
69             sub authz ($$) {
70             my($self, $r) = @_;
71             my $log = $r->log;
72             my($req, $resp, $msg);
73              
74             ## don't perform in subrequests
75             unless ($r->is_initial_req) { return OK; }
76              
77             $log->debug(ref($self), "->authz():");
78              
79             $req = $self->getRequirements($r);
80             $resp = $self->authorizeRequest($r, $req);
81             if (ref($resp)) {
82             if ($msg = $resp->{message}) { $log->info($msg); }
83             if ($resp->{forbidden}) { return FORBIDDEN; }
84             unless ($resp->{uri}) { return SERVER_ERROR; }
85             $r->header_out(Location => $resp->{uri});
86             return REDIRECT;
87             }
88             return DECLINED;
89             }
90              
91             ## authenticate user & issue credentials
92             sub issue ($$) {
93             my($self, $r) = @_;
94             my $log = $r->log;
95             my($resp, $msg);
96              
97             ## don't perform in subrequests
98             unless ($r->is_initial_req) { return OK; }
99              
100             $log->debug(ref($self), "->issue():");
101              
102             $resp = $self->verifyIdentity($r);
103             if (ref($resp)) {
104             if ($msg = $resp->{message}) { $log->info($msg); }
105             if ($resp->{fill_form}) { return OK; }
106             if ($resp->{auth_required}) { return AUTH_REQUIRED; }
107             unless ($resp->{uri}) { return SERVER_ERROR; }
108             $r->header_out(Location => $resp->{uri});
109             return REDIRECT;
110             }
111             $resp = $self->issueCredentials($r);
112             unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
113             if ($msg = $resp->{message}) { $log->info($msg); }
114             unless ($resp->{uri}) { return SERVER_ERROR; }
115             $r->header_out(Location => $resp->{uri});
116             return REDIRECT;
117             }
118              
119             ## renew credentials
120             sub renew ($$) {
121             my($self, $r) = @_;
122             my $log = $r->log;
123             my($cred, $resp, $msg);
124              
125             ## don't perform in subrequests
126             unless ($r->is_initial_req) { return OK; }
127              
128             $log->debug(ref($self), "->renew():");
129              
130             $cred = $self->getCredentials($r);
131             $resp = $self->validateCredentials($r, $cred);
132             unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
133             unless ($resp->{renew}) { # make sure credentials are sufficiently fresh
134             $log->warn("Timeout before renewal."); # or replay attempt?
135             if ($msg = $resp->{message}) { $log->info($msg); }
136             unless ($resp->{uri}) { return SERVER_ERROR; }
137             $r->header_out(Location => $resp->{uri});
138             return REDIRECT;
139             }
140             $resp = $self->issueCredentials($r);
141             unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
142             if ($msg = $resp->{message}) { $log->info($msg); }
143             unless ($resp->{uri}) { return SERVER_ERROR; }
144             $r->header_out(Location => $resp->{uri});
145             return REDIRECT;
146             }
147              
148             ## delete credentials
149             sub delete ($$) {
150             my($self, $r) = @_;
151             my $log = $r->log;
152             my($resp, $msg);
153              
154             ## don't perform in subrequests
155             unless ($r->is_initial_req) { return OK; }
156              
157             $log->debug(ref($self), "->delete():");
158              
159             $resp = $self->deleteCredentials($r);
160             unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
161             if ($msg = $resp->{message}) { $log->info($msg); }
162             return OK;
163             }
164              
165             ## change user ID (only for administrators)
166             sub changeid ($$) {
167             my($self, $r) = @_;
168             my $log = $r->log;
169             my($cred, $resp, $msg, $uri, $uid);
170              
171             ## don't perform in subrequests
172             unless ($r->is_initial_req) { return OK; }
173              
174             $log->debug(ref($self), "->changeid():");
175              
176             ## admin functions must be explicitly allowed in httpd.conf
177             unless ($r->dir_config('SecSess::AllowRemoteAdmin') eq 'true') {
178             $log->error('Remote administration not permitted.');
179             return FORBIDDEN;
180             }
181              
182             ## get credentials and validate them in usual way
183             $cred = $self->getCredentials($r);
184             $resp = $self->validateCredentials($r, $cred);
185             if (ref($resp)) {
186             if ($msg = $resp->{message}) { $log->info($msg); }
187             unless ($resp->{uri}) { return SERVER_ERROR; }
188             $r->header_out(Location => $resp->{uri});
189             return REDIRECT;
190             }
191              
192             ## make sure request is consistent and comes from an administrator
193             $resp = $self->verifyAdminRequest($r);
194             unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
195             if ($msg = $resp->{message}) { $log->info($msg); }
196             if ($resp->{forbidden}) { return FORBIDDEN; } # non-admin
197             if ($resp->{fill_form}) { return OK; }
198             unless ($uid = $resp->{newuid}) {
199             unless ($uri = $resp->{uri}) { return SERVER_ERROR; }
200             $r->header_out(Location => $uri);
201             return REDIRECT;
202             }
203              
204             ## every looks good, set uid and issue new credentials
205             $r->user($uid);
206             $resp = $self->issueCredentials($r);
207             unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
208             if ($msg = $resp->{message}) { $log->info($msg); }
209             unless ($resp->{uri}) { return SERVER_ERROR; }
210             $r->header_out(Location => $resp->{uri});
211             return REDIRECT;
212             }
213              
214             #
215             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
216             # Common Code: methods called from subclasses
217             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
218             #
219              
220             #
221             # constants (not sure which should be dir_config'd in future ...)
222             #
223              
224             ## tag and cookie attributes
225             sub authRealm { my $self = shift; return $self->{authRealm}; }
226             sub cookieDomain { my $self = shift; return $self->{cookieDomain}; }
227              
228             ## security attributes
229             sub minSessQOP { my $self = shift; return $self->{minSessQOP}; }
230             sub minAuthQOP { my $self = shift; return $self->{minAuthQOP}; }
231             sub sessQOP { my $self = shift; return $self->{sessQOP}; }
232             sub authQOP { my $self = shift; return $self->{authQOP}; }
233              
234             ## session expiration and timeout attributes
235             sub lifeTime { my $self = shift; return $self->{lifeTime}; }
236             sub idleTime { my $self = shift; return $self->{idleTime}; }
237             sub renewRate { my $self = shift; return $self->{renewRate}; }
238              
239             ## session states
240             sub authenURL { my $self = shift; return $self->{authenURL}; }
241             sub defaultURL { my $self = shift; return $self->{defaultURL}; }
242             sub timeoutURL { my $self = shift; return $self->{timeoutURL}; }
243             sub renewURL { my $self = shift; return $self->{renewURL}; }
244             sub errorURL { my $self = shift; return $self->{errorURL}; }
245             sub issueURL { my $self = shift; return $self->{issueURL}; }
246             sub chainURLS { my $self = shift; return $self->{chainURLS}; }
247              
248             ## admin form
249             sub adminURL { my $self = shift; return $self->{adminURL}; }
250              
251             #
252             # routines
253             #
254              
255             ## validate common hash credentials from
256             sub validateCredentials {
257             my $self = shift;
258             my($r, $cred) = @_;
259             my $log = $r->log;
260             my($uri, $requri, $resp, $uid);
261              
262             $log->debug(ref($self), "->validateCredentials():");
263              
264             ## were illegitimate credentials found?
265             unless (defined($cred)) { # probably a key-change, treat as timeout
266             # but possibly tampering, so log as warning
267             $log->warn("Decryption Error");
268             $uri = $self->timeoutURL;
269             return {
270             message => "Decryption failure, redirecting to '$uri'.",
271             uri => "$uri?type=notvalid"
272             };
273             }
274              
275             ## were any credentials found at all?
276             unless (ref($cred)) {
277             $uri = sprintf('%s?url=%s',
278             $self->authenURL,
279             $self->requested_uri($r)
280             );
281             return {
282             message => "$cred Redirecting to '$uri'",
283             uri => $uri
284             };
285             }
286              
287             ## set user id for Apache
288             $uid = $cred->{uid};
289             $log->debug("Setting user ID: '$uid'.");
290             $r->user($uid);
291            
292             ## checksum is good, examine the protection qualities and freshness
293             if ($resp = $self->validateQOP($r, $cred)) { return $resp; }
294             if ($resp = $self->validateAge($r, $cred)) { return $resp; }
295              
296             ## user authenticated
297             $log->info("User '$uid' authenticated.");
298             return undef;
299             }
300              
301             ## validate quality of protection
302             sub validateQOP {
303             my $self = shift;
304             my($r, $cred) = @_;
305             my($uri, $requri);
306              
307             unless ($cred->{qop} >= $self->minSessQOP) {
308             $uri = $self->authenURL;
309             $requri = $self->requested_uri($r);
310             return {
311             message => "Insufficient session protection.",
312             uri => "$uri?url=$requri"
313             }
314             }
315             unless ($cred->{authqop} >= $self->minAuthQOP) {
316             $uri = $self->authenURL;
317             $requri = $self->requested_uri($r);
318             return {
319             message => "Insufficient authentication protection.",
320             uri => "$uri?url=$requri"
321             }
322             }
323              
324             return undef;
325             }
326              
327             ## validated time stamp
328             sub validateAge {
329             my $self = shift;
330             my($r, $cred) = @_;
331             my($life, $idle, $renew, $uid, $ts, $t, $uri, $requri);
332              
333             ## get object timing constants
334             $life = $self->lifeTime;
335             $idle = $self->idleTime;
336             $renew = $self->renewRate;
337              
338             ## check times
339             $uid = $cred->{uid};
340             $ts = $cred->{timestamp};
341             $t = time;
342             $r->log->debug(sprintf(
343             "validateAge(): uid = '%s', time - ts = %.02f (min):"
344             . " vs renew = %d, idle = %d, life = %d",
345             $uid, ($t-$ts)/60.0, $renew, $idle, $life
346             ));
347             if ($t > $ts + 60*$life) { # hard timeout
348             $uri = $self->timeoutURL;
349             return {
350             message => "Expired, redirecting '$uid' to '$uri?type=expire'.",
351             uri => "$uri?type=expire"
352             };
353             }
354             if ($t > $ts + 60*($idle+$renew)) { # idle timeout
355             $uri = $self->timeoutURL;
356             return {
357             message => "Cookie idle too long '$uid'.",
358             uri => "$uri?type=idle"
359             };
360             }
361             if ($t > $ts + 60*$renew) { # renew
362             $uri = $self->renewURL;
363             $requri = $self->requested_uri($r);
364             return {
365             message => "Renewing credentials for user '$uid'.",
366             renew => 'true',
367             uri => "$uri?url=$requri"
368             };
369             }
370              
371             return undef;
372             }
373              
374             ## get requirements
375             sub getRequirements {
376             my $self = shift;
377             my($r) = @_;
378             return $r->requires;
379             }
380              
381             ## authorize request
382             sub authorizeRequest {
383             my $self = shift;
384             my($r, $req) = @_;
385              
386             return undef;
387             }
388              
389             #
390             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
391             # Utilities
392             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
393             #
394              
395             ## extract the requested URI as base64 wrapped
396             sub requested_uri {
397             my $self = shift;
398             my($r) = @_;
399             my($u, %args, $requrl);
400              
401             %args = $r->args;
402             unless ($requrl = $args{url}) { # will already be wrapped
403             $u = Apache::URI->parse($r);
404             $requrl = $self->wrap_uri($u->unparse);
405             }
406             return $requrl;
407             }
408              
409             ## (un)wrap a URI, with more armor than Apache::Util::escape_uri
410             sub wrap_uri {
411             my $self = shift;
412             my($u) = @_;
413             $u = encode_base64($u, '');
414             $u =~ tr/\+\/\=/-._/;
415             return $u;
416             }
417             sub unwrap_uri {
418             my $self = shift;
419             my($u) = @_;
420             $u =~ tr/\-\.\_/+\/=/;
421             return decode_base64($u);
422             }
423              
424             1;
425              
426             __END__