lib/Catalyst/Plugin/Authentication/Credential/Password.pm

   1 package Catalyst::Plugin::Authentication::Credential::Password;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Catalyst::Authentication::Credential::Password ();
   7
   8 ## BACKWARDS COMPATIBILITY - all subs below here are deprecated
   9 ## They are here for compatibility with older modules that use / inherit from C::P::A::Password
  10 ## login()'s existance relies rather heavily on the fact that only Credential::Password
  11 ## is being used as a credential.  This may not be the case.  This is only here
  12 ## for backward compatibility.  It will go away in a future version
  13 ## login should not be used in new applications.
  14
  15 sub login {
  16     my ( $c, $user, $password, @rest ) = @_;
  17
  18     unless (
  19         defined($user)
  20             or
  21         $user = $c->request->param("login")
  22              || $c->request->param("user")
  23              || $c->request->param("username")
  24     ) {
  25         $c->log->debug(
  26             "Can't login a user without a user object or user ID param")
  27               if $c->debug;
  28         return;
  29     }
  30
  31     unless (
  32         defined($password)
  33             or
  34         $password = $c->request->param("password")
  35                  || $c->request->param("passwd")
  36                  || $c->request->param("pass")
  37     ) {
  38         $c->log->debug("Can't login a user without a password")
  39           if $c->debug;
  40         return;
  41     }
  42
  43     unless ( Scalar::Util::blessed($user)
  44         and $user->isa("Catalyst::Authentication::User") )
  45     {
  46         if ( my $user_obj = $c->get_user( $user, $password, @rest ) ) {
  47             $user = $user_obj;
  48         }
  49         else {
  50             $c->log->debug("User '$user' doesn't exist in the default store")
  51               if $c->debug;
  52             return;
  53         }
  54     }
  55
  56     if ( $c->_check_password( $user, $password ) ) {
  57         $c->set_authenticated($user);
  58         $c->log->debug("Successfully authenticated user '$user'.")
  59           if $c->debug;
  60         return 1;
  61     }
  62     else {
  63         $c->log->debug(
  64             "Failed to authenticate user '$user'. Reason: 'Incorrect password'")
  65           if $c->debug;
  66         return;
  67     }
  68
  69 }
  70
  71 ## also deprecated.  Here for compatibility with older credentials which do not inherit from C::P::A::Password
  72 sub _check_password {
  73     my ( $c, $user, $password ) = @_;
  74
  75     if ( $user->supports(qw/password clear/) ) {
  76         return $user->password eq $password;
  77     }
  78     elsif ( $user->supports(qw/password crypted/) ) {
  79         my $crypted = $user->crypted_password;
  80         return $crypted eq crypt( $password, $crypted );
  81     }
  82     elsif ( $user->supports(qw/password hashed/) ) {
  83
  84         my $d = Digest->new( $user->hash_algorithm );
  85         $d->add( $user->password_pre_salt || '' );
  86         $d->add($password);
  87         $d->add( $user->password_post_salt || '' );
  88
  89         my $stored      = $user->hashed_password;
  90         my $computed    = $d->clone()->digest;
  91         my $b64computed = $d->clone()->b64digest;
  92
  93         return ( ( $computed eq $stored )
  94               || ( unpack( "H*", $computed ) eq $stored )
  95               || ( $b64computed eq $stored)
  96               || ( $b64computed.'=' eq $stored) );
  97     }
  98     elsif ( $user->supports(qw/password salted_hash/) ) {
  99         require Crypt::SaltedHash;
 100
 101         my $salt_len =
 102           $user->can("password_salt_len") ? $user->password_salt_len : 0;
 103
 104         return Crypt::SaltedHash->validate( $user->hashed_password, $password,
 105             $salt_len );
 106     }
 107     elsif ( $user->supports(qw/password self_check/) ) {
 108
 109         # while somewhat silly, this is to prevent code duplication
 110         return $user->check_password($password);
 111
 112     }
 113     else {
 114         Catalyst::Exception->throw(
 115                 "The user object $user does not support any "
 116               . "known password authentication mechanism." );
 117     }
 118 }
 119
 120 __PACKAGE__;
 121
 122 __END__
 123
 124 =pod
 125
 126 =head1 NAME
 127
 128 Catalyst::Plugin::Authentication::Credential::Password - Compatibility shim
 129
 130 =head1 DESCRIPTION
 131
 132 THIS IS A COMPATIBILITY SHIM.  It allows old configurations of Catalyst
 133 Authentication to work without code changes.
 134
 135 B<DO NOT USE IT IN ANY NEW CODE!>
 136
 137 Please see L<Catalyst::Authentication::Credential::Password> for more information.
 138
 139 =head1 METHODS
 140
 141 =head2 login( )
 142
 143 =cut