Filename | /usr/local/libexec/sympa/Sympa/User.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | AUTOLOAD | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@241 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@254 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@30 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@32 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@33 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@34 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@36 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@37 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@38 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@39 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@40 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@41 | Sympa::User::
0 | 0 | 0 | 0s | 0s | BEGIN@42 | Sympa::User::
0 | 0 | 0 | 0s | 0s | CORE:match (opcode) | Sympa::User::
0 | 0 | 0 | 0s | 0s | DESTROY | Sympa::User::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Sympa::User::
0 | 0 | 0 | 0s | 0s | __ANON__[:251] | Sympa::User::
0 | 0 | 0 | 0s | 0s | __ANON__[:264] | Sympa::User::
0 | 0 | 0 | 0s | 0s | __ANON__[:321] | Sympa::User::
0 | 0 | 0 | 0s | 0s | __ANON__[:354] | Sympa::User::
0 | 0 | 0 | 0s | 0s | add_global_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | clean_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | clean_users | Sympa::User::
0 | 0 | 0 | 0s | 0s | delete_global_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | expire | Sympa::User::
0 | 0 | 0 | 0s | 0s | get_all_global_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | get_global_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | get_id | Sympa::User::
0 | 0 | 0 | 0s | 0s | get_users | Sympa::User::
0 | 0 | 0 | 0s | 0s | hash_type | Sympa::User::
0 | 0 | 0 | 0s | 0s | is_global_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | moveto | Sympa::User::
0 | 0 | 0 | 0s | 0s | new | Sympa::User::
0 | 0 | 0 | 0s | 0s | password_fingerprint | Sympa::User::
0 | 0 | 0 | 0s | 0s | save | Sympa::User::
0 | 0 | 0 | 0s | 0s | update_global_user | Sympa::User::
0 | 0 | 0 | 0s | 0s | update_password_hash | Sympa::User::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # -*- indent-tabs-mode: nil; -*- | ||||
2 | # vim:ft=perl:et:sw=4 | ||||
3 | # $Id$ | ||||
4 | |||||
5 | # Sympa - SYsteme de Multi-Postage Automatique | ||||
6 | # | ||||
7 | # Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel | ||||
8 | # Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, | ||||
9 | # 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites | ||||
10 | # Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER | ||||
11 | # Copyright 2018 The Sympa Community. See the AUTHORS.md file at the | ||||
12 | # top-level directory of this distribution and at | ||||
13 | # <https://github.com/sympa-community/sympa.git>. | ||||
14 | # | ||||
15 | # This program is free software; you can redistribute it and/or modify | ||||
16 | # it under the terms of the GNU General Public License as published by | ||||
17 | # the Free Software Foundation; either version 2 of the License, or | ||||
18 | # (at your option) any later version. | ||||
19 | # | ||||
20 | # This program is distributed in the hope that it will be useful, | ||||
21 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||
22 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||
23 | # GNU General Public License for more details. | ||||
24 | # | ||||
25 | # You should have received a copy of the GNU General Public License | ||||
26 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||
27 | |||||
28 | package Sympa::User; | ||||
29 | |||||
30 | use strict; | ||||
31 | use warnings; | ||||
32 | use Carp qw(); | ||||
33 | use Digest::MD5; | ||||
34 | BEGIN { eval 'use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64)'; } # spent 0s executing statements in string eval | ||||
35 | |||||
36 | use Conf; | ||||
37 | use Sympa::DatabaseDescription; | ||||
38 | use Sympa::DatabaseManager; | ||||
39 | use Sympa::Language; | ||||
40 | use Sympa::Log; | ||||
41 | use Sympa::Tools::Data; | ||||
42 | use Sympa::Tools::Text; | ||||
43 | |||||
44 | my $log = Sympa::Log->instance; | ||||
45 | |||||
46 | ## Database and SQL statement handlers | ||||
47 | my ($sth, @sth_stack); | ||||
48 | |||||
49 | ## mapping between var and field names | ||||
50 | my %db_struct = Sympa::DatabaseDescription::full_db_struct(); | ||||
51 | my %map_field; | ||||
52 | foreach my $k (keys %{$db_struct{'user_table'}->{'fields'}}) { | ||||
53 | if ($k =~ /^(.+)_user$/) { | ||||
54 | $map_field{$1} = $k; | ||||
55 | } | ||||
56 | } | ||||
57 | |||||
58 | ## DB fields with numeric type | ||||
59 | ## We should not do quote() for these while inserting data | ||||
60 | my %numeric_field; | ||||
61 | foreach my $k (keys %{$db_struct{'user_table'}->{'fields'}}) { | ||||
62 | if ($db_struct{'user_table'}->{'fields'}{$k}{'struct'} =~ /^int/) { | ||||
63 | $numeric_field{$k} = 1; | ||||
64 | } | ||||
65 | } | ||||
66 | |||||
67 | =encoding utf-8 | ||||
68 | |||||
69 | =head1 NAME | ||||
70 | |||||
71 | Sympa::User - All Users Identified by Sympa | ||||
72 | |||||
73 | =head1 DESCRIPTION | ||||
74 | |||||
75 | =head2 CONSTRUCTOR | ||||
76 | |||||
77 | =over 4 | ||||
78 | |||||
79 | =item new ( EMAIL, [ KEY => VAL, ... ] ) | ||||
80 | |||||
81 | Create new Sympa::User object. | ||||
82 | |||||
83 | =back | ||||
84 | |||||
85 | =cut | ||||
86 | |||||
87 | sub new { | ||||
88 | my $pkg = shift; | ||||
89 | my $who = Sympa::Tools::Text::canonic_email(shift); | ||||
90 | my %values = @_; | ||||
91 | my $self; | ||||
92 | return undef unless defined $who; | ||||
93 | |||||
94 | ## Canonicalize lang if possible | ||||
95 | $values{'lang'} = Sympa::Language::canonic_lang($values{'lang'}) | ||||
96 | || $values{'lang'} | ||||
97 | if $values{'lang'}; | ||||
98 | |||||
99 | if (!($self = get_global_user($who))) { | ||||
100 | ## unauthenticated user would not be added to database. | ||||
101 | $values{'email'} = $who; | ||||
102 | if (scalar grep { $_ ne 'lang' and $_ ne 'email' } keys %values) { | ||||
103 | unless (defined add_global_user(\%values)) { | ||||
104 | return undef; | ||||
105 | } | ||||
106 | } | ||||
107 | $self = \%values; | ||||
108 | } | ||||
109 | |||||
110 | bless $self => $pkg; | ||||
111 | } | ||||
112 | |||||
113 | =head2 METHODS | ||||
114 | |||||
115 | =over 4 | ||||
116 | |||||
117 | =item expire | ||||
118 | |||||
119 | Remove user information from user_table. | ||||
120 | |||||
121 | =back | ||||
122 | |||||
123 | =cut | ||||
124 | |||||
125 | sub expire { | ||||
126 | delete_global_user(shift->email); | ||||
127 | } | ||||
128 | |||||
129 | =over 4 | ||||
130 | |||||
131 | =item get_id | ||||
132 | |||||
133 | Get unique identifier of object. | ||||
134 | |||||
135 | =back | ||||
136 | |||||
137 | =cut | ||||
138 | |||||
139 | sub get_id { | ||||
140 | ## DO NOT use accessors since $self may not have been fully initialized. | ||||
141 | shift->{'email'} || ''; | ||||
142 | } | ||||
143 | |||||
144 | =over 4 | ||||
145 | |||||
146 | =item moveto | ||||
147 | |||||
148 | Change email of user. | ||||
149 | |||||
150 | =back | ||||
151 | |||||
152 | =cut | ||||
153 | |||||
154 | sub moveto { | ||||
155 | my $self = shift; | ||||
156 | my $newemail = Sympa::Tools::Text::canonic_email(shift); | ||||
157 | |||||
158 | unless (defined $newemail) { | ||||
159 | $log->syslog('err', 'No email'); | ||||
160 | return undef; | ||||
161 | } | ||||
162 | if ($self->email eq $newemail) { | ||||
163 | return 0; | ||||
164 | } | ||||
165 | |||||
166 | push @sth_stack, $sth; | ||||
167 | my $sdm = Sympa::DatabaseManager->instance; | ||||
168 | |||||
169 | unless ( | ||||
170 | $sdm | ||||
171 | and $sth = $sdm->do_prepared_query( | ||||
172 | q{UPDATE user_table | ||||
173 | SET email_user = ? | ||||
174 | WHERE email_user = ?}, | ||||
175 | $newemail, $self->email | ||||
176 | ) | ||||
177 | ) { | ||||
178 | $log->syslog('err', 'Can\'t move user %s to %s', $self, $newemail); | ||||
179 | $sth = pop @sth_stack; | ||||
180 | return undef; | ||||
181 | } | ||||
182 | |||||
183 | $sth = pop @sth_stack; | ||||
184 | |||||
185 | $self->{'email'} = $newemail; | ||||
186 | |||||
187 | return 1; | ||||
188 | } | ||||
189 | |||||
190 | =over 4 | ||||
191 | |||||
192 | =item save | ||||
193 | |||||
194 | Save user information to user_table. | ||||
195 | |||||
196 | =back | ||||
197 | |||||
198 | =cut | ||||
199 | |||||
200 | sub save { | ||||
201 | my $self = shift; | ||||
202 | unless (add_global_user('email' => $self->email, %$self) | ||||
203 | or update_global_user($self->email, %$self)) { | ||||
204 | $log->syslog('err', 'Cannot save user %s', $self); | ||||
205 | return undef; | ||||
206 | } | ||||
207 | |||||
208 | return 1; | ||||
209 | } | ||||
210 | |||||
211 | =head3 ACCESSORS | ||||
212 | |||||
213 | =over 4 | ||||
214 | |||||
215 | =item E<lt>attributeE<gt> | ||||
216 | |||||
217 | =item E<lt>attributeE<gt>C<( VALUE )> | ||||
218 | |||||
219 | I<Getters/Setters>. | ||||
220 | Get or set user attributes. | ||||
221 | For example C<$user-E<gt>gecos> returns "gecos" parameter of the user, | ||||
222 | and C<$user-E<gt>gecos("foo")> also changes it. | ||||
223 | Basic user profile "email" have only getter, | ||||
224 | so it is read-only. | ||||
225 | |||||
226 | =back | ||||
227 | |||||
228 | =cut | ||||
229 | |||||
230 | our $AUTOLOAD; | ||||
231 | |||||
232 | sub DESTROY { } # "sub DESTROY;" may cause segfault with Perl around 5.10.1. | ||||
233 | |||||
234 | sub AUTOLOAD { | ||||
235 | $AUTOLOAD =~ m/^(.*)::(.*)/; | ||||
236 | |||||
237 | my $attr = $2; | ||||
238 | |||||
239 | if (scalar grep { $_ eq $attr } qw(email)) { | ||||
240 | ## getter for user attribute. | ||||
241 | no strict "refs"; | ||||
242 | *{$AUTOLOAD} = sub { | ||||
243 | my $self = shift; | ||||
244 | Carp::croak "Can't call method \"$attr\" on uninitialized " | ||||
245 | . ref($self) | ||||
246 | . " object" | ||||
247 | unless $self->{'email'}; | ||||
248 | Carp::croak "Can't modify \"$attr\" attribute" | ||||
249 | if scalar @_ > 1; | ||||
250 | $self->{$attr}; | ||||
251 | }; | ||||
252 | } elsif (exists $map_field{$attr}) { | ||||
253 | ## getter/setter for user attributes. | ||||
254 | no strict "refs"; | ||||
255 | *{$AUTOLOAD} = sub { | ||||
256 | my $self = shift; | ||||
257 | Carp::croak "Can't call method \"$attr\" on uninitialized " | ||||
258 | . ref($self) | ||||
259 | . " object" | ||||
260 | unless $self->{'email'}; | ||||
261 | $self->{$attr} = shift | ||||
262 | if scalar @_ > 1; | ||||
263 | $self->{$attr}; | ||||
264 | }; | ||||
265 | } else { | ||||
266 | Carp::croak "Can't locate object method \"$2\" via package \"$1\""; | ||||
267 | } | ||||
268 | goto &$AUTOLOAD; | ||||
269 | } | ||||
270 | |||||
271 | =head2 FUNCTIONS | ||||
272 | |||||
273 | =over 4 | ||||
274 | |||||
275 | =item get_users ( ... ) | ||||
276 | |||||
277 | Not yet implemented. | ||||
278 | |||||
279 | =back | ||||
280 | |||||
281 | =cut | ||||
282 | |||||
283 | sub get_users { | ||||
284 | die; | ||||
285 | } | ||||
286 | |||||
287 | =over 4 | ||||
288 | |||||
289 | =item password_fingerprint ( ) | ||||
290 | |||||
291 | Returns the password finger print. | ||||
292 | |||||
293 | =back | ||||
294 | |||||
295 | =cut | ||||
296 | |||||
297 | # Old name: Sympa::Auth::password_fingerprint(). | ||||
298 | # | ||||
299 | # Password fingerprint functions are stored in a table. Currently supported | ||||
300 | # algorithms are the default 'md5', and 'bcrypt'. | ||||
301 | # | ||||
302 | # If the algorithm uses a salt (e.g. bcrypt) and the second parameter $salt | ||||
303 | # is not provided, a random one will be generated. | ||||
304 | # | ||||
305 | |||||
306 | my %fingerprint_hashes = ( | ||||
307 | # default is to use MD5, which does not use a salt | ||||
308 | 'md5' => sub { | ||||
309 | my ($pwd, $salt) = @_; | ||||
310 | |||||
311 | $salt = '' unless defined $salt; | ||||
312 | |||||
313 | # salt parameter is not used for MD5 hashes | ||||
314 | my $fingerprint = Digest::MD5::md5_hex($pwd); | ||||
315 | my $match = ($fingerprint eq $salt) ? "yes" : "no"; | ||||
316 | |||||
317 | $log->syslog('debug', 'md5: match %s salt \"%s\" fingerprint %s', | ||||
318 | $match, $salt, $fingerprint); | ||||
319 | |||||
320 | return $fingerprint; | ||||
321 | }, | ||||
322 | # bcrypt uses a salt and has a configurable "cost" parameter | ||||
323 | 'bcrypt' => sub { | ||||
324 | my ($pwd, $salt) = @_; | ||||
325 | |||||
326 | die "bcrypt support unavailable: install Crypt::Eksblowfish::Bcrypt" | ||||
327 | unless $Crypt::Eksblowfish::Bcrypt::VERSION; | ||||
328 | |||||
329 | # A bcrypt-encrypted password contains the settings at the front. | ||||
330 | # If this not look like a settings string, create one. | ||||
331 | unless (defined($salt) | ||||
332 | && $salt =~ m#\A\$2(a?)\$([0-9]{2})\$([./A-Za-z0-9]{22})#x) { | ||||
333 | my $bcrypt_cost = Conf::get_robot_conf('*', 'bcrypt_cost'); | ||||
334 | my $cost = sprintf("%02d", 0 + $bcrypt_cost); | ||||
335 | my $newsalt = ""; | ||||
336 | |||||
337 | for my $i (0 .. 15) { | ||||
338 | $newsalt .= chr(rand(256)); | ||||
339 | } | ||||
340 | $newsalt = '$2a$' . $cost . '$' . en_base64($newsalt); | ||||
341 | $log->syslog('debug', | ||||
342 | "bcrypt: create new salt: cost $cost \"$newsalt\""); | ||||
343 | |||||
344 | $salt = $newsalt; | ||||
345 | } | ||||
346 | |||||
347 | my $fingerprint = bcrypt($pwd, $salt); | ||||
348 | my $match = ($fingerprint eq $salt) ? "yes" : "no"; | ||||
349 | |||||
350 | $log->syslog('debug', 'bcrypt: match %s salt \"%s\" fingerprint %s', | ||||
351 | $match, $salt, $fingerprint); | ||||
352 | |||||
353 | return $fingerprint; | ||||
354 | } | ||||
355 | ); | ||||
356 | |||||
357 | sub password_fingerprint { | ||||
358 | |||||
359 | my ($pwd, $salt) = @_; | ||||
360 | |||||
361 | $log->syslog('debug', "salt \"%s\"", $salt); | ||||
362 | |||||
363 | my $password_hash = Conf::get_robot_conf('*', 'password_hash'); | ||||
364 | my $password_hash_update = | ||||
365 | Conf::get_robot_conf('*', 'password_hash_update'); | ||||
366 | |||||
367 | if (Conf::get_robot_conf('*', 'password_case') eq 'insensitive') { | ||||
368 | $pwd = lc($pwd); | ||||
369 | } | ||||
370 | |||||
371 | # If updating hashes, honor the hash type implied by $salt. This lets | ||||
372 | # the user successfully log in, after which the hash can be updated | ||||
373 | |||||
374 | if ($password_hash_update) { | ||||
375 | if (defined($salt) && defined(my $hash_type = hash_type($salt))) { | ||||
376 | $log->syslog('debug', "honoring hash_type %s", $hash_type); | ||||
377 | $password_hash = $hash_type; | ||||
378 | } | ||||
379 | } | ||||
380 | |||||
381 | die "password_fingerprint: unknown password_hash \"$password_hash\"" | ||||
382 | unless defined($fingerprint_hashes{$password_hash}); | ||||
383 | |||||
384 | return $fingerprint_hashes{$password_hash}->($pwd, $salt); | ||||
385 | } | ||||
386 | |||||
387 | =over 4 | ||||
388 | |||||
389 | =item hash_type ( ) | ||||
390 | |||||
391 | detect the type of password fingerprint used for a hashed password | ||||
392 | |||||
393 | Returns undef if no supported hash type is detected | ||||
394 | |||||
395 | =back | ||||
396 | |||||
397 | =cut | ||||
398 | |||||
399 | sub hash_type { | ||||
400 | my $hash = shift; | ||||
401 | |||||
402 | return 'md5' if ($hash =~ /^[a-f0-9]{32}$/i); | ||||
403 | return 'bcrypt' | ||||
404 | if ($hash =~ m#\A\$2(a?)\$([0-9]{2})\$([./A-Za-z0-9]{22})#); | ||||
405 | return undef; | ||||
406 | } | ||||
407 | |||||
408 | =over 4 | ||||
409 | |||||
410 | =item update_password_hash ( ) | ||||
411 | |||||
412 | If needed, update the hash used for the user's encrypted password entry | ||||
413 | |||||
414 | =back | ||||
415 | |||||
416 | =cut | ||||
417 | |||||
418 | sub update_password_hash { | ||||
419 | my ($user, $pwd) = @_; | ||||
420 | |||||
421 | return unless (Conf::get_robot_conf('*', 'password_hash_update')); | ||||
422 | |||||
423 | # here if configured to check and update the password hash algorithm | ||||
424 | |||||
425 | my $user_hash = hash_type($user->{'password'}); | ||||
426 | my $system_hash = Conf::get_robot_conf('*', 'password_hash'); | ||||
427 | |||||
428 | return if (defined($user_hash) && ($user_hash eq $system_hash)); | ||||
429 | |||||
430 | # note that we directly use the callback for the hash type | ||||
431 | # instead of using any other logic to determine which to call | ||||
432 | |||||
433 | $log->syslog('debug', 'update password hash for %s from %s to %s', | ||||
434 | $user->{'email'}, $user_hash, $system_hash); | ||||
435 | |||||
436 | # note that we use the cleartext password here, not the hash | ||||
437 | update_global_user($user->{'email'}, {password => $pwd}); | ||||
438 | |||||
439 | } | ||||
440 | |||||
441 | ############################################################################ | ||||
442 | ## Old-style functions | ||||
443 | ############################################################################ | ||||
444 | |||||
445 | =head2 OLD STYLE FUNCTIONS | ||||
446 | |||||
447 | =over 4 | ||||
448 | |||||
449 | =item add_global_user | ||||
450 | |||||
451 | =item delete_global_user | ||||
452 | |||||
453 | =item is_global_user | ||||
454 | |||||
455 | =item get_global_user | ||||
456 | |||||
457 | =item get_all_global_user | ||||
458 | |||||
459 | I<Obsoleted>. | ||||
460 | |||||
461 | =item update_global_user | ||||
462 | |||||
463 | =back | ||||
464 | |||||
465 | =cut | ||||
466 | |||||
467 | ## Delete a user in the user_table | ||||
468 | sub delete_global_user { | ||||
469 | my @users = @_; | ||||
470 | |||||
471 | $log->syslog('debug2', ''); | ||||
472 | |||||
473 | return undef unless @users; | ||||
474 | |||||
475 | my $sdm = Sympa::DatabaseManager->instance; | ||||
476 | foreach my $who (@users) { | ||||
477 | $who = Sympa::Tools::Text::canonic_email($who); | ||||
478 | |||||
479 | # Update field | ||||
480 | unless ( | ||||
481 | $sdm | ||||
482 | and $sdm->do_prepared_query( | ||||
483 | q{DELETE FROM user_table WHERE email_user = ?}, $who | ||||
484 | ) | ||||
485 | ) { | ||||
486 | $log->syslog('err', 'Unable to delete user %s', $who); | ||||
487 | next; | ||||
488 | } | ||||
489 | } | ||||
490 | |||||
491 | return scalar @users; | ||||
492 | } | ||||
493 | |||||
494 | ## Returns a hash for a given user | ||||
495 | sub get_global_user { | ||||
496 | $log->syslog('debug2', '(%s)', @_); | ||||
497 | my $who = Sympa::Tools::Text::canonic_email(shift); | ||||
498 | |||||
499 | ## Additional subscriber fields | ||||
500 | my $additional = ''; | ||||
501 | if ($Conf::Conf{'db_additional_user_fields'}) { | ||||
502 | $additional = ', ' . $Conf::Conf{'db_additional_user_fields'}; | ||||
503 | } | ||||
504 | |||||
505 | push @sth_stack, $sth; | ||||
506 | my $sdm = Sympa::DatabaseManager->instance; | ||||
507 | |||||
508 | unless ( | ||||
509 | $sdm | ||||
510 | and $sth = $sdm->do_prepared_query( | ||||
511 | sprintf( | ||||
512 | q{SELECT email_user AS email, gecos_user AS gecos, | ||||
513 | password_user AS password, | ||||
514 | cookie_delay_user AS cookie_delay, lang_user AS lang, | ||||
515 | attributes_user AS attributes, data_user AS data, | ||||
516 | last_login_date_user AS last_login_date, | ||||
517 | wrong_login_count_user AS wrong_login_count, | ||||
518 | last_login_host_user AS last_login_host%s | ||||
519 | FROM user_table | ||||
520 | WHERE email_user = ?}, | ||||
521 | $additional | ||||
522 | ), | ||||
523 | $who | ||||
524 | ) | ||||
525 | ) { | ||||
526 | $log->syslog('err', 'Failed to prepare SQL query'); | ||||
527 | $sth = pop @sth_stack; | ||||
528 | return undef; | ||||
529 | } | ||||
530 | |||||
531 | my $user = $sth->fetchrow_hashref('NAME_lc'); | ||||
532 | $sth->finish(); | ||||
533 | |||||
534 | $sth = pop @sth_stack; | ||||
535 | |||||
536 | if (defined $user) { | ||||
537 | # Canonicalize lang if possible. | ||||
538 | if ($user->{'lang'}) { | ||||
539 | $user->{'lang'} = Sympa::Language::canonic_lang($user->{'lang'}) | ||||
540 | || $user->{'lang'}; | ||||
541 | } | ||||
542 | |||||
543 | ## Turn user_attributes into a hash | ||||
544 | my $attributes = $user->{'attributes'}; | ||||
545 | if (defined $attributes and length $attributes) { | ||||
546 | $user->{'attributes'} = {}; | ||||
547 | foreach my $attr (split(/__ATT_SEP__/, $attributes)) { | ||||
548 | my ($key, $value) = split(/__PAIRS_SEP__/, $attr); | ||||
549 | $user->{'attributes'}{$key} = $value; | ||||
550 | } | ||||
551 | delete $user->{'attributes'} | ||||
552 | unless scalar keys %{$user->{'attributes'}}; | ||||
553 | } else { | ||||
554 | delete $user->{'attributes'}; | ||||
555 | } | ||||
556 | ## Turn data_user into a hash | ||||
557 | if ($user->{'data'}) { | ||||
558 | my %prefs = Sympa::Tools::Data::string_2_hash($user->{'data'}); | ||||
559 | $user->{'prefs'} = \%prefs; | ||||
560 | } | ||||
561 | } | ||||
562 | |||||
563 | return $user; | ||||
564 | } | ||||
565 | |||||
566 | ## Returns an array of all users in User table hash for a given user | ||||
567 | # OBSOLETED: No longer used. | ||||
568 | sub get_all_global_user { | ||||
569 | $log->syslog('debug2', ''); | ||||
570 | |||||
571 | my @users; | ||||
572 | |||||
573 | push @sth_stack, $sth; | ||||
574 | my $sdm = Sympa::DatabaseManager->instance; | ||||
575 | |||||
576 | unless ($sdm | ||||
577 | and $sth = | ||||
578 | $sdm->do_prepared_query('SELECT email_user FROM user_table')) { | ||||
579 | $log->syslog('err', 'Unable to gather all users in DB'); | ||||
580 | $sth = pop @sth_stack; | ||||
581 | return undef; | ||||
582 | } | ||||
583 | |||||
584 | while (my $email = ($sth->fetchrow_array)[0]) { | ||||
585 | push @users, $email; | ||||
586 | } | ||||
587 | $sth->finish(); | ||||
588 | |||||
589 | $sth = pop @sth_stack; | ||||
590 | |||||
591 | return @users; | ||||
592 | } | ||||
593 | |||||
594 | ## Is the person in user table (db only) | ||||
595 | sub is_global_user { | ||||
596 | my $who = Sympa::Tools::Text::canonic_email(pop); | ||||
597 | $log->syslog('debug3', '(%s)', $who); | ||||
598 | |||||
599 | return undef unless defined $who; | ||||
600 | |||||
601 | push @sth_stack, $sth; | ||||
602 | my $sdm = Sympa::DatabaseManager->instance; | ||||
603 | |||||
604 | ## Query the Database | ||||
605 | unless ( | ||||
606 | $sdm | ||||
607 | and $sth = $sdm->do_prepared_query( | ||||
608 | q{SELECT COUNT(*) FROM user_table WHERE email_user = ?}, $who | ||||
609 | ) | ||||
610 | ) { | ||||
611 | $log->syslog('err', | ||||
612 | 'Unable to check whether user %s is in the user table'); | ||||
613 | $sth = pop @sth_stack; | ||||
614 | return undef; | ||||
615 | } | ||||
616 | |||||
617 | my $is_user = $sth->fetchrow(); | ||||
618 | $sth->finish(); | ||||
619 | |||||
620 | $sth = pop @sth_stack; | ||||
621 | |||||
622 | return $is_user; | ||||
623 | } | ||||
624 | |||||
625 | ## Sets new values for the given user in the Database | ||||
626 | sub update_global_user { | ||||
627 | $log->syslog('debug', '(%s, ...)', @_); | ||||
628 | my $who = shift; | ||||
629 | my $values = $_[0]; | ||||
630 | if (ref $values) { | ||||
631 | $values = {%$values}; | ||||
632 | } else { | ||||
633 | $values = {@_}; | ||||
634 | } | ||||
635 | |||||
636 | $who = Sympa::Tools::Text::canonic_email($who); | ||||
637 | |||||
638 | ## use hash fingerprint to store password | ||||
639 | ## hashes that use salts will randomly generate one | ||||
640 | ## avoid rehashing passwords that are already hash strings | ||||
641 | if ($values->{'password'}) { | ||||
642 | if (defined(hash_type($values->{'password'}))) { | ||||
643 | $log->syslog( | ||||
644 | 'debug', | ||||
645 | 'password is in %s format, not rehashing', | ||||
646 | hash_type($values->{'password'}) | ||||
647 | ); | ||||
648 | } else { | ||||
649 | $values->{'password'} = | ||||
650 | Sympa::User::password_fingerprint($values->{'password'}, | ||||
651 | undef); | ||||
652 | } | ||||
653 | } | ||||
654 | |||||
655 | ## Canonicalize lang if possible. | ||||
656 | $values->{'lang'} = Sympa::Language::canonic_lang($values->{'lang'}) | ||||
657 | || $values->{'lang'} | ||||
658 | if $values->{'lang'}; | ||||
659 | |||||
660 | my $sdm = Sympa::DatabaseManager->instance; | ||||
661 | unless ($sdm) { | ||||
662 | $log->syslog('err', 'Unavailable database connection'); | ||||
663 | return undef; | ||||
664 | } | ||||
665 | |||||
666 | my ($field, $value); | ||||
667 | |||||
668 | ## Update each table | ||||
669 | my @set_list; | ||||
670 | |||||
671 | while (($field, $value) = each %{$values}) { | ||||
672 | unless ($map_field{$field}) { | ||||
673 | $log->syslog('err', | ||||
674 | 'Unknown field %s in map_field internal error', $field); | ||||
675 | next; | ||||
676 | } | ||||
677 | my $set; | ||||
678 | |||||
679 | if ($numeric_field{$map_field{$field}}) { | ||||
680 | $value ||= 0; ## Can't have a null value | ||||
681 | $set = sprintf '%s=%s', $map_field{$field}, $value; | ||||
682 | } elsif ($field eq 'data' and ref $value eq 'HASH') { | ||||
683 | $set = sprintf '%s=%s', $map_field{$field}, | ||||
684 | $sdm->quote(Sympa::Tools::Data::hash_2_string($value)); | ||||
685 | } elsif ($field eq 'attributes' and ref $value eq 'HASH') { | ||||
686 | $set = sprintf '%s=%s', $map_field{$field}, | ||||
687 | $sdm->quote( | ||||
688 | join '__ATT_SEP__', | ||||
689 | map { sprintf '%s__PAIRS_SEP__%s', $_, $value->{$_} } | ||||
690 | sort keys %$value | ||||
691 | ); | ||||
692 | } else { | ||||
693 | $set = sprintf '%s=%s', $map_field{$field}, $sdm->quote($value); | ||||
694 | } | ||||
695 | push @set_list, $set; | ||||
696 | } | ||||
697 | |||||
698 | return undef unless @set_list; | ||||
699 | |||||
700 | ## Update field | ||||
701 | |||||
702 | push @sth_stack, $sth; | ||||
703 | |||||
704 | $sth = $sdm->do_query( | ||||
705 | "UPDATE user_table SET %s WHERE (email_user=%s)", | ||||
706 | join(',', @set_list), | ||||
707 | $sdm->quote($who) | ||||
708 | ); | ||||
709 | unless (defined $sth) { | ||||
710 | $log->syslog('err', | ||||
711 | 'Could not update information for user %s in user_table', $who); | ||||
712 | $sth = pop @sth_stack; | ||||
713 | return undef; | ||||
714 | } | ||||
715 | |||||
716 | $sth = pop @sth_stack; | ||||
717 | |||||
718 | return 1; | ||||
719 | } | ||||
720 | |||||
721 | ## Adds a user to the user_table | ||||
722 | sub add_global_user { | ||||
723 | $log->syslog('debug3', '(...)'); | ||||
724 | my $values = $_[0]; | ||||
725 | if (ref $values) { | ||||
726 | $values = {%$values}; | ||||
727 | } else { | ||||
728 | $values = {@_}; | ||||
729 | } | ||||
730 | |||||
731 | my $sdm = Sympa::DatabaseManager->instance; | ||||
732 | unless ($sdm) { | ||||
733 | $log->syslog('err', 'Unavailable database connection'); | ||||
734 | return undef; | ||||
735 | } | ||||
736 | |||||
737 | my ($field, $value); | ||||
738 | |||||
739 | ## encrypt password with the configured password hash algorithm | ||||
740 | ## an salt of 'undef' means generate a new random one | ||||
741 | ## avoid rehashing passwords that are already hash strings | ||||
742 | if ($values->{'password'}) { | ||||
743 | if (defined(hash_type($values->{'password'}))) { | ||||
744 | $log->syslog( | ||||
745 | 'debug', | ||||
746 | 'password is in %s format, not rehashing', | ||||
747 | hash_type($values->{'password'}) | ||||
748 | ); | ||||
749 | } else { | ||||
750 | $values->{'password'} = | ||||
751 | Sympa::User::password_fingerprint($values->{'password'}, | ||||
752 | undef); | ||||
753 | } | ||||
754 | } | ||||
755 | |||||
756 | ## Canonicalize lang if possible | ||||
757 | $values->{'lang'} = Sympa::Language::canonic_lang($values->{'lang'}) | ||||
758 | || $values->{'lang'} | ||||
759 | if $values->{'lang'}; | ||||
760 | |||||
761 | my $who = Sympa::Tools::Text::canonic_email($values->{'email'}); | ||||
762 | return undef unless defined $who; | ||||
763 | return undef if (is_global_user($who)); | ||||
764 | |||||
765 | ## Update each table | ||||
766 | my (@insert_field, @insert_value); | ||||
767 | while (($field, $value) = each %{$values}) { | ||||
768 | |||||
769 | next unless ($map_field{$field}); | ||||
770 | |||||
771 | my $insert; | ||||
772 | if ($numeric_field{$map_field{$field}}) { | ||||
773 | $value ||= 0; ## Can't have a null value | ||||
774 | $insert = $value; | ||||
775 | } else { | ||||
776 | $insert = $sdm->quote($value); | ||||
777 | } | ||||
778 | push @insert_value, $insert; | ||||
779 | push @insert_field, $map_field{$field}; | ||||
780 | } | ||||
781 | |||||
782 | unless (@insert_field) { | ||||
783 | $log->syslog( | ||||
784 | 'err', | ||||
785 | 'The fields (%s) do not correspond to anything in the database', | ||||
786 | join(',', keys(%{$values})) | ||||
787 | ); | ||||
788 | return undef; | ||||
789 | } | ||||
790 | |||||
791 | push @sth_stack, $sth; | ||||
792 | |||||
793 | ## Update field | ||||
794 | $sth = $sdm->do_query( | ||||
795 | "INSERT INTO user_table (%s) VALUES (%s)", | ||||
796 | join(',', @insert_field), | ||||
797 | join(',', @insert_value) | ||||
798 | ); | ||||
799 | unless (defined $sth) { | ||||
800 | $log->syslog('err', | ||||
801 | 'Unable to add user %s to the DB table user_table', | ||||
802 | $values->{'email'}); | ||||
803 | $sth = pop @sth_stack; | ||||
804 | return undef; | ||||
805 | } | ||||
806 | unless ($sth->rows) { | ||||
807 | $sth = pop @sth_stack; | ||||
808 | return 0; | ||||
809 | } | ||||
810 | |||||
811 | $sth = pop @sth_stack; | ||||
812 | |||||
813 | return 1; | ||||
814 | } | ||||
815 | |||||
816 | =head2 Miscellaneous | ||||
817 | |||||
818 | =over 4 | ||||
819 | |||||
820 | =item clean_user ( USER_OR_HASH ) | ||||
821 | |||||
822 | =item clean_users ( ARRAYREF_OF_USERS_OR_HASHES ) | ||||
823 | |||||
824 | I<Function>. | ||||
825 | Warn if the argument is not a Sympa::User object. | ||||
826 | Return Sympa::User object, if any. | ||||
827 | |||||
828 | I<TENTATIVE>. | ||||
829 | These functions will be used during transition between old and object-oriented | ||||
830 | styles. At last modifications have been done, they shall be removed. | ||||
831 | |||||
832 | =back | ||||
833 | |||||
834 | =cut | ||||
835 | |||||
836 | sub clean_user { | ||||
837 | my $user = shift; | ||||
838 | |||||
839 | unless (ref $user eq 'Sympa::User') { | ||||
840 | local $Carp::CarpLevel = 1; | ||||
841 | Carp::carp("Deprecated usage: user should be a Sympa::User object"); | ||||
842 | |||||
843 | if (ref $user eq 'HASH') { | ||||
844 | $user = bless $user => __PACKAGE__; | ||||
845 | } else { | ||||
846 | $user = undef; | ||||
847 | } | ||||
848 | } | ||||
849 | $user; | ||||
850 | } | ||||
851 | |||||
852 | sub clean_users { | ||||
853 | my $users = shift; | ||||
854 | return $users unless ref $users eq 'ARRAY'; | ||||
855 | |||||
856 | my $warned = 0; | ||||
857 | foreach my $user (@$users) { | ||||
858 | unless (ref $user eq 'Sympa::User') { | ||||
859 | unless ($warned) { | ||||
860 | local $Carp::CarpLevel = 1; | ||||
861 | Carp::carp( | ||||
862 | "Deprecated usage: user should be a Sympa::User object"); | ||||
863 | |||||
864 | $warned = 1; | ||||
865 | } | ||||
866 | if (ref $user eq 'HASH') { | ||||
867 | $user = bless $user => __PACKAGE__; | ||||
868 | } else { | ||||
869 | $user = undef; | ||||
870 | } | ||||
871 | } | ||||
872 | } | ||||
873 | return $users; | ||||
874 | } | ||||
875 | |||||
876 | 1; |