File Coverage

blib/lib/CGI/Ex/Auth.pm
Criterion Covered Total %
statement 301 463 65.0
branch 168 326 51.5
condition 97 198 48.9
subroutine 70 94 74.4
pod 37 77 48.0
total 673 1158 58.1


line stmt bran cond sub pod time code
1             package CGI::Ex::Auth;
2              
3             =head1 NAME
4              
5             CGI::Ex::Auth - Handle logins nicely.
6              
7             =head1 VERSION
8              
9             version 2.53
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 3     3   119443 use strict;
  3         28  
  3         129  
19             #use warnings; # TODO - investigate enabling in heavy usage scenarios
20              
21 3     3   1150 use MIME::Base64 qw(encode_base64 decode_base64);
  3         1747  
  3         168  
22 3     3   16 use Digest::MD5 qw(md5_hex);
  3         5  
  3         120  
23 3     3   841 use CGI::Ex;
  3         5  
  3         128  
24 3     3   19 use Carp qw(croak);
  3         4  
  3         16437  
25              
26             our $VERSION = '2.53'; # VERSION
27              
28             ###----------------------------------------------------------------###
29              
30             sub new {
31 32   33 32 1 1699 my $class = shift || croak "Usage: ".__PACKAGE__."->new";
32 32 50       89 my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
    100          
33 32         185 return bless {%$self}, $class;
34             }
35              
36             sub get_valid_auth {
37 29     29 1 76 my $self = shift;
38 29 100       88 $self = $self->new(@_) if ! ref $self;
39 29         59 delete $self->{'_last_auth_data'};
40              
41             # shortcut that will print a js file as needed (such as the md5.js)
42 29 50       64 if ($self->script_name . $self->path_info eq $self->js_uri_path . "/CGI/Ex/md5.js") {
43 0         0 $self->cgix->print_js('CGI/Ex/md5.js');
44 0         0 eval { die "Printed Javascript" };
  0         0  
45 0         0 return;
46             }
47              
48 29         148 my $form = $self->form;
49              
50             # allow for logout
51 29 50 33     61 if ($form->{$self->key_logout} && ! $self->{'_logout_looking_for_user'}) {
52 0         0 local $self->{'_logout_looking_for_user'} = 1;
53 0         0 local $self->{'no_set_cookie'} = 1;
54 0         0 local $self->{'no_cookie_verify'} = 1;
55 0         0 $self->check_valid_auth; # verify the logout so we can capture the username if possible
56              
57 0         0 $self->logout_hook;
58              
59 0 0       0 if ($self->bounce_on_logout) {
60 0         0 my $key_c = $self->key_cookie;
61 0 0       0 $self->delete_cookie({name => $key_c}) if $self->cookies->{$key_c};
62 0 0       0 my $user = $self->last_auth_data ? $self->last_auth_data->{'user'} : undef;
63 0 0       0 $self->location_bounce($self->logout_redirect(defined($user) ? $user : ''));
64 0         0 eval { die "Logging out" };
  0         0  
65 0         0 return;
66             } else {
67 0         0 $self->form({});
68 0         0 $self->handle_failure;
69 0         0 return;
70             }
71             }
72              
73 29         45 my $data;
74              
75             # look in form first
76 29         54 my $form_user = delete $form->{$self->key_user};
77 29 100       56 if (defined $form_user) {
78 15 50       36 if (delete $form->{$self->key_loggedout}) { # don't validate the form on a logout
    100          
    50          
79 0         0 $data = $self->new_auth_data({user => $form_user, error => 'Logged out'});
80             } elsif (defined $form->{ $self->key_pass }) {
81             $data = $self->verify_token({
82             token => {
83             user => $form_user,
84             test_pass => delete $form->{ $self->key_pass },
85 8 50 50     17 expires_min => delete($form->{ $self->key_save }) ? -1 : delete($form->{ $self->key_expires_min }) || undef,
86             },
87             from => 'form',
88             });
89             } elsif (! length $form_user) {
90 0         0 $data = $self->new_auth_data({user => '', error => 'Invalid user'});
91             } else {
92 7         50 $data = $self->verify_token({token => $form_user, from => 'form'});
93             }
94             }
95              
96             # no valid form data ? look in the cookie
97 29 100 100     83 if (! ref($data) # no form
      100        
98             || ($data->error && $data->{'allow_cookie_match'})) { # had form with error - but we can check if form user matches existing cookie
99 17         26 my $cookie = $self->cookies->{$self->key_cookie};
100 17 100 66     59 if (defined($cookie) && length($cookie)) {
101 9         12 my $form_data = $data;
102 9         26 $data = $self->verify_token({token => $cookie, from => 'cookie'});
103 9 100       23 if (defined $form_user) { # they had form data
104 3         6 my $user = $self->cleanup_user($form_user);
105 3 100 100     9 if (! $data || !$self->check_form_user_against_cookie($user, $data->{'user'}, $data)) { # but the cookie didn't match
106 2         6 $data = $self->{'_last_auth_data'} = $form_data; # restore old form data failure
107 2 50       19 $data->{'user'} = $user if ! defined $data->{'user'};
108             }
109             }
110             }
111             }
112              
113             # failure
114 29 100       64 if (! $data) {
115 13         47 return $self->handle_failure({had_form_data => defined($form_user)});
116             }
117              
118             # success
119 16         38 my $_key = $self->key_cookie;
120 16         36 my $_val = $self->generate_token($data);
121 16         43 my $use_session = $self->use_session_cookie($_key, $_val); # default false
122 16 100 33     30 if ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt')) {
      66        
123 5 50 66     23 $use_session = 1 if ! defined($use_session) && ! defined($data->{'expires_min'});
124             }
125             $self->set_cookie({
126 16 100       101 name => $_key,
127             value => $_val,
128             expires => ($use_session ? '' : '+20y'), # non-cram cookie types are session cookies unless save was set (thus setting expires_min)
129             });
130              
131 16 100       102 return $self->handle_success({is_form => ($data->{'from'} eq 'form' ? 1 : 0)});
132             }
133              
134             sub handle_success {
135 16     16 0 18 my $self = shift;
136 16   50     49 my $args = shift || {};
137 16 50       26 if (my $meth = $self->{'handle_success'}) {
138 0         0 return $meth->($self, $args);
139             }
140 16         35 my $form = $self->form;
141              
142             # bounce to redirect
143 16 50 66     32 if (my $redirect = $form->{ $self->key_redirect }) {
    50          
    0          
144 0         0 $self->location_bounce($redirect);
145 0         0 eval { die "Success login - bouncing to redirect" };
  0         0  
146 0         0 return;
147              
148             # if they have cookies we are done
149 16         29 } elsif (scalar(keys %{$self->cookies}) || $self->no_cookie_verify) {
150 16         71 $self->success_hook;
151 16         77 return $self;
152              
153             # need to verify cookies are set-able
154             } elsif ($args->{'is_form'}) {
155 0         0 $form->{$self->key_verify} = $self->server_time;
156 0         0 my $url = $self->script_name . $self->path_info . "?". $self->cgix->make_form($form);
157              
158 0         0 $self->location_bounce($url);
159 0         0 eval { die "Success login - bouncing to test cookie" };
  0         0  
160 0         0 return;
161             }
162             }
163              
164             sub success_hook {
165 16     16 0 21 my $self = shift;
166 16 50       38 if (my $meth = $self->{'success_hook'}) {
167 0         0 return $meth->($self);
168             }
169 16         21 return;
170             }
171              
172             sub logout_hook {
173 0     0 0 0 my $self = shift;
174 0 0       0 if (my $meth = $self->{'logout_hook'}) {
175 0         0 return $meth->($self);
176             }
177 0         0 return;
178             }
179              
180             sub handle_failure {
181 13     13 0 17 my $self = shift;
182 13   50     24 my $args = shift || {};
183 13 50       27 if (my $meth = $self->{'handle_failure'}) {
184 0         0 return $meth->($self, $args);
185             }
186 13         20 my $form = $self->form;
187              
188             # make sure the cookie is gone
189 13         58 my $key_c = $self->key_cookie;
190 13 100       33 $self->delete_cookie({name => $key_c}) if exists $self->cookies->{$key_c};
191              
192             # no valid login and we are checking for cookies - see if they have cookies
193 13 50       38 if (my $value = delete $form->{$self->key_verify}) {
194 0 0       0 if (abs(time() - $value) < 15) {
195 0         0 $self->no_cookies_print;
196 0         0 return;
197             }
198             }
199              
200             # oh - you're still here - well then - ask for login credentials
201 13         26 my $key_r = $self->key_redirect;
202 13   33     38 local $form->{$key_r} = $form->{$key_r} || $self->script_name . $self->path_info . (scalar(keys %$form) ? "?".$self->cgix->make_form($form) : '');
203 13   100     46 local $form->{'had_form_data'} = $args->{'had_form_data'} || 0;
204 13         31 $self->login_print;
205 6         31 my $data = $self->last_auth_data;
206 6 100       8 eval { die defined($data) ? $data : "Requesting credentials" };
  6         34  
207              
208             # allow for a sleep to help prevent brute force
209 6 50 66     27 sleep($self->failed_sleep) if defined($data) && $data->error ne 'Login expired' && $self->failed_sleep;
      66        
210 6         42 $self->failure_hook;
211              
212 6         44 return;
213             }
214              
215             sub failure_hook {
216 6     6 0 7 my $self = shift;
217 6 50       14 if (my $meth = $self->{'failure_hook'}) {
218 0         0 return $meth->($self);
219             }
220 6         19 return;
221             }
222              
223             sub check_valid_auth {
224 0     0 1 0 my $self = shift;
225 0 0       0 $self = $self->new(@_) if ! ref $self;
226              
227 0     0   0 local $self->{'location_bounce'} = sub {}; # but don't bounce to other locations
228 0     0   0 local $self->{'login_print'} = sub {}; # check only - don't login if not
229 0 0   0   0 local $self->{'set_cookie'} = $self->{'no_set_cookie'} ? sub {} : $self->{'set_cookie'};
230 0         0 return $self->get_valid_auth;
231             }
232              
233             ###----------------------------------------------------------------###
234              
235 27 0 33 27 0 64 sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || '' }
236              
237 55 50 33 55 0 366 sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
238              
239 27     27 0 79 sub server_time { time }
240              
241             sub cgix {
242 7     7 1 9 my $self = shift;
243 7 50       14 $self->{'cgix'} = shift if @_ == 1;
244 7   66     40 return $self->{'cgix'} ||= CGI::Ex->new;
245             }
246              
247             sub form {
248 71     71 1 77 my $self = shift;
249 71 50       139 $self->{'form'} = shift if @_ == 1;
250 71   33     156 return $self->{'form'} ||= $self->cgix->get_form;
251             }
252              
253             sub cookies {
254 50     50 1 65 my $self = shift;
255 50 50       91 $self->{'cookies'} = shift if @_ == 1;
256 50   66     175 return $self->{'cookies'} ||= $self->cgix->get_cookies;
257             }
258              
259             sub delete_cookie {
260 0     0 0 0 my $self = shift;
261 0         0 my $args = shift;
262 0 0       0 return $self->{'delete_cookie'}->($self, $args) if $self->{'delete_cookie'};
263 0         0 local $args->{'value'} = '';
264 0         0 local $args->{'expires'} = '-10y';
265 0 0       0 if (my $dom = $ENV{HTTP_HOST}) {
266 0         0 $dom =~ s/:\d+$//;
267 0   0     0 do {
268 0         0 local $args->{'domain'} = $dom;
269 0         0 $self->set_cookie($args);
270 0         0 local $args->{'domain'} = ".$dom";
271 0         0 $self->set_cookie($args);
272             }
273             while ($dom =~ s/^[\w\-]*\.// and $dom =~ /\./);
274             }
275 0         0 $self->set_cookie($args);
276 0         0 delete $self->cookies->{$args->{'name'}};
277             }
278              
279             sub set_cookie {
280 7     7 0 1573 my $self = shift;
281 7         7 my $args = shift;
282 7 100       23 return $self->{'set_cookie'}->($self, $args) if $self->{'set_cookie'};
283 4         5 my $key = $args->{'name'};
284 4         5 my $val = $args->{'value'};
285 4   66     11 my $dom = $args->{'domain'} || $self->cookie_domain;
286 4   66     10 my $sec = $args->{'secure'} || $self->cookie_secure;
287 4   33     11 my $http = $args->{'httponly'} || $self->cookie_httponly;
288 4   100     10 my $same = $args->{'samesite'} || $self->cookie_samesite;
289             $self->cgix->set_cookie({
290             -name => $key,
291             -value => $val,
292             -path => $args->{'path'} || $self->cookie_path($key, $val) || '/',
293             ($dom ? (-domain => $dom) : ()),
294             ($sec ? (-secure => $sec) : ()),
295             ($http ? (-httponly => $http) : ()),
296             ($same ? (-samesite => $same) : ()),
297 4 100 100     7 ($args->{'expires'} ? (-expires => $args->{'expires'}): ()),
    100          
    50          
    100          
    50          
298             });
299 4         13 $self->cookies->{$key} = $val;
300             }
301              
302             sub location_bounce {
303 0     0 0 0 my $self = shift;
304 0         0 my $url = shift;
305 0 0       0 return $self->{'location_bounce'}->($self, $url) if $self->{'location_bounce'};
306 0         0 return $self->cgix->location_bounce($url);
307             }
308              
309             ###----------------------------------------------------------------###
310              
311 29   50 29 1 140 sub key_logout { shift->{'key_logout'} ||= 'cea_logout' }
312 46   100 46 1 110 sub key_cookie { shift->{'key_cookie'} ||= 'cea_user' }
313 55   100 55 1 160 sub key_user { shift->{'key_user'} ||= 'cea_user' }
314 49   100 49 1 153 sub key_pass { shift->{'key_pass'} ||= 'cea_pass' }
315 26   100 26 0 70 sub key_time { shift->{'key_time'} ||= 'cea_time' }
316 21   100 21 1 103 sub key_save { shift->{'key_save'} ||= 'cea_save' }
317 34   100 34 1 126 sub key_expires_min { shift->{'key_expires_min'} ||= 'cea_expires_min' }
318 13   50 13 1 75 sub form_name { shift->{'form_name'} ||= 'cea_form' }
319 13   50 13 1 52 sub key_verify { shift->{'key_verify'} ||= 'cea_verify' }
320 42   100 42 0 129 sub key_redirect { shift->{'key_redirect'} ||= 'cea_redirect' }
321 15   50 15 1 80 sub key_loggedout { shift->{'key_loggedout'} ||= 'loggedout' }
322 0   0 0 1 0 sub bounce_on_logout { shift->{'bounce_on_logout'} ||= 0 }
323 3   50 3 0 16 sub secure_hash_keys { shift->{'secure_hash_keys'} ||= [] }
324             #perl -e 'use Digest::MD5 qw(md5_hex); open(my $fh, "<", "/dev/urandom"); for (1..10) { read $fh, my $t, 5_000_000; print md5_hex($t),"\n"}'
325 0   0 0 0 0 sub no_cookie_verify { shift->{'no_cookie_verify'} ||= 0 }
326 46   50 46 0 307 sub use_crypt { shift->{'use_crypt'} ||= 0 }
327 20   50 20 0 114 sub use_blowfish { shift->{'use_blowfish'} ||= '' }
328 33 100 100 33 0 48 sub use_plaintext { my $s = shift; $s->use_crypt || ($s->{'use_plaintext'} ||= 0) }
  33         54  
329 21 100   21 0 27 sub use_base64 { my $s = shift; $s->{'use_base64'} = 1 if ! defined $s->{'use_base64'}; $s->{'use_base64'} }
  21         96  
  21         55  
330 28 50   28 0 31 sub expires_min { my $s = shift; $s->{'expires_min'} = 6 * 60 if ! defined $s->{'expires_min'}; $s->{'expires_min'} }
  28         69  
  28         57  
331 0   0 0 1 0 sub failed_sleep { shift->{'failed_sleep'} ||= 0 }
332 3     3 0 24 sub cookie_path { shift->{'cookie_path'} }
333 3     3 1 18 sub cookie_domain { shift->{'cookie_domain'} }
334 3     3 0 6 sub cookie_secure { shift->{'cookie_secure'} }
335 4     4 0 6 sub cookie_httponly { shift->{'cookie_httponly'} }
336 3     3 0 6 sub cookie_samesite { shift->{'cookie_samesite'} }
337 16     16 0 27 sub use_session_cookie { shift->{'use_session_cookie'} }
338 3     3 1 4 sub disable_simple_cram { shift->{'disable_simple_cram'} }
339 26     26 0 155 sub complex_plaintext { shift->{'complex_plaintext'} }
340              
341             sub logout_redirect {
342 0     0 0 0 my ($self, $user) = @_;
343 0 0       0 my $form = $self->cgix->make_form({$self->key_loggedout => 1, (length($user) ? ($self->key_user => $user) : ()) });
344 0   0     0 return $self->{'logout_redirect'} || $self->script_name ."?$form";
345             }
346              
347             sub js_uri_path {
348 42     42 0 52 my $self = shift;
349 42   66     131 return $self->{'js_uri_path'} ||= $self->script_name ."/js";
350             }
351              
352             ###----------------------------------------------------------------###
353              
354             sub no_cookies_print {
355 0     0 0 0 my $self = shift;
356 0 0       0 return $self->{'no_cookies_print'}->($self) if $self->{'no_cookies_print'};
357 0         0 $self->cgix->print_content_type;
358 0         0 print qq{
You do not appear to have cookies enabled.
};
359             }
360              
361             sub login_print {
362 8     8 1 10 my $self = shift;
363 8         9 my $hash = $self->login_hash_common;
364 8         19 my $file = $self->login_template;
365              
366             ### allow for a hooked override
367 8 50       17 if (my $meth = $self->{'login_print'}) {
368 8         21 $meth->($self, $file, $hash);
369 1         4 return 0;
370             }
371              
372             ### process the document
373 0         0 my $args = $self->template_args;
374 0   0     0 $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_include_path,
      0        
375             my $t = $self->template_obj($args);
376 0         0 my $out = '';
377 0 0       0 $t->process_simple($file, $hash, \$out) || die $t->error;
378              
379             ### fill in form fields
380 0         0 require CGI::Ex::Fill;
381 0         0 CGI::Ex::Fill::fill({text => \$out, form => $hash});
382              
383             ### print it
384 0         0 $self->cgix->print_content_type;
385 0         0 print $out;
386              
387 0         0 return 0;
388             }
389              
390             sub template_obj {
391 0     0 0 0 my ($self, $args) = @_;
392 0   0     0 return $self->{'template_obj'} || do {
393             require Template::Alloy;
394             Template::Alloy->new($args);
395             };
396             }
397              
398 0   0 0 0 0 sub template_args { $_[0]->{'template_args'} ||= {} }
399              
400 0 0   0 0 0 sub template_include_path { $_[0]->{'template_include_path'} || '' }
401              
402             sub login_hash_common {
403 13     13 1 30 my $self = shift;
404 13         19 my $form = $self->form;
405 13         24 my $data = $self->last_auth_data;
406 13 100       53 $data = {no_data => 1} if ! ref $data;
407              
408             return {
409             %$form,
410             error => ($form->{'had_form_data'}) ? "Login Failed" : "",
411             login_data => $data,
412             key_user => $self->key_user,
413             key_pass => $self->key_pass,
414             key_time => $self->key_time,
415             key_save => $self->key_save,
416             key_expires_min => $self->key_expires_min,
417             key_redirect => $self->key_redirect,
418             form_name => $self->form_name,
419             script_name => $self->script_name,
420             path_info => $self->path_info,
421             md5_js_path => $self->js_uri_path ."/CGI/Ex/md5.js",
422 13 100 100     41 $self->key_user => $data->{'user'} || '',
423             $self->key_pass => '', # don't allow for this to get filled into the form
424             $self->key_time => $self->server_time,
425             $self->key_expires_min => $self->expires_min,
426             text_user => $self->text_user,
427             text_pass => $self->text_pass,
428             text_save => $self->text_save,
429             text_submit => $self->text_submit,
430             hide_save => $self->hide_save,
431             };
432             }
433              
434             ###----------------------------------------------------------------###
435              
436             sub verify_token {
437 24     24 1 32 my $self = shift;
438 24         26 my $args = shift;
439 24 50       45 if (my $meth = $self->{'verify_token'}) {
440 0         0 return $meth->($self, $args);
441             }
442 24 50       95 my $token = delete $args->{'token'}; die "Missing token" if ! length $token;
  24         51  
443 24         93 my $data = $self->new_auth_data({token => $token, %$args});
444 24         52 my $meth;
445              
446             # make sure the token is parsed to usable data
447 24 100       61 if (ref $token) { # token already parsed
    50          
448 8         27 $data->add_data({%$token, armor => 'none'});
449              
450             } elsif (my $meth = $self->{'parse_token'}) {
451 0 0       0 if (! $meth->($self, $args)) {
452 0 0       0 $data->error('Invalid custom parsed token') if ! $data->error; # add error if not already added
453 0         0 $data->{'allow_cookie_match'} = 1;
454 0         0 return $data;
455             }
456             } else {
457 16 100       37 if (! $self->parse_token($token, $data)) {
458 3 50       6 $data->error('Invalid token') if ! $data->error; # add error if not already added
459 3         4 $data->{'allow_cookie_match'} = 1;
460 3         6 return $data;
461             }
462             }
463              
464              
465             # verify the user
466 21 50 33     80 if (! defined($data->{'user'})) {
    50          
    50          
    50          
467 0         0 $data->error('Missing user');
468             } elsif (! defined($data->{'user'} = $self->cleanup_user($data->{'user'}))
469             || ! length($data->{'user'})) {
470 0         0 $data->error('Missing cleaned user');
471             } elsif (! defined $data->{'test_pass'}) {
472 0         0 $data->error('Missing test_pass');
473             } elsif (! $self->verify_user($data->{'user'})) {
474 0         0 $data->error('Invalid user');
475             }
476 21 50       40 return $data if $data->error;
477              
478             # get the pass
479 21         23 my $pass;
480 21 50       34 if (! defined($pass = eval { $self->get_pass_by_user($data->{'user'}) })) {
  21 100       114  
481 0         0 $data->add_data({details => $@});
482 0         0 $data->error('Could not get pass');
483             } elsif (ref $pass eq 'HASH') {
484 2         17 my $extra = $pass;
485             $pass = exists($extra->{'real_pass'}) ? delete($extra->{'real_pass'})
486             : exists($extra->{'password'}) ? delete($extra->{'password'})
487 2 50       9 : do { $data->error('Data returned by get_pass_by_user did not contain real_pass or password'); undef };
  0 50       0  
  0         0  
488 2 0 33     5 $data->error('Invalid login') if ! defined $pass && ! $data->error;
489 2         5 $data->add_data($extra);
490             }
491 21 50       107 return $data if $data->error;
492 21         51 $data->add_data({real_pass => $pass}); # store - to allow generate_token to not need to relookup the pass
493              
494              
495             # validate the pass
496 21 50       51 if ($meth = $self->{'verify_password'}) {
497 0 0       0 if (! $meth->($self, $pass, $data)) {
498 0 0       0 $data->error('Password failed verification') if ! $data->error;
499             }
500             } else{
501 21 100       63 if (! $self->verify_password($pass, $data)) {
502 4 50       8 $data->error('Password failed verification') if ! $data->error;
503             }
504             }
505 21 100       44 return $data if $data->error;
506              
507              
508             # validate the payload
509 17 50       40 if ($meth = $self->{'verify_payload'}) {
510 0 0       0 if (! $meth->($self, $data->{'payload'}, $data)) {
511 0 0       0 $data->error('Payload failed custom verification') if ! $data->error;
512             }
513             } else {
514 17 50       64 if (! $self->verify_payload($data->{'payload'}, $data)) {
515 0 0       0 $data->error('Payload failed verification') if ! $data->error;
516             }
517             }
518              
519 17         41 return $data;
520             }
521              
522             sub new_auth_data {
523 24     24 0 32 my $self = shift;
524 24         64 return $self->{'_last_auth_data'} = CGI::Ex::Auth::Data->new(@_);
525             }
526              
527             sub parse_token {
528 16     16 1 31 my ($self, $token, $data) = @_;
529 16         33 my $found;
530             my $bkey;
531 16         30 for my $armor ('none', 'base64', 'blowfish') {
532             my $copy = ($armor eq 'none') ? $token
533 24 50       62 : ($armor eq 'base64') ? $self->use_base64 ? eval { local $^W; decode_base64($token) } : next
  5 50       23  
  5 100       22  
    100          
534             : ($bkey = $self->use_blowfish) ? decrypt_blowfish($token, $bkey)
535             : next;
536 21 50 33     45 if ($self->complex_plaintext && $copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / ([^/]*) / (.*) $|x) {
    100          
    100          
537 0         0 $data->add_data({
538             user => $1,
539             plain_time => $2,
540             expires_min => $3,
541             payload => $4,
542             test_pass => $5,
543             armor => $armor,
544             });
545 0         0 $found = 1;
546 0         0 last;
547             } elsif ($copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / ([^/]*) / ([a-fA-F0-9]{32}) (?: / (sh\.\d+\.\d+))? $|x) {
548 2   50     33 $data->add_data({
549             user => $1,
550             cram_time => $2,
551             expires_min => $3,
552             payload => $4,
553             test_pass => $5,
554             secure_hash => $6 || '',
555             armor => $armor,
556             });
557 2         6 $found = 1;
558 2         3 last;
559             } elsif ($copy =~ m|^ ([^/]+) / (.*) $|x) {
560 11         58 $data->add_data({
561             user => $1,
562             test_pass => $2,
563             armor => $armor,
564             });
565 11         32 $found = 1;
566 11         18 last;
567             }
568             }
569 16         43 return $found;
570             }
571              
572             sub verify_password {
573 21     21 1 40 my ($self, $pass, $data) = @_;
574 21         31 my $err;
575              
576             ### looks like a secure_hash cram
577 21 100 33     224 if ($data->{'secure_hash'}) {
    50 33        
    50 66        
    100          
    50          
578 2         5 $data->add_data(type => 'secure_hash_cram');
579 2         11 my $array = eval {$self->secure_hash_keys };
  2         4  
580 2 50 33     44 if (! $array) {
    50          
    50          
581 0         0 $err = 'secure_hash_keys not found';
582             } elsif (! @$array) {
583 0         0 $err = 'secure_hash_keys empty';
584             } elsif ($data->{'secure_hash'} !~ /^sh\.(\d+)\.(\d+)$/ || $1 > $#$array) {
585 0         0 $err = 'Invalid secure hash';
586             } else {
587 2         5 my $rand1 = $1;
588 2         4 my $rand2 = $2;
589 2 50       10 my $real = $pass =~ /^[a-fA-F0-9]{32}$/ ? lc($pass) : md5_hex($pass);
590 2         6 my $str = join("/", @{$data}{qw(user cram_time expires_min payload)});
  2         6  
591 2         12 my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2));
592 2 50 33     12 if ($data->{'expires_min'} > 0
    50          
593             && ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) {
594 0         0 $err = 'Login expired';
595             } elsif (lc($data->{'test_pass'}) ne $sum) {
596 0         0 $err = 'Invalid login';
597             }
598             }
599              
600             ### looks like a simple_cram
601             } elsif ($data->{'cram_time'}) {
602 0         0 $data->add_data(type => 'simple_cram');
603 0 0       0 die "Type simple_cram disabled during verify_password" if $self->disable_simple_cram;
604 0 0       0 my $real = $pass =~ /^[a-fA-F0-9]{32}$/ ? lc($pass) : md5_hex($pass);
605 0         0 my $str = join("/", @{$data}{qw(user cram_time expires_min payload)});
  0         0  
606 0         0 my $sum = md5_hex($str .'/'. $real);
607 0 0 0     0 if ($data->{'expires_min'} > 0
    0          
608             && ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) {
609 0         0 $err = 'Login expired';
610             } elsif (lc($data->{'test_pass'}) ne $sum) {
611 0         0 $err = 'Invalid login';
612             }
613              
614             ### expiring plain
615             } elsif ($data->{'plain_time'}
616             && $data->{'expires_min'} > 0
617             && ($self->server_time - $data->{'plain_time'}) > $data->{'expires_min'} * 60) {
618 0         0 $err = 'Login expired';
619              
620             ### plaintext_crypt
621             } elsif ($pass =~ m|^([./0-9A-Za-z]{2})([./0-9A-Za-z]{11})$|
622             && crypt($data->{'test_pass'}, $1) eq $pass) {
623 2         6 $data->add_data(type => 'crypt', was_plaintext => 1);
624              
625             ### failed plaintext crypt
626             } elsif ($self->use_crypt) {
627 0         0 $err = 'Invalid login';
628 0 0       0 $data->add_data(type => 'crypt', was_plaintext => ($data->{'test_pass'} =~ /^[a-fA-F0-9]{32}$/ ? 0 : 1));
629              
630             ### plaintext and md5
631             } else {
632 17         69 my $is_md5_t = $data->{'test_pass'} =~ /^[a-fA-F0-9]{32}$/;
633 17         25 my $is_md5_r = $pass =~ /^[a-fA-F0-9]{32}$/;
634 17 50       78 my $test = $is_md5_t ? lc($data->{'test_pass'}) : md5_hex($data->{'test_pass'});
635 17 50       46 my $real = $is_md5_r ? lc($pass) : md5_hex($pass);
636 17 50       51 $data->add_data(type => ($is_md5_r ? 'md5' : 'plaintext'), was_plaintext => ($is_md5_t ? 0 : 1));
    50          
637 17 100       50 $err = 'Invalid login'
638             if $test ne $real;
639             }
640              
641 21 100       42 $data->error($err) if $err;
642 21         51 return ! $err;
643             }
644              
645 24     24 0 63 sub last_auth_data { shift->{'_last_auth_data'} }
646              
647             sub generate_token {
648 17     17 1 22 my $self = shift;
649 17   33     37 my $data = shift || $self->last_auth_data;
650 17 50       31 die "Can't generate a token off of a failed auth" if ! $data;
651 17 50       49 die "Can't generate a token for a user which contains a \"/\"" if $data->{'user'} =~ m{/};
652 17         24 my $token;
653 17 100       48 my $exp = defined($data->{'expires_min'}) ? $data->{'expires_min'} : $self->expires_min;
654              
655 17   50     37 my $user = $data->{'user'} || die "Missing user";
656 17         33 my $load = $self->generate_payload($data);
657 17 50       48 die "User can not contain a \"/\." if $user =~ m|/|;
658 17 50       30 die "Payload can not contain a \"/\. Please encode it in generate_payload." if $load =~ m|/|;
659              
660             ### do kinds that require staying plaintext
661 17 50 33     48 if ( (defined($data->{'use_plaintext'}) ? $data->{'use_plaintext'} : $self->use_plaintext) # ->use_plaintext is true if ->use_crypt is
    100 66        
      66        
      33        
662             || (defined($data->{'use_crypt'}) && $data->{'use_crypt'})
663             || (defined($data->{'type'}) && $data->{'type'} eq 'crypt')) {
664 5 50       18 my $pass = defined($data->{'test_pass'}) ? $data->{'test_pass'} : $data->{'real_pass'};
665 5 50       9 $token = $self->complex_plaintext ? join('/', $user, $self->server_time, $exp, $load, $pass) : "$user/$pass";
666              
667             ### all other types go to cram - secure_hash_cram, simple_cram, plaintext and md5
668             } else {
669 12 50       55 my $real = defined($data->{'real_pass'}) ? ($data->{'real_pass'} =~ /^[a-fA-F0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}))
    50          
670             : die "Missing real_pass";
671 12         15 my $array;
672 12 100 33     38 if (! $data->{'prefer_simple_cram'}
      66        
673 12         31 && ($array = eval { $self->secure_hash_keys })
674             && @$array) {
675 9         98 my $rand1 = int(rand @$array);
676 9         15 my $rand2 = int(rand 100000);
677 9         32 my $str = join("/", $user, $self->server_time, $exp, $load);
678 9         44 my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2));
679 9         28 $token = $str .'/'. $sum . '/sh.'.$rand1.'.'.$rand2;
680             } else {
681 3 50       6 die "Type simple_cram disabled during generate_token" if $self->disable_simple_cram;
682 3         6 my $str = join("/", $user, $self->server_time, $exp, $load);
683 3         17 my $sum = md5_hex($str .'/'. $real);
684 3         7 $token = $str .'/'. $sum;
685             }
686             }
687              
688 17 100 33     78 if (my $key = $data->{'use_blowfish'} || $self->use_blowfish) {
    50          
    50          
689 0         0 $token = encrypt_blowfish($token, $key);
690              
691             } elsif (defined($data->{'use_base64'}) ? $data->{'use_base64'} : $self->use_base64) {
692 17         60 $token = encode_base64($token, '');
693             }
694              
695 17         35 return $token;
696             }
697              
698             sub generate_payload {
699 17     17 0 24 my $self = shift;
700 17         19 my $args = shift;
701 17 50       39 if (my $meth = $self->{'generate_payload'}) {
702 0         0 return $meth->($self, $args);
703             }
704 17 100       38 return defined($args->{'payload'}) ? $args->{'payload'} : '';
705             }
706              
707             sub verify_user {
708 21     21 1 27 my $self = shift;
709 21         25 my $user = shift;
710 21 100       35 if (my $meth = $self->{'verify_user'}) {
711 3         7 return $meth->($self, $user);
712             }
713 18         36 return 1;
714             }
715              
716             sub cleanup_user {
717 24     24 1 41 my $self = shift;
718 24         29 my $user = shift;
719 24 100       44 if (my $meth = $self->{'cleanup_user'}) {
720 3         8 return $meth->($self, $user);
721             }
722 21         108 return $user;
723             }
724              
725             sub check_form_user_against_cookie {
726 2     2 0 15 my ($self, $form_user, $cookie_user, $data) = @_;
727 2 50 33     9 return if ! defined($form_user) || ! defined($cookie_user);
728 2         9 return $form_user eq $cookie_user;
729             }
730              
731             sub get_pass_by_user {
732 3     3 1 3 my $self = shift;
733 3         3 my $user = shift;
734 3 50       6 if (my $meth = $self->{'get_pass_by_user'}) {
735 3         5 return $meth->($self, $user);
736             }
737              
738 0         0 die "Please override get_pass_by_user";
739             }
740              
741             sub verify_payload {
742 17     17 1 41 my ($self, $payload, $data) = @_;
743 17 50       39 if (my $meth = $self->{'verify_payload'}) {
744 0         0 return $meth->($self, $payload, $data);
745             }
746 17         42 return 1;
747             }
748              
749             ###----------------------------------------------------------------###
750              
751             sub encrypt_blowfish {
752 0     0 0 0 my ($str, $key) = @_;
753              
754 0         0 require Crypt::Blowfish;
755 0         0 my $cb = Crypt::Blowfish->new($key);
756              
757 0         0 $str .= (chr 0) x (8 - length($str) % 8); # pad to multiples of 8
758              
759 0         0 my $enc = '';
760 0         0 $enc .= unpack "H16", $cb->encrypt($1) while $str =~ /\G(.{8})/g; # 8 bytes at a time
761              
762 0         0 return $enc;
763             }
764              
765             sub decrypt_blowfish {
766 0     0 0 0 my ($enc, $key) = @_;
767              
768 0         0 require Crypt::Blowfish;
769 0         0 my $cb = Crypt::Blowfish->new($key);
770              
771 0         0 my $str = '';
772 0         0 $str .= $cb->decrypt(pack "H16", $1) while $enc =~ /\G([A-Fa-f0-9]{16})/g;
773 0         0 $str =~ y/\00//d;
774              
775 0         0 return $str
776             }
777              
778             ###----------------------------------------------------------------###
779              
780             sub login_template {
781 8     8 1 10 my $self = shift;
782 8 50       18 return $self->{'login_template'} if $self->{'login_template'};
783              
784             my $text = join '',
785 0 0       0 map {ref $_ ? $$_ : /\[%/ ? $_ : $_ ? "[% TRY; PROCESS '$_'; CATCH %][% END %]\n" : ''}
  0 0       0  
    0          
786             $self->login_header, $self->login_form, $self->login_script, $self->login_footer;
787 0         0 return \$text;
788             }
789              
790 0 0   0 1 0 sub login_header { shift->{'login_header'} || 'login_header.tt' }
791 0 0   0 1 0 sub login_footer { shift->{'login_footer'} || 'login_footer.tt' }
792              
793             sub login_form {
794 0     0 1 0 my $self = shift;
795 0 0       0 return $self->{'login_form'} if defined $self->{'login_form'};
796 0         0 return \q{
797            
798            
799            
800            
801            
802            
824            
825            
826             };
827             }
828              
829 13 50   13 1 18 sub text_user { my $self = shift; return defined($self->{'text_user'}) ? $self->{'text_user'} : 'Username:' }
  13         50  
830 13 50   13 1 17 sub text_pass { my $self = shift; return defined($self->{'text_pass'}) ? $self->{'text_pass'} : 'Password:' }
  13         30  
831 13 50   13 1 16 sub text_save { my $self = shift; return defined($self->{'text_save'}) ? $self->{'text_save'} : 'Save Password ?' }
  13         31  
832 13 50   13 0 19 sub hide_save { my $self = shift; return defined($self->{'hide_save'}) ? $self->{'hide_save'} : 0 }
  13         187  
833 13 50   13 0 24 sub text_submit { my $self = shift; return defined($self->{'text_submit'}) ? $self->{'text_submit'} : 'Login' }
  13         36  
834              
835             sub login_script {
836 0     0 1 0 my $self = shift;
837 0 0       0 return $self->{'login_script'} if defined $self->{'login_script'};
838 0 0 0     0 return '' if $self->use_plaintext || $self->disable_simple_cram;
839 0         0 return \q{
840            
841            
842            
843            
862             };
863             }
864              
865             ###----------------------------------------------------------------###
866              
867             package CGI::Ex::Auth::Data;
868              
869 3     3   31 use strict;
  3         5  
  3         230  
870             use overload
871 128     128   546 'bool' => sub { ! shift->error },
872 0     0   0 '0+' => sub { 1 },
873 0     0   0 '""' => sub { shift->as_string },
874 3     3   2203 fallback => 1;
  3         1721  
  3         28  
875              
876             sub new {
877 24     24   36 my ($class, $args) = @_;
878 24 50       29 return bless {%{ $args || {} }}, $class;
  24         131  
879             }
880              
881             sub add_data {
882 65     65   79 my $self = shift;
883 65 100       120 my $args = @_ == 1 ? shift : {@_};
884 65         138 @{ $self }{keys %$args} = values %$args;
  65         204  
885             }
886              
887             sub error {
888 225     225   233 my $self = shift;
889 225 100       300 if (@_ == 1) {
890 7         12 $self->{'error'} = shift;
891 7         23 $self->{'error_caller'} = [caller];
892             }
893 225         558 return $self->{'error'};
894             }
895              
896             sub as_string {
897 0     0     my $self = shift;
898 0 0 0       return $self->error || ($self->{'user'} && $self->{'type'}) ? "Valid auth data" : "Unverified auth data";
899             }
900              
901             ###----------------------------------------------------------------###
902              
903             1;
904              
905             __END__