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