SL/Auth/PasswordPolicy.pm

   1 package SL::Auth::PasswordPolicy;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use constant OK                   =>  0;
   8 use constant TOO_SHORT            =>  1;
   9 use constant TOO_LONG             =>  2;
  10 use constant MISSING_LOWERCASE    =>  4;
  11 use constant MISSING_UPPERCASE    =>  8;
  12 use constant MISSING_DIGIT        => 16;
  13 use constant MISSING_SPECIAL_CHAR => 32;
  14 use constant INVALID_CHAR         => 64;
  15
  16 use Rose::Object::MakeMethods::Generic
  17 (
  18  'scalar --get_set_init' => 'config',
  19 );
  20
  21 sub verify {
  22   my ($self, $password, $is_admin) = @_;
  23
  24   my $cfg = $self->config;
  25   return OK() unless $cfg && %{ $cfg };
  26   return OK() if $is_admin && $cfg->{disable_policy_for_admin};
  27
  28   my $result = OK();
  29   $result |= TOO_SHORT()            if $cfg->{min_length}                && (length($password) < $cfg->{min_length});
  30   $result |= TOO_LONG()             if $cfg->{max_length}                && (length($password) > $cfg->{max_length});
  31   $result |= MISSING_LOWERCASE()    if $cfg->{require_lowercase}         && $password !~ m/[a-z]/;
  32   $result |= MISSING_UPPERCASE()    if $cfg->{require_uppercase}         && $password !~ m/[A-Z]/;
  33   $result |= MISSING_DIGIT()        if $cfg->{require_digit}             && $password !~ m/[0-9]/;
  34   $result |= MISSING_SPECIAL_CHAR() if $cfg->{require_special_character} && $password !~ $cfg->{special_characters_re};
  35   $result |= INVALID_CHAR()         if $cfg->{invalid_characters_re}     && $password =~ $cfg->{invalid_characters_re};
  36
  37   return $result;
  38 }
  39
  40 sub errors {
  41   my ($self, $result) = @_;
  42
  43   my @errors;
  44
  45   push @errors, $::locale->text('The password is too short (minimum length: #1).', $self->config->{min_length}) if $result & TOO_SHORT();
  46   push @errors, $::locale->text('The password is too long (maximum length: #1).',  $self->config->{max_length}) if $result & TOO_LONG();
  47   push @errors, $::locale->text('A lower-case character is required.')                                          if $result & MISSING_LOWERCASE();
  48   push @errors, $::locale->text('An upper-case character is required.')                                         if $result & MISSING_UPPERCASE();
  49   push @errors, $::locale->text('A digit is required.')                                                         if $result & MISSING_DIGIT();
  50
  51   if ($result & MISSING_SPECIAL_CHAR()) {
  52     my $char_list = join ' ', sort split(m//, $self->config->{special_characters});
  53     push @errors, $::locale->text('A special character is required (valid characters: #1).', $char_list);
  54   }
  55
  56   if (($result & INVALID_CHAR())) {
  57     my $char_list = join ' ', sort split(m//, $self->config->{ $self->config->{invalid_characters} ? 'invalid_characters' : 'valid_characters' });
  58     push @errors, $::locale->text('An invalid character was used (invalid characters: #1).', $char_list) if $self->config->{invalid_characters};
  59     push @errors, $::locale->text('An invalid character was used (valid characters: #1).',   $char_list) if $self->config->{valid_characters};
  60   }
  61
  62   return @errors;
  63 }
  64
  65
  66 sub init_config {
  67   my ($self) = @_;
  68
  69   my %cfg = %{ $::emmvee_conf{password_policy} || {} };
  70
  71   $cfg{valid_characters}      =~ s/[ \n\r]//g if $cfg{valid_characters};
  72   $cfg{invalid_characters}    =~ s/[ \n\r]//g if $cfg{invalid_characters};
  73   $cfg{invalid_characters_re} =  '[^' . quotemeta($cfg{valid_characters})   . ']' if $cfg{valid_characters};
  74   $cfg{invalid_characters_re} =  '['  . quotemeta($cfg{invalid_characters}) . ']' if $cfg{invalid_characters};
  75   $cfg{special_characters}    =  '!@#$%^&*()_+=[]{}<>\'"|\\,;.:?-';
  76   $cfg{special_characters_re} =  '[' . quotemeta($cfg{special_characters}) . ']';
  77   print $cfg{special_characters_re}, "\n";
  78
  79   map { $cfg{"require_${_}"} = $cfg{"require_${_}"} =~ m/^(?:1|true|t|yes|y)$/i } qw(lowercase uppercase digit special_char);
  80
  81   $self->config(\%cfg);
  82 }
  83
  84 1;
  85 __END__
  86
  87 =pod
  88
  89 =encoding utf8
  90
  91 =head1 NAME
  92
  93 SL::Auth::PasswordPolicy - Verify a given password against the policy
  94 set in the configuration file
  95
  96 =head1 SYNOPSIS
  97
  98  my $verifier = SL::Auth::PasswordPolicy->new;
  99  my $result   = $verifier->verify($password);
 100  if ($result != SL::Auth::PasswordPolicy->OK()) {
 101    print "Errors: " . join(' ', $verifier->errors($result)) . "\n";
 102  }
 103
 104 =head1 CONSTANTS
 105
 106 =over 4
 107
 108 =item C<OK>
 109
 110 Password is OK.
 111
 112 =item C<TOO_SHORT>
 113
 114 The password is too short.
 115
 116 =item C<TOO_LONG>
 117
 118 The password is too long.
 119
 120 =item C<MISSING_LOWERCASE>
 121
 122 The password is missing a lower-case character.
 123
 124 =item C<MISSING_UPPERCASE>
 125
 126 The password is missing an upper-case character.
 127
 128 =item C<MISSING_DIGIT>
 129
 130 The password is missing a digit.
 131
 132 =item C<MISSING_SPECIAL_CHAR>
 133
 134 The password is missing a special character. Special characters are
 135 the following: ! " # $ % & ' ( ) * + , - . : ; E<lt> = E<gt> ? @ [ \ ]
 136 ^ _ { | }
 137
 138 =item C<INVALID_CHAR>
 139
 140 The password contains an invalid character.
 141
 142 =back
 143
 144 =head1 FUNCTIONS
 145
 146 =over 4
 147
 148 =item C<verify $password, $is_admin>
 149
 150 Checks whether or not the password matches the policy. Returns C<OK()>
 151 if it does and an error code otherwise (binary or'ed of the error
 152 constants).
 153
 154 If C<$is_admin> is trueish and the configuration specifies that the
 155 policy checks are disabled for the administrator then C<verify> will
 156 always return C<OK()>.
 157
 158 =item C<errors $code>
 159
 160 Returns an array of human-readable strings describing the issues set
 161 in C<$code> which should be the result of L</verify>.
 162
 163 =back
 164
 165 =head1 BUGS
 166
 167 Nothing here yet.
 168
 169 =head1 AUTHOR
 170
 171 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 172
 173 =cut