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

package CGI::Ex::Auth;

=head1 NAME

CGI::Ex::Auth - Handle logins nicely.

=head1 VERSION

version 2.54

=cut

###----------------------------------------------------------------###
#  Copyright - Paul Seamons                                          #
#  Distributed under the Perl Artistic License without warranty      #
###----------------------------------------------------------------###

use strict;
#use warnings; # TODO - investigate enabling in heavy usage scenarios

use MIME::Base64 qw(encode_base64 decode_base64);
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
use Carp qw(croak);

our $VERSION = '2.54'; # VERSION

###----------------------------------------------------------------###

sub new {
    my $class = shift || croak "Usage: ".__PACKAGE__."->new";
    my $self  = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
    return bless {%$self}, $class;
}

sub get_valid_auth {
    my $self = shift;
    $self = $self->new(@_) if ! ref $self;
    delete $self->{'_last_auth_data'};

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

    # allow for logout
    if ($form->{$self->key_logout} && ! $self->{'_logout_looking_for_user'}) {
        local $self->{'_logout_looking_for_user'} = 1;
        local $self->{'no_set_cookie'}    = 1;
        local $self->{'no_cookie_verify'} = 1;
        $self->check_valid_auth; # verify the logout so we can capture the username if possible

        $self->logout_hook;

        if ($self->bounce_on_logout) {
            my $key_c = $self->key_cookie;
            $self->delete_cookie({name => $key_c}) if $self->cookies->{$key_c};
            my $user = $self->last_auth_data ? $self->last_auth_data->{'user'} : undef;
            $self->location_bounce($self->logout_redirect(defined($user) ? $user : ''));
            eval { die "Logging out" };
            return;
        } else {
            $self->form({});
            $self->handle_failure;
            return;
        }
    }

    my $data;

    # look in form first
    my $form_user = delete $form->{$self->key_user};
    if (defined $form_user) {
        if (delete $form->{$self->key_loggedout}) { # don't validate the form on a logout
            $data = $self->new_auth_data({user => $form_user, error => 'Logged out'});
        } elsif (defined $form->{ $self->key_pass }) {
            $data = $self->verify_token({
                token => {
                    user        => $form_user,
                    test_pass   => delete $form->{ $self->key_pass },
                    expires_min => delete($form->{ $self->key_save }) ? -1 : delete($form->{ $self->key_expires_min }) || undef,
                },
                from => 'form',
            });
        } elsif (! length $form_user) {
            $data = $self->new_auth_data({user => '', error => 'Invalid user'});
        } else {
            $data = $self->verify_token({token => $form_user, from => 'form'});
        }
    }

    # no valid form data ? look in the cookie
    if (! ref($data)  # no form
        || ($data->error && $data->{'allow_cookie_match'})) { # had form with error - but we can check if form user matches existing cookie
        my $cookie = $self->cookies->{$self->key_cookie};
        if (defined($cookie) && length($cookie)) {
            my $form_data = $data;
            $data = $self->verify_token({token => $cookie, from => 'cookie'});
            if (defined $form_user) { # they had form data
                my $user = $self->cleanup_user($form_user);
                if (! $data || !$self->check_form_user_against_cookie($user, $data->{'user'}, $data)) { # but the cookie didn't match
                    $data = $self->{'_last_auth_data'} = $form_data; # restore old form data failure
                    $data->{'user'} = $user if ! defined $data->{'user'};
                }
            }
        }
    }

    # failure
    if (! $data) {
        return $self->handle_failure({had_form_data => defined($form_user)});
    }

    # success
    my $_key = $self->key_cookie;
    my $_val = $self->generate_token($data);
    my $use_session = $self->use_session_cookie($_key, $_val); # default false
    if ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt')) {
        $use_session = 1 if ! defined($use_session) && ! defined($data->{'expires_min'});
    }
    $self->set_cookie({
        name    => $_key,
        value   => $_val,
        expires => ($use_session ? '' : '+20y'), # non-cram cookie types are session cookies unless save was set (thus setting expires_min)
    });

    return $self->handle_success({is_form => ($data->{'from'} eq 'form' ? 1 : 0)});
}

sub handle_success {
    my $self = shift;
    my $args = shift || {};
    if (my $meth = $self->{'handle_success'}) {
        return $meth->($self, $args);
    }
    my $form = $self->form;

    # 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 (scalar(keys %{$self->cookies}) || $self->no_cookie_verify) {
        $self->success_hook;
        return $self;

    # need to verify cookies are set-able
    } elsif ($args->{'is_form'}) {
        $form->{$self->key_verify} = $self->server_time;
        my $url = $self->script_name . $self->path_info . "?". $self->cgix->make_form($form);

        $self->location_bounce($url);
        eval { die "Success login - bouncing to test cookie" };
        return;
    }
}

sub success_hook {
    my $self = shift;
    if (my $meth = $self->{'success_hook'}) {
        return $meth->($self);
    }
    return;
}

sub logout_hook {
    my $self = shift;
    if (my $meth = $self->{'logout_hook'}) {
        return $meth->($self);
    }
    return;
}

sub handle_failure {
    my $self = shift;
    my $args = shift || {};
    if (my $meth = $self->{'handle_failure'}) {
        return $meth->($self, $args);
    }
    my $form = $self->form;

    # make sure the cookie is gone
    my $key_c = $self->key_cookie;
    $self->delete_cookie({name => $key_c}) if exists $self->cookies->{$key_c};

    # no valid login and we are checking for cookies - 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;
    local $form->{$key_r} = $form->{$key_r} || $self->script_name . $self->path_info . (scalar(keys %$form) ? "?".$self->cgix->make_form($form) : '');
    local $form->{'had_form_data'} = $args->{'had_form_data'} || 0;
    $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;
    $self->failure_hook;

    return;
}

sub failure_hook {
    my $self = shift;
    if (my $meth = $self->{'failure_hook'}) {
        return $meth->($self);
    }
    return;
}

sub check_valid_auth {
    my $self = shift;
    $self = $self->new(@_) if ! ref $self;

    local $self->{'location_bounce'} = sub {}; # but don't bounce to other locations
    local $self->{'login_print'}     = sub {}; # check only - don't login if not
    local $self->{'set_cookie'}      = $self->{'no_set_cookie'} ? sub {} : $self->{'set_cookie'};
    return $self->get_valid_auth;
}

###----------------------------------------------------------------###

sub script_name { shift->{'script_name'} || $ENV{'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;
    return $self->{'delete_cookie'}->($self, $args) if $self->{'delete_cookie'};
    local $args->{'value'}   = '';
    local $args->{'expires'} = '-10y';
    if (my $dom = $ENV{HTTP_HOST}) {
        $dom =~ s/:\d+$//;
        do {
            local $args->{'domain'} = $dom;
            $self->set_cookie($args);
            local $args->{'domain'} = ".$dom";
            $self->set_cookie($args);
        }
        while ($dom =~ s/^[\w\-]*\.// and $dom =~ /\./);
    }
    $self->set_cookie($args);
    delete $self->cookies->{$args->{'name'}};
}

sub set_cookie {
    my $self = shift;
    my $args = shift;
    return $self->{'set_cookie'}->($self, $args) if $self->{'set_cookie'};
    my $key  = $args->{'name'};
    my $val  = $args->{'value'};
    my $dom  = $args->{'domain'}   || $self->cookie_domain;
    my $sec  = $args->{'secure'}   || $self->cookie_secure;
    my $http = $args->{'httponly'} || $self->cookie_httponly;
    my $same = $args->{'samesite'} || $self->cookie_samesite;
    $self->cgix->set_cookie({
        -name    => $key,
        -value   => $val,
        -path    => $args->{'path'} || $self->cookie_path($key, $val) || '/',
        ($dom  ? (-domain   => $dom)  : ()),
        ($sec  ? (-secure   => $sec)  : ()),
        ($http ? (-httponly => $http) : ()),
        ($same ? (-samesite => $same) : ()),
        ($args->{'expires'} ? (-expires => $args->{'expires'}): ()),
    });
    $self->cookies->{$key} = $val;
}

sub location_bounce {
    my $self = shift;
    my $url  = shift;
    return $self->{'location_bounce'}->($self, $url) if $self->{'location_bounce'};
    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_loggedout    { shift->{'key_loggedout'}    ||= 'loggedout'    }
sub bounce_on_logout { shift->{'bounce_on_logout'} ||= 0              }
sub secure_hash_keys { shift->{'secure_hash_keys'} ||= []             }
#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"}'
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 cookie_path      { shift->{'cookie_path'}      }
sub cookie_domain    { shift->{'cookie_domain'}    }
sub cookie_secure    { shift->{'cookie_secure'}    }
sub cookie_httponly  { shift->{'cookie_httponly'}  }
sub cookie_samesite  { shift->{'cookie_samesite'}  }
sub use_session_cookie { shift->{'use_session_cookie'} }
sub disable_simple_cram { shift->{'disable_simple_cram'} }
sub complex_plaintext { shift->{'complex_plaintext'} }

sub logout_redirect {
    my ($self, $user) = @_;
    my $form = $self->cgix->make_form({$self->key_loggedout => 1, (length($user) ? ($self->key_user => $user) : ()) });
    return $self->{'logout_redirect'} || $self->script_name ."?$form";
}

sub js_uri_path {
    my $self = shift;
    return $self->{'js_uri_path'} ||= $self->script_name ."/js";
}

###----------------------------------------------------------------###

sub no_cookies_print {
    my $self = shift;
    return $self->{'no_cookies_print'}->($self) if $self->{'no_cookies_print'};
    $self->cgix->print_content_type;
    print qq{You do not appear to have cookies enabled.};
}

sub login_print {
    my $self = shift;
    my $hash = $self->login_hash_common;
    my $file = $self->login_template;

    ### allow for a hooked override
    if (my $meth = $self->{'login_print'}) {
        $meth->($self, $file, $hash);
        return 0;
    }

    ### process the document
    my $args = $self->template_args;
    $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_include_path,
    my $t = $self->template_obj($args);
    my $out = '';
    $t->process_simple($file, $hash, \$out) || die $t->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_obj {
    my ($self, $args) = @_;
    return $self->{'template_obj'} || do {
        require Template::Alloy;
        Template::Alloy->new($args);
    };
}

sub template_args { $_[0]->{'template_args'} ||= {} }

sub template_include_path { $_[0]->{'template_include_path'} || '' }

sub login_hash_common {
    my $self = shift;
    my $form = $self->form;
    my $data = $self->last_auth_data;
    $data = {no_data => 1} if ! ref $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_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",
        $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_expires_min => $self->expires_min,
        text_user          => $self->text_user,
        text_pass          => $self->text_pass,
        text_save          => $self->text_save,
        text_submit        => $self->text_submit,
        hide_save          => $self->hide_save,
    };
}

###----------------------------------------------------------------###

sub verify_token {
    my $self  = shift;
    my $args  = shift;
    if (my $meth = $self->{'verify_token'}) {
        return $meth->($self, $args);
    }
    my $token = delete $args->{'token'}; die "Missing token" if ! length $token;
    my $data  = $self->new_auth_data({token => $token, %$args});
    my $meth;

    # make sure the token is parsed to usable data
    if (ref $token) { # token already parsed
        $data->add_data({%$token, armor => 'none'});

    } elsif (my $meth = $self->{'parse_token'}) {
        if (! $meth->($self, $args)) {
            $data->error('Invalid custom parsed token') if ! $data->error; # add error if not already added
            $data->{'allow_cookie_match'} = 1;
            return $data;
        }
    } else {
        if (! $self->parse_token($token, $data)) {
            $data->error('Invalid token') if ! $data->error; # add error if not already added
            $data->{'allow_cookie_match'} = 1;
            return $data;
        }
    }


    # verify the user
    if (! defined($data->{'user'})) {
        $data->error('Missing user');
    } elsif (! defined($data->{'user'} = $self->cleanup_user($data->{'user'}))
             || ! length($data->{'user'})) {
        $data->error('Missing cleaned user');
    } elsif (! defined $data->{'test_pass'}) {
        $data->error('Missing test_pass');
    } elsif (! $self->verify_user($data->{'user'})) {
        $data->error('Invalid user');
    }
    return $data if $data->error;

    # get the pass
    my $pass;
    if (! 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;
    $data->add_data({real_pass => $pass}); # store - to allow generate_token to not need to relookup the pass


    # validate the pass
    if ($meth = $self->{'verify_password'}) {
        if (! $meth->($self, $pass, $data)) {
            $data->error('Password failed verification') if ! $data->error;
        }
    } else{
        if (! $self->verify_password($pass, $data)) {
            $data->error('Password failed verification') if ! $data->error;
        }
    }
    return $data if $data->error;


    # validate the payload
    if ($meth = $self->{'verify_payload'}) {
        if (! $meth->($self, $data->{'payload'}, $data)) {
            $data->error('Payload failed custom verification') if ! $data->error;
        }
    } else {
        if (! $self->verify_payload($data->{'payload'}, $data)) {
            $data->error('Payload failed verification') if ! $data->error;
        }
    }

    return $data;
}

sub new_auth_data {
    my $self = shift;
    return $self->{'_last_auth_data'} = CGI::Ex::Auth::Data->new(@_);
}

sub parse_token {
    my ($self, $token, $data) = @_;
    my $found;
    my $bkey;
    for my $armor ('none', 'base64', 'blowfish') {
        my $copy = ($armor eq 'none')       ? $token
            : ($armor eq 'base64')          ? $self->use_base64 ? eval { local $^W; decode_base64($token) } : next
            : ($bkey = $self->use_blowfish) ? decrypt_blowfish($token, $bkey)
            : next;
        if ($self->complex_plaintext && $copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / ([^/]*) / (.*) $|x) {
            $data->add_data({
                user         => $1,
                plain_time   => $2,
                expires_min  => $3,
                payload      => $4,
                test_pass    => $5,
                armor        => $armor,
            });
            $found = 1;
            last;
        } elsif ($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;
        }
    }
    return $found;
}

sub verify_password {
    my ($self, $pass, $data) = @_;
    my $err;

    ### 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) {
            $err = 'secure_hash_keys not found';
        } elsif (! @$array) {
            $err = 'secure_hash_keys empty';
        } elsif ($data->{'secure_hash'} !~ /^sh\.(\d+)\.(\d+)$/ || $1 > $#$array) {
            $err = 'Invalid secure hash';
        } else {
            my $rand1 = $1;
            my $rand2 = $2;
            my $real  = $pass =~ /^[a-fA-F0-9]{32}$/ ? lc($pass) : md5_hex($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) {
                $err = 'Login expired';
            } elsif (lc($data->{'test_pass'}) ne $sum) {
                $err = 'Invalid login';
            }
        }

    ### looks like a simple_cram
    } elsif ($data->{'cram_time'}) {
        $data->add_data(type => 'simple_cram');
        die "Type simple_cram disabled during verify_password" if $self->disable_simple_cram;
        my $real = $pass =~ /^[a-fA-F0-9]{32}$/ ? lc($pass) : md5_hex($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) {
            $err = 'Login expired';
        } elsif (lc($data->{'test_pass'}) ne $sum) {
            $err = 'Invalid login';
        }

    ### expiring plain
    } elsif ($data->{'plain_time'}
             && $data->{'expires_min'} > 0
             && ($self->server_time - $data->{'plain_time'}) > $data->{'expires_min'} * 60) {
        $err = 'Login expired';

    ### plaintext_crypt
    } elsif ($pass =~ m|^([./0-9A-Za-z]{2})([./0-9A-Za-z]{11})$|
             && crypt($data->{'test_pass'}, $1) eq $pass) {
        $data->add_data(type => 'crypt', was_plaintext => 1);

    ### failed plaintext crypt
    } elsif ($self->use_crypt) {
        $err = 'Invalid login';
        $data->add_data(type => 'crypt', was_plaintext => ($data->{'test_pass'} =~ /^[a-fA-F0-9]{32}$/ ? 0 : 1));

    ### plaintext and md5
    } else {
        my $is_md5_t = $data->{'test_pass'} =~ /^[a-fA-F0-9]{32}$/;
        my $is_md5_r = $pass =~ /^[a-fA-F0-9]{32}$/;
        my $test = $is_md5_t ? lc($data->{'test_pass'}) : md5_hex($data->{'test_pass'});
        my $real = $is_md5_r ? lc($pass) : md5_hex($pass);
        $data->add_data(type => ($is_md5_r ? 'md5' : 'plaintext'), was_plaintext => ($is_md5_t ? 0 : 1));
        $err = 'Invalid login'
            if $test ne $real;
    }

    $data->error($err) if $err;
    return ! $err;
}

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;
    die "Can't generate a token for a user which contains a \"/\"" if $data->{'user'} =~ m{/};
    my $token;
    my $exp = defined($data->{'expires_min'}) ? $data->{'expires_min'} : $self->expires_min;

    my $user = $data->{'user'} || die "Missing user";
    my $load = $self->generate_payload($data);
    die "User can not contain a \"/\."                                           if $user =~ m|/|;
    die "Payload can not contain a \"/\.  Please encode it in generate_payload." if $load =~ m|/|;

    ### 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 = $self->complex_plaintext ? join('/', $user, $self->server_time, $exp, $load, $pass) : "$user/$pass";

    ### all other types go to cram - secure_hash_cram, simple_cram, plaintext and md5
    } else {
        my $real = defined($data->{'real_pass'}) ? ($data->{'real_pass'} =~ /^[a-fA-F0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}))
                                                 : die "Missing real_pass";
        my $array;
        if (! $data->{'prefer_simple_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 {
            die "Type simple_cram disabled during generate_token" if $self->disable_simple_cram;
            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;
    if (my $meth = $self->{'generate_payload'}) {
        return $meth->($self, $args);
    }
    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 check_form_user_against_cookie {
    my ($self, $form_user, $cookie_user, $data) = @_;
    return if ! defined($form_user) || ! defined($cookie_user);
    return $form_user eq $cookie_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, $payload, $data) = @_;
    if (my $meth = $self->{'verify_payload'}) {
        return $meth->($self, $payload, $data);
    }
    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 = join '',
        map {ref $_ ? $$_ : /\[%/ ? $_ : $_ ? "[% TRY; PROCESS '$_'; CATCH %][% END %]\n" : ''}
        $self->login_header, $self->login_form, $self->login_script, $self->login_footer;
    return \$text;
}

sub login_header { shift->{'login_header'} || 'login_header.tt' }
sub login_footer { shift->{'login_footer'} || 'login_footer.tt' }

sub login_form {
    my $self = shift;
    return $self->{'login_form'} if defined $self->{'login_form'};
    return \q{
[% error %]




 




803




 





 





 





 





 





 



  




804




 





 





 





 





 





 



   [% text_user %] 




805




 





 





 





 





 





 



    




806




 





 





 





 





 





 



  




807




 





 





 





 





 





 



  




808




 





 





 





 





 





 



   [% text_pass %] 




809




 





 





 





 





 





 



    




810




 





 





 





 





 





 



  




811




 





 





 





 





 





 



 [% IF ! hide_save ~%] 




812




 





 





 





 





 





 



  




813




 





 





 





 





 





 



    




814




 





 





 





 





 





 



      [% text_save %] 




815




 





 





 





 





 





 



    




816




 





 





 





 





 





 



  




817




 





 





 





 





 





 



 [%~ END %] 




818




 





 





 





 





 





 



  




819




 





 





 





 





 





 



    




820




 





 





 





 





 





 



      




821




 





 





 





 





 





 



    




822




 





 





 





 





 





 



  




823








[% IF ! hide_save ~%]


     [% text_save %]


[%~ END %]








};
}

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 hide_save   { my $self = shift; return defined($self->{'hide_save'})   ? $self->{'hide_save'}   : 0 }
sub text_submit { my $self = shift; return defined($self->{'text_submit'}) ? $self->{'text_submit'} : 'Login' }

sub login_script {
    my $self = shift;
    return $self->{'login_script'} if defined $self->{'login_script'};
    return '' if $self->use_plaintext || $self->disable_simple_cram;
    return \q{



 </td>
</tr>

<tr>
<td  class="h" >
<a name="844">844</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> if (document.md5_hex) document.[% form_name %].onsubmit = function () { </td>
</tr>

<tr>
<td  class="h" >
<a name="845">845</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var f = document.[% form_name %]; </td>
</tr>

<tr>
<td  class="h" >
<a name="846">846</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var u = f.[% key_user %].value; </td>
</tr>

<tr>
<td  class="h" >
<a name="847">847</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var p = f.[% key_pass %].value; </td>
</tr>

<tr>
<td  class="h" >
<a name="848">848</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var t = f.[% key_time %].value; </td>
</tr>

<tr>
<td  class="h" >
<a name="849">849</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var s = f.[% key_save %] && f.[% key_save %].checked ? -1 : f.[% key_expires_min %].value; </td>
</tr>

<tr>
<td  class="h" >
<a name="850">850</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="851">851</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var str = u+'/'+t+'/'+s+'/'+''; </td>
</tr>

<tr>
<td  class="h" >
<a name="852">852</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var sum = document.md5_hex(str +'/' + document.md5_hex(p)); </td>
</tr>

<tr>
<td  class="h" >
<a name="853">853</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="854">854</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var f2 = document.[% form_name %]_jspost; </td>
</tr>

<tr>
<td  class="h" >
<a name="855">855</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   f2.[% key_user %].value = str +'/'+ sum; </td>
</tr>

<tr>
<td  class="h" >
<a name="856">856</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   f2.[% key_redirect %].value = f.[% key_redirect %].value; </td>
</tr>

<tr>
<td  class="h" >
<a name="857">857</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   f2.action = f.action; </td>
</tr>

<tr>
<td  class="h" >
<a name="858">858</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   f2.submit(); </td>
</tr>

<tr>
<td  class="h" >
<a name="859">859</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   return false; </td>
</tr>

<tr>
<td  class="h" >
<a name="860">860</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> } </td>
</tr>

<tr>
<td  class="h" >
<a name="861">861</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">
};
}

###----------------------------------------------------------------###

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__