password validation base implementation

diff --git a/site/cgi-bin/modules/BSE/Util/PasswordValidate.pm b/site/cgi-bin/modules/BSE/Util/PasswordValidate.pm
new file mode 100644 (file)
index 0000000..6c4f340
--- /dev/null
+++ b/site/cgi-bin/modules/BSE/Util/PasswordValidate.pm
@@ -0,0 +1,263 @@
+package BSE::Util::PasswordValidate;
+use strict;
+use Carp qw(confess);
+use Scalar::Util qw(reftype);
+
+our $VERSION = "1.000";
+
+=head1 NAME
+
+BSE::PasswordValidate - validate password strength as configured
+
+=head1 SYNOPSIS
+
+  use BSE::PasswordValidate;
+  unless (BSE::PasswordValidate->validate
+    (
+    password => $password,
+    username => $username,
+    rules => $rules,
+    other => $other)) {
+    # fail
+  }
+
+=head1 DESCRIPTION
+
+Validate a user supplied password.
+
+=over
+
+=item validate(password => $password, username => $name, other => $other, rules => $rules, errors =>\@errors)
+
+C<$password> is the password to validate.
+
+C<$rules> is a hashref of rules to check.  Possible keys are:
+
+C<$name> is the user name to match against (C<notuser> and C<notu5er>
+validation.)
+
+C<$other> is other fields to match the password agains (currently
+unused).
+
+=over
+
+=item *
+
+C<length> - the minimum length for passwords
+
+=item *
+
+C<entropy> - the minimum entropy as measured by Data::Password::Entropy
+
+=item *
+
+C<symbols> - non-alphanumerics/spaces are required
+
+=item *
+
+C<digits> - digits are required.
+
+=item *
+
+C<mixedcase> - both upper and lower case are required.
+
+=item *
+
+C<categories> - number of character categories out of 5 required out
+of symbols, digits, upper case, lower case and extended ASCII/Unicode
+characters.
+
+=item *
+
+C<notuser> - the password may not match the user name case-insensitively.
+
+=item *
+
+C<notu5ser> - the password may not match the user name
+case-insensitively, even with symbol replacement (e.g. "5" for "S".
+
+=back
+
+=cut
+
+sub validate {
+  my ($class, %opts) = @_;
+
+  my $self = bless \%opts, $class;
+
+  $opts{password} =~ s/\A\s+//;
+  $opts{password} =~ s/\s+\z//;
+
+  defined $opts{password}
+    or confess "Missing password parameter";
+  exists $opts{username}
+    or confess "Missing username paramater";
+  ref $opts{rules} && reftype $opts{rules} eq "HASH"
+    or confess "Missing or invalid rules parameter";
+  ref $opts{errors} && reftype $opts{errors} eq "ARRAY"
+    or confess "Missing or invalid errors parameter";
+  ref $opts{other} && reftype $opts{other} eq "HASH"
+    or confess "Missing or invalid other parameter";
+  
+  my $good = 1;
+  for my $rule (keys %{$opts{rules}}) {
+    my $method = "_validate_$rule";
+    unless ($self->can($method)) {
+      confess "Unknown rule $rule\n";
+    }
+    if ($opts{rules}{$rule} && !$self->$method($opts{rules}{$rule})) {
+      $good = 0;
+    }
+  }
+
+  unless ($good) {
+    @{$self->{errors}} = sort
+      {
+       ( ref $a ? $a->[0] : $a )
+         cmp
+           ( ref $b ? $b->[0] : $b )
+      } @{$self->{errors}};
+  }
+
+  return $good;
+}
+
+sub _validate_length {
+  my ($self, $length) = @_;
+
+  if (length($self->{password}) < $length) {
+    push @{$self->{errors}}, join ":", "msg:bse/util/password/length",
+                              length $self->{password}, $length;
+    return;
+  }
+
+  return 1;
+}
+
+sub _validate_entropy {
+  my ($self, $entropy) = @_;
+
+  require Data::Password::Entropy;
+  Data::Password::Entropy->import();
+  my $found_entropy = password_entropy($self->{password});
+  if ($found_entropy < $entropy) {
+    push @{$self->{errors}}, join ":", "msg:bse/util/password/entropy",
+                              $found_entropy, $entropy, $found_entropy/$entropy * 100;
+    return;
+  }
+
+  return 1;
+}
+
+sub _validate_symbols {
+  my ($self) = @_;
+
+  unless ($self->{password} =~ /\W/) {
+    push @{$self->{errors}}, "msg:bse/util/password/symbols";
+    return;
+  }
+
+  return 1;
+}
+
+sub _validate_digits {
+  my ($self) = @_;
+
+  unless ($self->{password} =~ /\d/) {
+    push @{$self->{errors}}, "msg:bse/util/password/digits";
+    return;
+  }
+
+  return 1;
+}
+
+sub _validate_mixedcase {
+  my ($self) = @_;
+
+  unless ($self->{password} =~ /\p{Ll}/
+         && $self->{password} =~ /\p{Lu}/) {
+    push @{$self->{errors}}, "msg:bse/util/password/mixedcase";
+    return;
+  }
+
+  return 1;
+}
+
+sub _validate_categories {
+  my ($self, $count) = @_;
+
+  my $found_count = 0;
+  for ($self->{password}) {
+    $found_count++ if /\p{Ll}/;
+    $found_count++ if /\p{Lu}/;
+    $found_count++ if /\pN/;
+    $found_count++ if /[^\pL\pN]/;
+    $found_count++ if /[^\x00-\x9F]/;
+  }
+
+  if ($found_count < $count) {
+    push @{$self->{errors}},
+      join ":", "msg:bse/util/password/categories", $found_count, $count;
+    return;
+  }
+
+  return 1;
+}
+
+sub _validate_notuser {
+  my ($self) = @_;
+
+  if ($self->{username} =~ /\Q$self->{password}/i
+     || $self->{password} =~ /\Q$self->{username}/i) {
+    push @{$self->{errors}}, "msg:bse/util/password/notuser";
+    return;
+  }
+
+  return 1;
+}
+
+my @u5er_sets = 
+  (
+   [ qw(a 4 @) ],
+   [ qw(b 8) ],
+   [ qw(e 3) ],
+   [ qw(g 6) ],
+   [ qw(i l 1) ],
+   [ qw(o 0) ],
+   [ qw(q 9) ],
+   [ qw(s 5 $) ],
+   [ qw(t 7) ],
+   [ qw(z 2) ],
+  );
+
+my %u5er_map;
+{
+  for my $set (@u5er_sets) {
+    for my $entry (@$set) {
+      $u5er_map{$entry} = "[" . join("", @$set) . "]";
+    }
+  }
+}
+
+sub _validate_notu5er {
+  my ($self) = @_;
+
+  (my $work_pw = $self->{password}) =~
+    s/(.)/$u5er_map{lc $1} || quotemeta $1/ige;
+  (my $work_user = quotemeta $self->{username}) =~
+    s/(.)/$u5er_map{lc $1} || quotemeta $1/ige;
+
+  if ($self->{username} =~ qr/$work_pw/i
+      || $self->{password} =~ qr/$work_user/i) {
+    push @{$self->{errors}}, "msg:bse/util/password/notu5er";
+    return;
+  }
+
+  return 1;
+}
+
+=back
+
+=cut
+
+1;

diff --git a/t/010-modules/100-password-validate.t b/t/010-modules/100-password-validate.t
new file mode 100644 (file)
index 0000000..ef7ef0f
--- /dev/null
+++ b/t/010-modules/100-password-validate.t
@@ -0,0 +1,280 @@
+#!perl -w
+use strict;
+use Test::More;
+use BSE::Util::PasswordValidate;
+use Data::Dumper;
+
+my @tests =
+   (
+    {
+     name => "simple pass",
+     args =>
+     {
+      password => "test",
+      rules => {},
+     },
+    },
+    {
+     name => "length fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       length => 5,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/length:4:5"
+     ],
+    },
+    {
+     name => "entropy fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       entropy => 80,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/entropy:16:80:20"
+     ],
+    },
+    # symbols
+    {
+     name => "symbols fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       symbols => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/symbols",
+     ],
+    },
+    {
+     name => "symbols success",
+     result => 1,
+     args =>
+     {
+      password => "alpha&beta",
+      rules =>
+      {
+       symbols => 1,
+      },
+     },
+    },
+
+    # digits
+    {
+     name => "digits fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       digits => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/digits",
+     ],
+    },
+    {
+     name => "digits success",
+     result => 1,
+     args =>
+     {
+      password => "alpha5beta",
+      rules =>
+      {
+       digits => 1,
+      },
+     },
+    },
+
+    # mixedcase
+    {
+     name => "mixedcase fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       mixedcase => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/mixedcase",
+     ],
+    },
+    {
+     name => "mixedcase success",
+     result => 1,
+     args =>
+     {
+      password => "Test",
+      rules =>
+      {
+       mixedcase => 1,
+      },
+     },
+    },
+
+    # categories
+    {
+     name => "categories fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       categories => 3,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/categories:1:3"
+     ],
+    },
+    {
+     name => "categories success",
+     result => 1,
+     args =>
+     {
+      password => "Test1",
+      rules =>
+      {
+       categories => 3,
+      },
+     },
+    },
+
+    # notuser
+    {
+     name => "notuser fail",
+     result => 0,
+     args =>
+     {
+      password => "test",
+      rules =>
+      {
+       notuser => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/notuser",
+     ],
+    },
+    {
+     name => "notuser fail (case)",
+     result => 0,
+     args =>
+     {
+      password => "TEST",
+      rules =>
+      {
+       notuser => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/notuser",
+     ],
+    },
+    {
+     name => "notuser success",
+     result => 1,
+     args =>
+     {
+      password => "abcd",
+      rules =>
+      {
+       notuser => 1,
+      },
+     },
+    },
+
+    # notu5er
+    {
+     name => "notu5er fail",
+     result => 0,
+     args =>
+     {
+      password => "te5t",
+      rules =>
+      {
+       notu5er => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/notu5er",
+     ],
+    },
+    {
+     name => "notu5er fail (case)",
+     result => 0,
+     args =>
+     {
+      password => "TE5T",
+      rules =>
+      {
+       notu5er => 1,
+      },
+     },
+     errors =>
+     [
+      "msg:bse/util/password/notu5er",
+     ],
+    },
+    {
+     name => "notu5er success",
+     result => 1,
+     args =>
+     {
+      password => "abcd",
+      rules =>
+      {
+       notu5er => 1,
+      },
+     },
+    },
+   );
+
+plan tests => 2 * @tests;
+
+for my $test (@tests) {
+  $test->{args}{other} ||= {};
+  $test->{args}{username} ||= "testuser";
+  exists $test->{result} or $test->{result} = 1;
+  $test->{errors} ||= [];
+  my $name = $test->{name};
+  my @errors;
+  my $result = BSE::Util::PasswordValidate->validate
+    (
+     %{$test->{args}},
+     errors => \@errors,
+    );
+  note("$name => $result");
+  note(Dumper(\@errors));
+  ok($test->{result} ? $result : !$result, "$name: result");
+  is_deeply(\@errors, $test->{errors}, "$name: check error messages");
+}

diff --git a/t/t000load.t b/t/t000load.t
index 398d5e7a6caed61094211ef5d6558fc9511ab807..77fb8832691610896e738dd37f48e41173a522a8 100644 (file)
--- a/t/t000load.t
+++ b/t/t000load.t
@@ -1,9 +1,10 @@
 #!perl -w
 use strict;
-use Test::More tests => 31;
+use Test::More tests => 32;
 use_ok("BSE::Cfg");
 use_ok("Squirrel::Template");
 use_ok("BSE::Template");
+use_ok("BSE::Util::PasswordValidate");
 use_ok("DevHelp::Date");
 use_ok("DevHelp::Formatter");
 use_ok("DevHelp::HTML");