package CGI::Ex::Auth;
=head1 NAME
CGI::Ex::Auth - Handle logins nicely.
=cut
###----------------------------------------------------------------###
# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use strict;
use vars qw($VERSION);
use MIME::Base64 qw(encode_base64 decode_base64);
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
$VERSION = '2.10';
###----------------------------------------------------------------###
sub new {
my $class = shift || __PACKAGE__;
my $args = shift || {};
return bless {%$args}, $class;
}
sub get_valid_auth {
my $self = shift;
$self = $self->new(@_) if ! ref $self;
### shortcut that will print a js file as needed (such as the md5.js)
if ($self->script_name . $self->path_info eq $self->js_uri_path . "/CGI/Ex/md5.js") {
$self->cgix->print_js('CGI/Ex/md5.js');
eval { die "Printed Javascript" };
return;
}
my $form = $self->form;
my $cookies = $self->cookies;
my $key_l = $self->key_logout;
my $key_c = $self->key_cookie;
my $has_cookies = scalar %$cookies;
### allow for logout
if ($form->{$key_l}) {
$self->delete_cookie({key => $key_c});;
$self->location_bounce($self->logout_redirect);
eval { die "Logging out" };
return;
}
my $had_form_info;
foreach ([$form, $self->key_user, 1],
[$cookies, $key_c, 0],
) {
my ($hash, $key, $is_form) = @$_;
next if ! defined $hash->{$key};
$had_form_info ++ if $is_form;
### if it looks like a bare username (as in they didn't have javascript)- add in other items
my $data;
if ($is_form
&& $hash->{$key} !~ m|^[^/]+/|
&& defined $hash->{ $self->key_pass }) {
$data = $self->verify_token({
token => {
user => delete $hash->{$key},
test_pass => delete $hash->{ $self->key_pass },
expires_min => delete($hash->{ $self->key_save }) ? -1 : delete($hash->{ $self->key_expires_min }) || $self->expires_min,
payload => delete $hash->{ $self->key_payload } || '',
},
from => 'form',
}) || next;
} else {
$data = $self->verify_token({token => $hash->{$key}, from => ($is_form ? 'form' : 'cookie')}) || next;
delete $hash->{$key} if $is_form;
}
### generate a fresh cookie if they submitted info on plaintext types
if ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt')) {
$self->set_cookie({
key => $key_c,
val => $self->generate_token($data),
no_expires => ($data->{ $self->key_save } ? 0 : 1), # make it a session cookie unless they ask for saving
}) if $is_form; # only set the cookie if we found info in the form - the cookie will be a session cookie after that
### always generate a cookie on types that have expiration
} else {
$self->set_cookie({
key => $key_c,
val => $self->generate_token($data),
no_expires => 0,
});
}
### successful login
### bounce to redirect
if (my $redirect = $form->{ $self->key_redirect }) {
$self->location_bounce($redirect);
eval { die "Success login - bouncing to redirect" };
return;
### if they have cookies we are done
} elsif ($has_cookies || $self->no_cookie_verify) {
return $self;
### need to verify cookies are set-able
} elsif ($is_form) {
$form->{$self->key_verify} = $self->server_time;
my $query = $self->cgix->make_form($form);
my $url = $self->script_name . $self->path_info . ($query ? "?$query" : "");
$self->location_bounce($url);
eval { die "Success login - bouncing to test cookie" };
return;
}
}
### make sure the cookie is gone
$self->delete_cookie({key => $key_c}) if $cookies->{$key_c};
### nothing found - see if they have cookies
if (my $value = delete $form->{$self->key_verify}) {
if (abs(time() - $value) < 15) {
$self->no_cookies_print;
return;
}
}
### oh - you're still here - well then - ask for login credentials
my $key_r = $self->key_redirect;
if (! $form->{$key_r}) {
my $query = $self->cgix->make_form($form);
$form->{$key_r} = $self->script_name . $self->path_info . ($query ? "?$query" : "");
}
$form->{'had_form_data'} = $had_form_info;
$self->login_print;
my $data = $self->last_auth_data;
eval { die defined($data) ? $data : "Requesting credentials" };
### allow for a sleep to help prevent brute force
sleep($self->failed_sleep) if defined($data) && $data->error ne 'Login expired' && $self->failed_sleep;
return;
}
###----------------------------------------------------------------###
sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME" }
sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
sub server_time { time }
sub cgix {
my $self = shift;
$self->{'cgix'} = shift if $#_ != -1;
return $self->{'cgix'} ||= CGI::Ex->new;
}
sub form {
my $self = shift;
$self->{'form'} = shift if $#_ != -1;
return $self->{'form'} ||= $self->cgix->get_form;
}
sub cookies {
my $self = shift;
$self->{'cookies'} = shift if $#_ != -1;
return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
sub delete_cookie {
my $self = shift;
my $args = shift;
my $key = $args->{'key'};
$self->cgix->set_cookie({
-name => $key,
-value => '',
-expires => '-10y',
-path => '/',
});
delete $self->cookies->{$key};
}
sub set_cookie {
my $self = shift;
my $args = shift;
my $key = $args->{'key'};
my $val = $args->{'val'};
$self->cgix->set_cookie({
-name => $key,
-value => $val,
($args->{'no_expires'} ? () : (-expires => '+20y')), # let the expires time take care of things for types that self expire
-path => '/',
});
$self->cookies->{$key} = $val;
}
sub location_bounce {
my $self = shift;
my $url = shift;
return $self->cgix->location_bounce($url);
}
###----------------------------------------------------------------###
sub key_logout { shift->{'key_logout'} ||= 'cea_logout' }
sub key_cookie { shift->{'key_cookie'} ||= 'cea_user' }
sub key_user { shift->{'key_user'} ||= 'cea_user' }
sub key_pass { shift->{'key_pass'} ||= 'cea_pass' }
sub key_time { shift->{'key_time'} ||= 'cea_time' }
sub key_save { shift->{'key_save'} ||= 'cea_save' }
sub key_expires_min { shift->{'key_expires_min'} ||= 'cea_expires_min' }
sub form_name { shift->{'form_name'} ||= 'cea_form' }
sub key_verify { shift->{'key_verify'} ||= 'cea_verify' }
sub key_redirect { shift->{'key_redirect'} ||= 'cea_redirect' }
sub key_payload { shift->{'key_payload'} ||= 'cea_payload' }
sub secure_hash_keys { shift->{'secure_hash_keys'} ||= [] }
sub no_cookie_verify { shift->{'no_cookie_verify'} ||= 0 }
sub use_crypt { shift->{'use_crypt'} ||= 0 }
sub use_blowfish { shift->{'use_blowfish'} ||= '' }
sub use_plaintext { my $s = shift; $s->use_crypt || ($s->{'use_plaintext'} ||= 0) }
sub use_base64 { my $s = shift; $s->{'use_base64'} = 1 if ! defined $s->{'use_base64'}; $s->{'use_base64'} }
sub expires_min { my $s = shift; $s->{'expires_min'} = 6 * 60 if ! defined $s->{'expires_min'}; $s->{'expires_min'} }
sub failed_sleep { shift->{'failed_sleep'} ||= 0 }
sub logout_redirect {
my $self = shift;
return $self->{'logout_redirect'} || $self->script_name ."?loggedout=1";
}
sub js_uri_path {
my $self = shift;
return $self->{'js_uri_path'} ||= $self->script_name ."/js";
}
###----------------------------------------------------------------###
sub no_cookies_print {
my $self = shift;
$self->cgix->print_content_type;
print qq{
You do not appear to have cookies enabled.
};
return 1;
}
sub login_print {
my $self = shift;
my $hash = $self->login_hash_common;
my $template = $self->login_template;
### allow for a hooked override
if (my $meth = $self->{'login_print'}) {
$meth->($self, $template, $hash);
return 0;
}
### process the document
require CGI::Ex::Template;
my $cet = CGI::Ex::Template->new($self->template_args);
my $out = '';
$cet->process_simple($template, $hash, \$out) || die $cet->error;
### fill in form fields
require CGI::Ex::Fill;
CGI::Ex::Fill::fill({text => \$out, form => $hash});
### print it
$self->cgix->print_content_type;
print $out;
return 0;
}
sub template_args {
my $self = shift;
return $self->{'template_args'} ||= {
INCLUDE_PATH => $self->template_include_path,
};
}
sub template_include_path { shift->{'template_include_path'} || '' }
sub login_hash_common {
my $self = shift;
my $form = $self->form;
my $data = $self->last_auth_data;
$data = {} if ! defined $data;
return {
%$form,
error => ($form->{'had_form_data'}) ? "Login Failed" : "",
login_data => $data,
key_user => $self->key_user,
key_pass => $self->key_pass,
key_time => $self->key_time,
key_save => $self->key_save,
key_expires_min => $self->key_expires_min,
key_payload => $self->key_payload,
key_redirect => $self->key_redirect,
form_name => $self->form_name,
script_name => $self->script_name,
path_info => $self->path_info,
md5_js_path => $self->js_uri_path ."/CGI/Ex/md5.js",
use_plaintext => $self->use_plaintext,
$self->key_user => $data->{'user'} || '',
$self->key_pass => '', # don't allow for this to get filled into the form
$self->key_time => $self->server_time,
$self->key_payload => $self->generate_payload({%$data, login_form => 1}),
$self->key_expires_min => $self->expires_min,
text_user => $self->text_user,
text_pass => $self->text_pass,
text_save => $self->text_save,
};
}
###----------------------------------------------------------------###
sub verify_token {
my $self = shift;
my $args = shift;
my $token = delete $args->{'token'} || die "Missing token";
my $data = $self->{'_last_auth_data'} = $self->new_auth_data({token => $token, %$args});
### token already parsed
if (ref $token) {
$data->add_data({%$token, armor => 'none'});
### parse token for info
} else {
my $found;
my $key;
for my $armor ('none', 'base64', 'blowfish') { # try with and without base64 encoding
my $copy = ($armor eq 'none') ? $token
: ($armor eq 'base64') ? eval { local $^W; decode_base64($token) }
: ($key = $self->use_blowfish) ? decrypt_blowfish($token, $key)
: next;
if ($copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / (.*) / ([a-fA-F0-9]{32}) (?: / (sh\.\d+\.\d+))? $|x) {
$data->add_data({
user => $1,
cram_time => $2,
expires_min => $3,
payload => $4,
test_pass => $5,
secure_hash => $6 || '',
armor => $armor,
});
$found = 1;
last;
} elsif ($copy =~ m|^ ([^/]+) / (.*) $|x) {
$data->add_data({
user => $1,
test_pass => $2,
armor => $armor,
});
$found = 1;
last;
}
}
if (! $found) {
$data->error('Invalid token');
return $data;
}
}
### verify the user and get the pass
my $pass;
if (! defined($data->{'user'})) {
$data->error('Missing user');
} elsif (! defined $data->{'test_pass'}) {
$data->error('Missing test_pass');
} elsif (! $self->verify_user($data->{'user'} = $self->cleanup_user($data->{'user'}))) {
$data->error('Invalid user');
} elsif (! defined($pass = eval { $self->get_pass_by_user($data->{'user'}) })) {
$data->add_data({details => $@});
$data->error('Could not get pass');
} elsif (ref $pass eq 'HASH') {
my $extra = $pass;
$pass = exists($extra->{'real_pass'}) ? delete($extra->{'real_pass'})
: exists($extra->{'password'}) ? delete($extra->{'password'})
: do { $data->error('Data returned by get_pass_by_user did not contain real_pass or password'); undef };
$data->error('Invalid login') if ! defined $pass && ! $data->error;
$data->add_data($extra);
}
return $data if $data->error;
### store - to allow generate_token to not need to relookup the pass
$data->add_data({real_pass => $pass});
### looks like a secure_hash cram
if ($data->{'secure_hash'}) {
$data->add_data(type => 'secure_hash_cram');
my $array = eval {$self->secure_hash_keys };
if (! $array) {
$data->error('secure_hash_keys not found');
} elsif (! @$array) {
$data->error('secure_hash_keys empty');
} elsif ($data->{'secure_hash'} !~ /^sh\.(\d+)\.(\d+)$/ || $1 > $#$array) {
$data->error('Invalid secure hash');
} else {
my $rand1 = $1;
my $rand2 = $2;
my $real = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'});
my $str = join("/", @{$data}{qw(user cram_time expires_min payload)});
my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2));
if ($data->{'expires_min'} > 0
&& ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) {
$data->error('Login expired');
} elsif (lc($data->{'test_pass'}) ne $sum) {
$data->error('Invalid login');
}
}
### looks like a normal cram
} elsif ($data->{'cram_time'}) {
$data->add_data(type => 'cram');
my $real = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'});
my $str = join("/", @{$data}{qw(user cram_time expires_min payload)});
my $sum = md5_hex($str .'/'. $real);
if ($data->{'expires_min'} > 0
&& ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) {
$data->error('Login expired');
} elsif (lc($data->{'test_pass'}) ne $sum) {
$data->error('Invalid login');
}
### plaintext_crypt
} elsif ($data->{'real_pass'} =~ m|^([./0-9A-Za-z]{2})([./0-9A-Za-z]{11})$|
&& crypt($data->{'test_pass'}, $1) eq $data->{'real_pass'}) {
$data->add_data(type => 'crypt', was_plaintext => 1);
### failed plaintext crypt
} elsif ($self->use_crypt) {
$data->error('Invalid login');
$data->add_data(type => 'crypt', was_plaintext => ($data->{'test_pass'} =~ /^[a-f0-9]{32}$/ ? 0 : 1));
### plaintext and md5
} else {
my $is_md5_t = $data->{'test_pass'} =~ /^[a-f0-9]{32}$/;
my $is_md5_r = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/;
my $test = $is_md5_t ? lc($data->{'test_pass'}) : md5_hex($data->{'test_pass'});
my $real = $is_md5_r ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'});
$data->add_data(type => ($is_md5_r ? 'md5' : 'plaintext'), was_plaintext => ($is_md5_t ? 0 : 1));
$data->error('Invalid login')
if $test ne $real;
}
### check the payload
if (! $data->error && ! $self->verify_payload($data->{'payload'})) {
$data->error('Invalid payload');
}
return $data;
}
sub new_auth_data {
my $self = shift;
return CGI::Ex::Auth::Data->new(@_);
}
sub last_auth_data { shift->{'_last_auth_data'} }
sub generate_token {
my $self = shift;
my $data = shift || $self->last_auth_data;
die "Can't generate a token off of a failed auth" if ! $data;
my $token;
### do kinds that require staying plaintext
if ( (defined($data->{'use_plaintext'}) ? $data->{'use_plaintext'} : $self->use_plaintext) # ->use_plaintext is true if ->use_crypt is
|| (defined($data->{'use_crypt'}) && $data->{'use_crypt'})
|| (defined($data->{'type'}) && $data->{'type'} eq 'crypt')) {
my $pass = defined($data->{'test_pass'}) ? $data->{'test_pass'} : $data->{'real_pass'};
$token = $data->{'user'} .'/'. $pass;
### all other types go to cram - secure_hash_cram, cram, plaintext and md5
} else {
my $user = $data->{'user'} || die "Missing user";
my $real = defined($data->{'real_pass'}) ? ($data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}))
: die "Missing real_pass";
my $exp = defined($data->{'expires_min'}) ? $data->{'expires_min'} : $self->expires_min;
my $load = $self->generate_payload($data);
die "Payload can not contain a \"/\. Please escape it in generate_payload." if $load =~ m|/|;
die "User can not contain a \"/\." if $user =~ m|/|;
my $array;
if (! $data->{'prefer_cram'}
&& ($array = eval { $self->secure_hash_keys })
&& @$array) {
my $rand1 = int(rand @$array);
my $rand2 = int(rand 100000);
my $str = join("/", $user, $self->server_time, $exp, $load);
my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2));
$token = $str .'/'. $sum . '/sh.'.$rand1.'.'.$rand2;
} else {
my $str = join("/", $user, $self->server_time, $exp, $load);
my $sum = md5_hex($str .'/'. $real);
$token = $str .'/'. $sum;
}
}
if (my $key = $data->{'use_blowfish'} || $self->use_blowfish) {
$token = encrypt_blowfish($token, $key);
} elsif (defined($data->{'use_base64'}) ? $data->{'use_base64'} : $self->use_base64) {
$token = encode_base64($token, '');
}
return $token;
}
sub generate_payload {
my $self = shift;
my $args = shift;
return defined($args->{'payload'}) ? $args->{'payload'} : '';
}
sub verify_user {
my $self = shift;
my $user = shift;
if (my $meth = $self->{'verify_user'}) {
return $meth->($self, $user);
}
return 1;
}
sub cleanup_user {
my $self = shift;
my $user = shift;
if (my $meth = $self->{'cleanup_user'}) {
return $meth->($self, $user);
}
return $user;
}
sub get_pass_by_user {
my $self = shift;
my $user = shift;
if (my $meth = $self->{'get_pass_by_user'}) {
return $meth->($self, $user);
}
die "Please override get_pass_by_user";
}
sub verify_payload {
my $self = shift;
my $payload = shift;
if (my $meth = $self->{'verify_payload'}) {
return $meth->($self, $payload);
}
return 1;
}
###----------------------------------------------------------------###
sub encrypt_blowfish {
my ($str, $key) = @_;
require Crypt::Blowfish;
my $cb = Crypt::Blowfish->new($key);
$str .= (chr 0) x (8 - length($str) % 8); # pad to multiples of 8
my $enc = '';
$enc .= unpack "H16", $cb->encrypt($1) while $str =~ /\G(.{8})/g; # 8 bytes at a time
return $enc;
}
sub decrypt_blowfish {
my ($enc, $key) = @_;
require Crypt::Blowfish;
my $cb = Crypt::Blowfish->new($key);
my $str = '';
$str .= $cb->decrypt(pack "H16", $1) while $enc =~ /\G([A-Fa-f0-9]{16})/g;
$str =~ y/\00//d;
return $str
}
###----------------------------------------------------------------###
sub login_template {
my $self = shift;
return $self->{'login_template'} if $self->{'login_template'};
my $text = ""
. $self->login_header
. $self->login_form
. $self->login_script
. $self->login_footer;
return \$text;
}
sub login_header {
return shift->{'login_header'} || q {
[%~ TRY ; PROCESS 'login_header.tt' ; CATCH %][% END ~%]
};
}
sub login_footer {
return shift->{'login_footer'} || q {
[%~ TRY ; PROCESS 'login_footer.tt' ; CATCH %][% END ~%]
};
}
sub login_form {
return shift->{'login_form'} || q {
};
}
sub text_user { my $self = shift; return defined($self->{'text_user'}) ? $self->{'text_user'} : 'Username:' }
sub text_pass { my $self = shift; return defined($self->{'text_pass'}) ? $self->{'text_pass'} : 'Password:' }
sub text_save { my $self = shift; return defined($self->{'text_save'}) ? $self->{'text_save'} : 'Save Password ?' }
sub login_script {
return q {
[%~ IF ! use_plaintext %]
[% END ~%]
};
}
###----------------------------------------------------------------###
package CGI::Ex::Auth::Data;
use strict;
use overload
'bool' => sub { ! shift->error },
'0+' => sub { 1 },
'""' => sub { shift->as_string },
fallback => 1;
sub new {
my ($class, $args) = @_;
return bless {%{ $args || {} }}, $class;
}
sub add_data {
my $self = shift;
my $args = @_ == 1 ? shift : {@_};
@{ $self }{keys %$args} = values %$args;
}
sub error {
my $self = shift;
if (@_ == 1) {
$self->{'error'} = shift;
$self->{'error_caller'} = [caller];
}
return $self->{'error'};
}
sub as_string {
my $self = shift;
return $self->error || ($self->{'user'} && $self->{'type'}) ? "Valid auth data" : "Unverified auth data";
}
###----------------------------------------------------------------###
1;
__END__
=head1 SYNOPSIS
use CGI::Ex::Auth;
### authorize the user
my $auth = CGI::Ex::Auth->get_valid_auth({
get_pass_by_user => \&get_pass_by_user,
});
sub get_pass_by_user {
my $auth = shift;
my $user = shift;
my $pass = some_way_of_getting_password($user);
return $pass;
}
### OR - if you are using a OO based CGI or Application
sub require_authentication {
my $self = shift;
return $self->{'auth'} = CGI::Ex::Auth->get_valid_auth({
get_pass_by_user => sub {
my ($auth, $user) = @_;
return $self->get_pass($user);
},
});
}
sub get_pass {
my ($self, $user) = @_;
return $self->loopup_and_cache_pass($user);
}
=head1 DESCRIPTION
CGI::Ex::Auth allows for auto-expiring, safe and easy web based logins. Auth uses
javascript modules that perform MD5 hashing to cram the password on
the client side before passing them through the internet.
For the stored cookie you can choose to use cram mechanisms,
secure hash cram tokens, auto expiring logins (not cookie based),
and Crypt::Blowfish protection. You can also choose to keep
passwords plaintext and to use perl's crypt for testing
passwords.
A downside to this module is that it does not use a session to
preserve state so get_pass_by_user has to happen on every request (any
authenticated area has to verify authentication each time). A plus is
that you don't need to use a session if you don't want to. It is up
to the interested reader to add caching to the get_pass_by_user
method.
=head1 METHODS
=over 4
=item C
Constructor. Takes a hashref of properties as arguments.
Many of the methods which may be overridden in a subclass,
or may be passed as properties to the new constuctor such as in the following:
CGI::Ex::Auth->new({
get_pass_by_user => \&my_pass_sub,
key_user => 'my_user',
key_pass => 'my_pass',
login_template => \"