Chris/webperl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Overhaul of capability interrogation, addition of policy support.

Browse Source
This commit is contained in:
Chris 2013-02-13 14:16:31 +00:00
parent 2fb530567d
commit 5ef7038d36
5 changed files with 484 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

205
Webperl/Auth.pm
View File

@ -235,15 +235,15 @@ sub valid_user {
or return undef; or return undef;
# Check whether the user can authenticate if the implementation was found # Check whether the user can authenticate if the implementation was found
$valid = $methodimpl -> authenticate($username, $password, $self) $valid = $methodimpl -> authenticate($username, $password, $self);
if($methodimpl);
# errors should halt auth attempts
return undef if(!defined($valid));
} }
# If no authmethod was found for the user, or the auth failed and fallback is enabled, # If no authmethod was found for the user, or the auth failed and fallback is enabled,
# all the available auth methods should be checked. Note that !$methodimpl is here so # all the available auth methods should be checked.
# that, if an auth method is removed for some reason, the system will try other auth if(!$valid && (!$authmethod || $self -> {"settings"} -> {"Auth:enable_fallback"})) {
# methods instead.
if(!$valid && (!$authmethod || !$methodimpl || $self -> {"settings"} -> {"Auth:enable_fallback"})) {
foreach my $trymethod (@{$methods}) { foreach my $trymethod (@{$methods}) {
my $methodimpl = $self -> get_authmethod_module($trymethod) my $methodimpl = $self -> get_authmethod_module($trymethod)
or return undef; or return undef;
@ -265,7 +265,7 @@ sub valid_user {
if($valid); if($valid);
# Authentication failed. # Authentication failed.
return $self -> self_error("Invalid username or password specified."); return undef;
} }
@ -280,6 +280,8 @@ sub get_user_authmethod_module {
my $self = shift; my $self = shift;
my $username = shift; my $username = shift;
$self -> clear_error();
# Does the user have an authmethod set? # Does the user have an authmethod set?
my $authmethod = $self -> {"app"} -> get_user_authmethod($username); my $authmethod = $self -> {"app"} -> get_user_authmethod($username);
@ -321,38 +323,30 @@ sub get_authmethod_module {
# Note that this doesn't cover user creation, as these can not establish # Note that this doesn't cover user creation, as these can not establish
# which authmodule to use until the user has been created... # which authmodule to use until the user has been created...
## @method $ require_activate($username)
# Determine whether the user's AuthMethod module requires that user accounts ## @method $ capabilities($username, $capability)
# be activated before they can be used. # Interrogate the capabilities of the authentication method. This will either
# return a reference to a hash containing the capability information for the
# auth method or, if a valid capability argument is specified, this returns
# the value for that capability.
# #
# @param username The name of the user to check for authentication requirement. # @param username The name of the user to check
# @return true if the AuthMethod requires activation, false if it does not. # @param capability The optional name of the capability to obtain the value for.
sub require_activate { # @return If no 'capabilities' argument is provided, a reference to a hash
my $self = shift; # containing all of the authmethod's capabilities. If a capability is
my $username = shift; # specified, this returns the value for it, or undef if the requested
# capability is unknown.
sub capabilities {
my $self = shift;
my $username = shift;
my $capability = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username) my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef; or return undef;
return $methodimpl -> require_activate() return $methodimpl -> capabilities($capability);
or return $self -> self_error($methodimpl -> errstr());
}
## @method $ noactivate_message($username)
# Generate a message (or, better yet, a language variable marker) to show to users
# who attempt to activate an account that uses an AuthMethod that does not require it.
#
# @param username The name of the user trying to activate
# @return A message to show to the user when redundantly attempting to activate.
sub noactivate_message {
my $self = shift;
my $username = shift;
my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef;
return $methodimpl -> noactivate_message();
} }
@ -367,6 +361,8 @@ sub activated {
my $self = shift; my $self = shift;
my $username = shift; my $username = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username) my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef; or return undef;
@ -404,42 +400,6 @@ sub activate_user {
} }
## @method $ supports_recovery($username)
# Determine whether the user's AuthMethod allows users to recover their account details
# within the system.
#
# @param username The name of the user to check for recovery support for.
# @return True if the AuthMethod supports in-system account recovery, false if it does not.
sub supports_recovery {
my $self = shift;
my $username = shift;
my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef;
return $methodimpl -> supports_recovery()
or return $self -> self_error($methodimpl -> errstr());
}
## @method $ norecover_message($username)
# Generate a message to show users who attempt to recover their account using an AuthMethod
# that does not support in-system recovery.
#
# @param username The name of the user to obtain the 'recovery unsupported' message for
# @return A message to show to the user attempting an unsupported recovery operation.
sub norecover_message {
my $self = shift;
my $username = shift;
my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef;
return $methodimpl -> norecover_message()
or return $self -> self_error($methodimpl -> errstr());
}
## @method @ reset_password_actcode($username) ## @method @ reset_password_actcode($username)
# Forcibly reset the user's password and activation code to new random values. # Forcibly reset the user's password and activation code to new random values.
# #
@ -449,6 +409,8 @@ sub reset_password_actcode {
my $self = shift; my $self = shift;
my $username = shift; my $username = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username) my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef; or return undef;
@ -469,6 +431,8 @@ sub reset_password {
my $self = shift; my $self = shift;
my $username = shift; my $username = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username) my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef; or return undef;
@ -483,7 +447,7 @@ sub reset_password {
## @method $ set_password($username, $password) ## @method $ set_password($username, $password)
# Set the user's password to the specified value. # Set the user's password to the specified value.
# #
# @param username The ID of the user to set the password for # @param username The ID of the user to set the password for
# @param password The password to set for the user. # @param password The password to set for the user.
# @return True on success, undef on error. # @return True on success, undef on error.
sub set_password { sub set_password {
@ -491,6 +455,8 @@ sub set_password {
my $username = shift; my $username = shift;
my $password = shift; my $password = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username) my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef; or return undef;
@ -511,6 +477,8 @@ sub generate_actcode {
my $self = shift; my $self = shift;
my $username = shift; my $username = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username) my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef; or return undef;
@ -522,4 +490,99 @@ sub generate_actcode {
} }
## @method $ force_passchange($username)
# Determine whether the user needs to reset their password (either because they are
# using a temporary system-allocated password, or the password policy requires it).
#
# @param username The name of the user who to check password status for.
# @return 'temporary' if the user must change their password because it is a
# temporary one, 'expired' if the password has expired, the empty string if
# the password does not need to be changed, undef on error.
sub force_passchange {
my $self = shift;
my $username = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef;
my $user = $self -> get_user($username)
or return undef;
return $methodimpl -> force_passchange($user -> {"user_id"})
or return $self -> self_error($methodimpl -> errstr());
}
## @method @ mark_loginfail($username)
# For method implementations that support it, mark the user as failing a login.
# Some authmethods may limit user login failures and deactivate accounts that
# have failed repeatedly.
#
# @param username The name of the user who failed to log in. If this user does
# not exist, this returns undef.
# @return An array containing two values: The first is the number of login failures
# recorded for the user, the second is the number of allowed failures. If
# the second value is zero, no failure limiting is being performed. If an error
# occurs, both values are undef.
sub mark_loginfail {
my $self = shift;
my $username = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username)
or return (undef, undef);
my $user = $self -> get_user($username)
or return (undef, undef);
# Don't actually need to check $methodimpl -> capabilities("failcount") here, as
# the default implementation returns usably sane values.
my ($failcount, $limit) = $methodimpl -> mark_loginfail($user -> {"user_id"});
return ($self -> self_error($methodimpl -> errstr()), undef)
unless(defined($failcount));
return ($failcount, $limit);
}
## @method $ apply_policy($username, $password)
# Apply the configured password policy to the specified password string.
# The following configuration parameters (which should be set for each applicable
# authmethod in the auth_method_params table) are used to control the policy. If
# no value is set for a given parameter, the policy is assumed to not care about
# the parameter:
#
# - `policy_min_length`, passwords must be at least this number of characters long.
# - `policy_min_lowercase`, at least this number of lowercase characters must be present.
# - `policy_min_uppercase`, at least this many uppercase characters must be included.
# - `policy_min_digits`, the minimum number of digits that must be used.
# - `policy_min_other`, the number of non-alphanumeric characters that must be present.
# - `policy_min_entropy`, the minimum password entropy (as calculated by Data::Password::Entropy)
# to allow for passwords. See
# - `policy_use_cracklib`, if true, passwords are checked using cracklib.
#
# @param username The name of the user to check the password for.
# @param password The password string to check against the password policy.
# @return undef if the password passes the password policy, otherwise a reference to
# a hash, the keys forming the names of the policy rules failed, and the values
# being array references containing the settings for the policy rule and the value
# detected.
sub apply_policy {
my $self = shift;
my $username = shift;
my $password = shift;
$self -> clear_error();
my $methodimpl = $self -> get_user_authmethod_module($username)
or return undef;
return $methodimpl -> apply_policy($password)
or return $self -> self_error($methodimpl -> errstr());
}
1; 1;

237
Webperl/AuthMethod.pm
View File

@ -26,6 +26,35 @@ package Webperl::AuthMethod;
use strict; use strict;
use base qw(Webperl::SystemModule); use base qw(Webperl::SystemModule);
# ============================================================================
# Constructor
## @cmethod $ new(%args)
# Construct a new AuthMethod object. This will create a new AuthMethod object
# initialised with the provided arguments.
#
# @param args A hash of arguments to initialise the AuthMethod object with.
# @return A new AuthMethod object.
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = $class -> SUPER::new(@_)
or return undef;
$self -> {"capabilities"} = {"activate" => 0,
"activate_message" => $self -> {"noactivate_message"} || $self -> {"settings"} -> {"config"} -> {"AuthMethod::noactivate_message"},
"recover" => 0,
"recover_message" => $self -> {"norecover_message"} || $self -> {"settings"} -> {"config"} -> {"AuthMethod::norecover_message"},
"passchange" => 0,
"passchange_message" => $self -> {"nopasschange_message"} || $self -> {"settings"} -> {"config"} -> {"AuthMethod::nopasschange_message"},
"failcount" => 0,
"failcount_message" => $self -> {"nofailcount_message"} || $self -> {"settings"} -> {"config"} -> {"AuthMethod::nofailcount_message"},
};
return $self;
}
# ============================================================================ # ============================================================================
# Interface code # Interface code
@ -84,28 +113,39 @@ sub authenticate {
} }
## @method $ require_activate() ## @method $ capabilities($capability)
# Determine whether the AuthMethod module requires that user accounts # Interrogate the capabilities of the authentication method. This will either
# be activated before they can be used. # return a reference to a hash containing the capability information for the
# auth method or, if a valid capability argument is specified, this returns
# the value for that capability.
# #
# @return true if the AuthMethod requires activation, false if it does not. # @param capability The optional name of the capability to obtain the value for.
sub require_activate { # @return If no 'capabilities' argument is provided, a reference to a hash
my $self = shift; # containing all of the authmethod's capabilities. If a capability is
# specified, this returns the value for it, or undef if the requested
# capability is unknown.
sub capabilities {
my $self = shift;
my $capability = shift;
# By default, AuthMethods do not require account activation return($self -> {"capabilities"} -> {$capability})
return 0; if($capability && $self -> {"capabilities"});
return $self -> {"capabilities"};
} }
## @method $ noactivate_message() ## @method $ generate_actcode($userid)
# Generate a message (or, better yet, a language variable marker) to show to users # Generate a new activation code for the specified user.
# who attempt to activate an account that uses an AuthMethod that does not require it.
# #
# @return A message to show to the user when redundantly attempting to activate. # @param userid The ID of the user to reset the actcode for
sub noactivate_message { # @return The new activation code for the user
my $self = shift; sub generate_actcode {
my $self = shift;
my $userid = shift;
return $self -> {"noactivate_message"} || $self -> {"settings"} -> {"config"} -> {"AuthMethod::noactivate_message"}; # do nothing as activation is not required
return $self -> self_error($self -> capabilities("activate_message"));
} }
@ -135,32 +175,7 @@ sub activate_user {
my $userid = shift; my $userid = shift;
# Activation will always fail if not needed # Activation will always fail if not needed
return $self -> self_error("Unsupported activation requested"); return $self -> self_error($self -> capabilities("activate_message"));
}
## @method $ supports_recovery()
# Determine whether the AuthMethod allows users to recover their account details
# within the system.
#
# @return True if the AuthMethod supports in-system account recovery, false if it does not.
sub supports_recovery {
my $self = shift;
# By default, AuthMethods do not support recovery
return 0;
}
## @method $ norecover_message()
# Generate a message to show users who attempt to recover their account using an AuthMethod
# that does not support in-system recovery.
#
# @return A message to show to the user attempting an unsupported recovery operation.
sub norecover_message {
my $self = shift;
return $self -> {"norecover_message"} || $self -> {"settings"} -> {"config"} -> {"AuthMethod::norecover_message"};
} }
@ -174,7 +189,7 @@ sub reset_password_actcode {
my $userid = shift; my $userid = shift;
# Do nothing, as by default activation and password change are not supported # Do nothing, as by default activation and password change are not supported
return $self -> self_error("Unsupported password and activation code change requested"); return $self -> self_error($self -> capabilities("recover_message"));
} }
@ -188,7 +203,7 @@ sub reset_password {
my $userid = shift; my $userid = shift;
# Do nothing as password changes are not supported # Do nothing as password changes are not supported
return $self -> self_error("Unsupported password change requested"); return $self -> self_error($self -> capabilities("passchange_message"));
} }
@ -203,21 +218,141 @@ sub set_password {
my $userid = shift; my $userid = shift;
# Do nothing as password changes are not supported # Do nothing as password changes are not supported
return $self -> self_error("Unsupported password change requested"); return $self -> self_error($self -> capabilities("passchange_message"));
} }
## @method $ generate_actcode($userid) ## @method $ force_passchange($userid)
# Generate a new activation code for the specified user. # Determine whether the user needs to reset their password (either because they are
# using a temporary system-allocated password, or the password policy requires it).
# #
# @param userid The ID of the user to reset the actcode for # If a password expiration policy is in use, `policy_max_passwordage` should be set
# @return The new activation code for the user # in the auth_method_params for the applicable authmethods. The parameter should contain
sub generate_actcode { # the maximum age of any given password in seconds. If not set, expiration is not
# enforced.
#
# @param userid The ID of the user to check for password change requirement.
# @return A string indicating why the user must change their password if they need
# to, the empty string if they do not, undef on error.
sub force_passchange {
my $self = shift; my $self = shift;
my $userid = shift; my $userid = shift;
# do nothing as activation is not required # By default, AuthMethods do not support password changing, so they can't force it.
return $self -> self_error("Unsupported activation code change requested"); return ''
}
## @method @ mark_loginfail($userid)
# Increment the login failure count for the specified user. The following configuration
# parameter (which should be set for each applicable authmethod in the auth_method_params
# table) is used to control the login failure marking process:
#
# - `policy_max_loginfail`, the number of login failures a user may have before their
# account is deactivated.
#
# @warning Login failure limiting should not be performed unless account activation
# and password changes are supported. Otherwise the system has no means of
# preventing attempts to log in past the limit.
#
# @param userid The ID of the user to increment the login failure counter for.
# @return An array containing two values: The first is the number of login failures
# recorded for the user, the second is the number of allowed failures. If
# the second value is zero, no failure limiting is being performed. If an error
# occurs or the user does not exist, both values are undef.
sub mark_loginfail {
my $self = shift;
my $userid = shift;
# login failure counting is not supported by default, so users never get deactivated.
return (0, 0);
}
## @method $ apply_policy($password)
# Apply the configured password policy to the specified password string.
# The following configuration parameters (which should be set for each applicable
# authmethod in the auth_method_params table) are used to control the policy. If
# no value is set for a given parameter, the policy is assumed to not care about
# the parameter:
#
# - `policy_min_length`, passwords must be at least this number of characters long.
# - `policy_min_lowercase`, at least this number of lowercase characters must be present.
# - `policy_min_uppercase`, at least this many uppercase characters must be included.
# - `policy_min_digits`, the minimum number of digits that must be used.
# - `policy_min_other`, the number of non-alphanumeric characters that must be present.
# - `policy_min_entropy`, the minimum password entropy (as calculated by Data::Password::Entropy)
# to allow for passwords. See
# - `policy_use_cracklib`, if true, passwords are checked using cracklib.
#
# @param password The password string to check against the password policy.
# @return undef if the password passes the password policy, otherwise a reference to
# a hash, the keys forming the names of the policy rules failed, and the values
# being array references containing the settings for the policy rule and the value
# detected.
sub apply_policy {
my $self = shift;
my $password = shift;
my $failures = {};
$failures -> {"policy_min_length"} = [ $self -> {"policy_min_length"}, length($password) ]
if($self -> {"policy_min_length"} && length($password) < $self -> {"policy_min_length"});
my $lowercount = $password =~ tr/a-z//;
$failures -> {"policy_min_lowercase"} = [ $self -> {"policy_min_lowercase"}, $lowercount ]
if($self -> {"policy_min_lowercase"} && $lowercount < $self -> {"policy_min_lowercase"});
my $uppercount = $password =~ tr/A-Z//;
$failures -> {"policy_min_uppercase"} = [ $self -> {"policy_min_uppercase"}, $uppercount ]
if($self -> {"policy_min_uppercase"} && $uppercount < $self -> {"policy_min_uppercase"});
my $digitcount = $password =~ tr/0-9//;
$failures -> {"policy_min_digits"} = [ $self -> {"policy_min_digits"}, $digitcount ]
if($self -> {"policy_min_digits"} && $digitcount < $self -> {"policy_min_digits"});
my $othercount = length($password) - ($lowercount + $uppercount + $digitcount);
$othercount = 0 if($othercount < 0); # Impossibru! But check it anyway.
$failures -> {"policy_min_others"} = [ $self -> {"policy_min_others"}, $othercount ]
if($self -> {"policy_min_others"} && $othercount < $self -> {"policy_min_others"});
# Check against Data::Password::Entropy if possible
if($self -> {"policy_min_entropy"}) {
# Load the entropy module at runtime, so that systems that don't test entropy don't need it...
eval {
require Data::Password::Entropy;
Data::Password::Entropy -> import();
};
# Handle attempted load that fails. This is transparent to users, which may be a bad thing....
if($@) {
$self -> {"logger"} -> log("error", 0, undef, "policy_min_entropy is set, but unable to load Data::Password::Entropy!");
} else {
my $entropy = password_entropy($password);
$failures -> {"policy_min_entropy"} = [ $self -> {"policy_min_entropy"}, $entropy ]
if($entropy < $self -> {"policy_min_entropy"});
}
}
# Potentially invoke cracklib
if($self -> {"policy_use_cracklib"}) {
# Load the cracklib module at runtime, so that systems that don't test against it don't need it...
eval {
require Crypt::Cracklib;
Crypt::Cracklib -> import();
};
# Handle attempted load that fails. This is transparent to users, which may be a bad thing....
if($@) {
$self -> {"logger"} -> log("error", 0, undef, "policy_use_cracklib is set, but unable to load Crypt::Cracklib!");
} else {
my $crackres = fascist_check($password);
$failures -> {"policy_use_cracklib"} = [1, $crackres]
if($crackres ne "ok");
}
}
return scalar(keys(%$failures)) ? $failures : undef;
} }
1; 1;

183
Webperl/AuthMethod/Database.pm
View File

@ -22,26 +22,25 @@
# The users' passwords are never stored as plain text - this uses a # The users' passwords are never stored as plain text - this uses a
# salted, hashed storage mechanism for passwords. # salted, hashed storage mechanism for passwords.
# #
# This module will expect at least the following configuration values # This module supports the following comfiguration variables:
# to be passed to the constructor.
# #
# * table - The name of the database table to authenticate against. # - table (required) The name of the database table to authenticate against.
# This must be accessible to the system-wide dbh object. # This table must be accessible to the system-wide dbh object.
# * userfield - The name of the column in the table that stores usernames. # - bcrypt_cost (optional) the number of iterations of hashing to perform. This
# * passfield - The password column in the table. The field in the table # defaults to Webperl::AuthMethod::Database::COST_DEFAULT if not
# must be able to store a 59 character hashed password. # specified.
# #
# The following arguments may also be provided to the module constructor: # These will generally be provided by supplying the configuration variables
# # in the auth_methods_params table and using Webperl::AuthMethods to load
# * bcrypt_cost - the number of iterations of hashing to perform. This # the AuthMethod at runtime.
# defaults to COST_DEFAULT if not specified.
package Webperl::AuthMethod::Database; package Webperl::AuthMethod::Database;
use strict; use strict;
use base qw(Webperl::AuthMethod); # This class extends AuthMethod use base qw(Webperl::AuthMethod); # This class extends AuthMethod
use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64); use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64);
use constant COST_DEFAULT => 14; # The default cost to use if bcrypt_cost is not set. ## The default cost to use if bcrypt_cost is not passed to the constructor.
use constant COST_DEFAULT => 14;
# ============================================================================ # ============================================================================
@ -58,19 +57,27 @@ use constant COST_DEFAULT => 14; # The default cost to use if bcrypt_cost is not
sub new { sub new {
my $invocant = shift; my $invocant = shift;
my $class = ref($invocant) || $invocant; my $class = ref($invocant) || $invocant;
my $self = $class -> SUPER::new(@_); my $self = $class -> SUPER::new(@_)
or return undef;
# bomb if the parent constructor failed.
return $class -> SUPER::get_error() if(!$self);
# Set default values as needed
$self -> {"bcrypt_cost"} = COST_DEFAULT;
# check that required settings are set... # check that required settings are set...
return "Webperl::AuthMethod::Database missing 'table' argument in new()" if(!$self -> {"table"}); return set_error("Webperl::AuthMethod::Database missing 'table' argument in new()")
return "Webperl::AuthMethod::Database missing 'userfield' argument in new()" if(!$self -> {"userfield"}); if(!$self -> {"table"});
return "Webperl::AuthMethod::Database missing 'passfield' argument in new()" if(!$self -> {"passfield"});
# Set default values as needed
$self -> {"bcrypt_cost"} = COST_DEFAULT
unless($self -> {"bcrypt_cost"});
# replace the stock capabilities
$self -> {"capabilities"} = {"activate" => 1,
"activate_message" => '',
"recover" => 1,
"recover_message" => '',
"passchange" => 1,
"passchange_message" => '',
"failcount" => 1,
"failcount_message" => '',
};
return $self; return $self;
} }
@ -130,8 +137,8 @@ sub create_user {
# Do the insert # Do the insert
my $userh = $self -> {"dbh"} -> prepare("INSERT INTO ".$self -> {"settings"} -> {"database"} -> {"users"}." my $userh = $self -> {"dbh"} -> prepare("INSERT INTO ".$self -> {"settings"} -> {"database"} -> {"users"}."
(user_auth, username, password, email, created, act_code) (user_auth, username, password, password_set, force_change, email, created, act_code)
VALUES(?, ?, ?, ?, UNIX_TIMESTAMP(), ?)"); VALUES(?, ?, ?, UNIX_TIMESTAMP(), 1, ?, UNIX_TIMESTAMP(), ?)");
my $rows = $userh -> execute($authmethod, $username, $cryptpass, $email, $actcode); my $rows = $userh -> execute($authmethod, $username, $cryptpass, $email, $actcode);
return $self -> self_error("Unable to perform user insert: ". $self -> {"dbh"} -> errstr) if(!$rows); return $self -> self_error("Unable to perform user insert: ". $self -> {"dbh"} -> errstr) if(!$rows);
return $self -> self_error("User insert failed, no rows added.") if($rows eq "0E0"); return $self -> self_error("User insert failed, no rows added.") if($rows eq "0E0");
@ -166,10 +173,13 @@ sub authenticate {
my $password = shift; my $password = shift;
my $auth = shift; my $auth = shift;
my $userh = $self -> {"dbh"} -> prepare("SELECT ".$self -> {"passfield"}." FROM ".$self -> {"table"}." return $auth -> self_error("Database login failed: Username and password are required.")
WHERE ".$self -> {"userfield"}." LIKE ?"); if(!$username || !$password);
my $userh = $self -> {"dbh"} -> prepare("SELECT password FROM ".$self -> {"table"}."
WHERE username LIKE ?");
$userh -> execute($username) $userh -> execute($username)
or $self -> {"logger"} -> die_log($self -> {"cgi"} -> remote_host(), "Unable to execute user lookup query: ".$self -> {"dbh"} -> errstr); or return $auth -> self_error("Database login failed: Unable to execute user lookup query: ".$self -> {"dbh"} -> errstr);
# If a user has been found with the specified username, check the password... # If a user has been found with the specified username, check the password...
my $user = $userh -> fetchrow_arrayref(); my $user = $userh -> fetchrow_arrayref();
@ -184,18 +194,6 @@ sub authenticate {
} }
## @method $ require_activate()
# Determine whether the AuthMethod module requires that user accounts
# be activated before they can be used.
#
# @return true if the AuthMethod requires activation, false if it does not.
sub require_activate {
my $self = shift;
return 1;
}
## @method $ activated($userid) ## @method $ activated($userid)
# Determine whether the user account specified has been activated. # Determine whether the user account specified has been activated.
# #
@ -232,7 +230,7 @@ sub activate_user {
$self -> clear_error(); $self -> clear_error();
my $activate = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}." my $activate = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}."
SET activated = UNIX_TIMESTAMP(), act_code = NULL SET activated = UNIX_TIMESTAMP(), act_code = NULL, fail_count = 0
WHERE user_id = ?"); WHERE user_id = ?");
my $rows = $activate -> execute($userid); my $rows = $activate -> execute($userid);
return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows); return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows);
@ -242,18 +240,6 @@ sub activate_user {
} }
## @method $ supports_recovery()
# Determine whether the AuthMethod allows users to recover their account details
# within the system.
#
# @return True if the AuthMethod supports in-system account recovery, false if it does not.
sub supports_recovery {
my $self = shift;
return 1;
}
## @method @ reset_password_actcode($userid) ## @method @ reset_password_actcode($userid)
# Forcibly reset the user's password and activation code to new random values. # Forcibly reset the user's password and activation code to new random values.
# #
@ -270,7 +256,7 @@ sub reset_password_actcode {
my $cryptpass = $self -> hash_password($password); my $cryptpass = $self -> hash_password($password);
my $reseth = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}." my $reseth = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}."
SET password = ?, act_code = ? SET password = ?, act_code = ?, password_set = UNIX_TIMESTAMP(), force_change = 1, activated = NULL
WHERE user_id = ?"); WHERE user_id = ?");
my $rows = $reseth -> execute($cryptpass, $actcode, $userid); my $rows = $reseth -> execute($cryptpass, $actcode, $userid);
return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows); return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows);
@ -295,7 +281,7 @@ sub reset_password {
my $cryptpass = $self -> hash_password($password); my $cryptpass = $self -> hash_password($password);
my $reseth = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}." my $reseth = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}."
SET password = ? SET password = ?, password_set = UNIX_TIMESTAMP(), force_change = 1
WHERE user_id = ?"); WHERE user_id = ?");
my $rows = $reseth -> execute($cryptpass, $userid); my $rows = $reseth -> execute($cryptpass, $userid);
return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows); return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows);
@ -320,7 +306,7 @@ sub set_password {
my $cryptpass = $self -> hash_password($password); my $cryptpass = $self -> hash_password($password);
my $reseth = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}." my $reseth = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}."
SET password = ? SET password = ?, password_set = UNIX_TIMESTAMP()
WHERE user_id = ?"); WHERE user_id = ?");
my $rows = $reseth -> execute($cryptpass, $userid); my $rows = $reseth -> execute($cryptpass, $userid);
return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows); return $self -> self_error("Unable to perform user update: ". $self -> {"dbh"} -> errstr) if(!$rows);
@ -352,6 +338,93 @@ sub generate_actcode {
} }
## @method @ mark_loginfail($userid)
# Increment the login failure count for the specified user. The following configuration
# parameter (which should be set for each applicable authmethod in the auth_method_params
# table) is used to control the login failure marking process:
#
# - `policy_max_loginfail`, the number of login failures a user may have before their
# account is deactivated.
#
# @warning Login failure limiting should not be performed unless account activation
# and password changes are supported. Otherwise the system has no means of
# preventing attempts to log in past the limit.
#
# @param userid The ID of the user to increment the login failure counter for.
# @return An array containing two values: The first is the number of login failures
# recorded for the user, the second is the number of allowed failures. If
# the second value is zero, no failure limiting is being performed. If an error
# occurs or the user does not exist, both values are undef.
sub mark_loginfail {
my $self = shift;
my $userid = shift;
my $userh = $self -> {"dbh"} -> prepare("SELECT fail_count
FROM ".$self -> {"settings"} -> {"database"} -> {"users"}."
WHERE user_id = ?");
$userh -> execute($userid)
or return $self -> self_error("Unable to perform user lookup: ". $self -> {"dbh"} -> errstr);
my $failcount = $userh -> fetchrow_arrayref();
# Halt if the user does not exist
return (undef, undef) unless($failcount);
# Do nothing if limiting is not enabled
return (0, 0) unless($self -> {"policy_max_loginfail"});
++$failcount;
# update the login fail counter
$userh = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"users"}."
SET fail_count = ?
WHERE user_id = ?");
my $rows = $userh -> execute($failcount, $userid);
return $self -> self_error("Unable to perform user failcount update: ". $self -> {"dbh"} -> errstr) if(!$rows);
return $self -> self_error("Unable to perform user failcount update: no rows changed") if($rows eq "0E0");
return ($failcount, $self -> {"policy_max_loginfail"});
}
## @method $ force_passchange($userid)
# Determine whether the user needs to reset their password (either because they are
# using a temporary system-allocated password, or the password policy requires it).
#
# If a password expiration policy is in use, `policy_max_passwordage` should be set
# in the auth_method_params for the applicable authmethods. The parameter should contain
# the maximum age of any given password in seconds. If not set, expiration is not
# enforced.
#
# @param userid The ID of the user to check for password change requirement.
# @return 'temporary' if the user must change their password because it is a
# temporary one, 'expired' if the password has expired, the empty string if
# the password does not need to be changed, undef on error.
sub force_passchange {
my $self = shift;
my $userid = shift;
my $passh = $self -> {"dbh"} -> prepare("SELECT force_change, password_set
FROM ".$self -> {"settings"} -> {"database"} -> {"users"}."
WHERE user_id = ?");
$passh -> execute($userid)
or return $self -> self_error("Unable to perform passchange check: ". $self -> {"dbh"} -> errstr);
my $pass_data = $passh -> fetchrow_hashref()
or return ''; # Unknown user? Can't change the password even if we'd like to.
# Check for password expiration based on policy settings
my $age = time() - ($pass_data -> {"password_set"} || 0); # Handle NULL password_set's sanely
return 'expired' if($self -> {"policy_max_passwordage"} && ($age > $self -> {"policy_max_passwordage"}));
# Check for temporary passwords
return 'temporary' if($pass_data -> {"force_change"});
# Otherwise, no need to change the password
return '';
}
# ============================================================================ # ============================================================================
# Ghastly internals # Ghastly internals

38
Webperl/AuthMethod/LDAPS.pm
View File

@ -21,21 +21,21 @@
# users to be authenticated against most LDAPS servers, provided that # users to be authenticated against most LDAPS servers, provided that
# it is configured with the appropriate incantations to talk to it. # it is configured with the appropriate incantations to talk to it.
# #
# This module will expect at least the following configuration values # This module supports the following comfiguration variables:
# to be passed to the constructor.
# #
# * server - the server to authenticate the user against, can be either # - `server` (required) the server to authenticate the user against, can be either
# a hostname, IP address, or URI. # a hostname, IP address, or URI.
# * base - the base dn to use when searching for the user's dn. # - `base` (required) the base dn to use when searching for the user's dn.
# * searchfield - the field to use when searching for the user dn. # - `searchfield` (required) the field to use when searching for the user dn.
# - `adminuser` (optional) if specified, searching for the user's DN will be done
# using this user rather than anonymously.
# - `adminpass` (optional) The password to use when logging in as the admin user.
# - `reuseconn` (optional) If set to a true value, the connection to the LDAPS is reused
# for authentication after finding the user's dn.
# #
# The following arguments may be provided: # These will generally be provided by supplying the configuration variables
# # in the auth_methods_params table and using Webperl::AuthMethods to load
# * adminuser - if specified, searching for the user's DN will be done # the AuthMethod at runtime.
# using this user rather than anonymously.
# * adminpass - The password to use when logging in as the admin user.
# * reuseconn - If set to a true value, the connection to the LDAPS is reused
# for authentication after finding the user's dn.
package Webperl::AuthMethod::LDAPS; package Webperl::AuthMethod::LDAPS;
use strict; use strict;
@ -53,15 +53,13 @@ use Net::LDAPS;
sub new { sub new {
my $invocant = shift; my $invocant = shift;
my $class = ref($invocant) || $invocant; my $class = ref($invocant) || $invocant;
my $self = $class -> SUPER::new(@_); my $self = $class -> SUPER::new(@_)
or return undef;
# bomb if the parent constructor failed.
return $class -> SUPER::get_error() if(!$self);
# check that required settings are set... # check that required settings are set...
return "Webperl::AuthMethod::LDAPS missing 'server' argument in new()" if(!$self -> {"server"}); return set_error("Webperl::AuthMethod::LDAPS missing 'server' argument in new()") if(!$self -> {"server"});
return "Webperl::AuthMethod::LDAPS missing 'base' argument in new()" if(!$self -> {"base"}); return set_error("Webperl::AuthMethod::LDAPS missing 'base' argument in new()") if(!$self -> {"base"});
return "Webperl::AuthMethod::LDAPS missing 'searchfield' argument in new()" if(!$self -> {"searchfield"}); return set_error("Webperl::AuthMethod::LDAPS missing 'searchfield' argument in new()") if(!$self -> {"searchfield"});
return $self; return $self;
} }

34
Webperl/AuthMethod/SSH.pm
View File

@ -22,18 +22,18 @@
# this module involves potentially significant delays in authentication # this module involves potentially significant delays in authentication
# as a result of its reliance on Net::SSH::Expect. # as a result of its reliance on Net::SSH::Expect.
# #
# This module expects at least the following configuration values # This module supports the following comfiguration variables:
# to be passed to the constructor.
# #
# * server - the server to authenticate the user against, can be either # - `server` (required) the server to authenticate the user against, can be either
# a hostname or ip address. # a hostname or ip address.
# - `timeout` (optional) the conection timeout in seconds. This defaults to 5 if not
# specified (values less than 5 are only recommended on fast
# networks and when talking to servers that respond rapidly).
# - `binary` (optional) the location of the ssh binary. Defaults to `/usr/bin/ssh`.
# #
# The following configuration options may also be supplied: # These will generally be provided by supplying the configuration variables
# # in the auth_methods_params table and using Webperl::AuthMethods to load
# * timeout - the conection timeout in seconds. This defaults to 5 if not # the AuthMethod at runtime.
# specified (values less than 5 are only recommended on fast
# networks and when talking to servers that respond rapidly).
# * binary - the location of the ssh binary. Defaults to /usr/bin/ssh.
package Webperl::AuthMethod::SSH; package Webperl::AuthMethod::SSH;
use strict; use strict;
@ -55,13 +55,12 @@ use Utils qw(blind_untaint);
sub new { sub new {
my $invocant = shift; my $invocant = shift;
my $class = ref($invocant) || $invocant; my $class = ref($invocant) || $invocant;
my $self = $class -> SUPER::new(@_); my $self = $class -> SUPER::new(@_)
or return undef;
# bomb if the parent constructor failed.
return $class -> SUPER::get_error() if(!$self);
# check that required settings are set... # check that required settings are set...
return "Webperl::AuthMethod::SSH missing 'server' argument in new()" if(!$self -> {"server"}); return set_error("Webperl::AuthMethod::SSH missing 'server' argument in new()")
if(!$self -> {"server"});
# Check whether the timeout and binary settings are, well, set... # Check whether the timeout and binary settings are, well, set...
$self -> {"timeout"} = 5 unless(defined($self -> {"timeout"})); $self -> {"timeout"} = 5 unless(defined($self -> {"timeout"}));
@ -95,6 +94,9 @@ sub authenticate {
my $resp; my $resp;
eval { eval {
# FIXME: This is really godawful ghastly nasty shit that should not exist upon
# the living Earth, but if this is run in tainted mode perl will freak out.
# Fix this by untainting more safely!
my $ssh = Net::SSH::Expect -> new(host => blind_untaint($self -> {"server"}), my $ssh = Net::SSH::Expect -> new(host => blind_untaint($self -> {"server"}),
user => blind_untaint($username), user => blind_untaint($username),
password => blind_untaint($password), password => blind_untaint($password),
@ -119,7 +121,7 @@ sub authenticate {
return 0; return 0;
} }
return $auth -> self_error("SSH login failed: username and password are required."); return $auth -> self_error("SSL Login failed: Username and password are required.");
} }
1; 1;