Pflichtenheftaufträge: Pauschalpos. in Ang./Auftr. erstellen können
[kivitendo-erp.git] / SL / Auth.pm
1 package SL::Auth;
2
3 use DBI;
4
5 use Digest::MD5 qw(md5_hex);
6 use IO::File;
7 use Time::HiRes qw(gettimeofday);
8 use List::MoreUtils qw(uniq);
9 use YAML;
10
11 use SL::Auth::ColumnInformation;
12 use SL::Auth::Constants qw(:all);
13 use SL::Auth::DB;
14 use SL::Auth::LDAP;
15 use SL::Auth::Password;
16 use SL::Auth::SessionValue;
17
18 use SL::SessionFile;
19 use SL::User;
20 use SL::DBConnect;
21 use SL::DBUpgrade2;
22 use SL::DBUtils;
23
24 use strict;
25
26 use constant SESSION_KEY_ROOT_AUTH => 'session_auth_status_root';
27 use constant SESSION_KEY_USER_AUTH => 'session_auth_status_user';
28
29 use Rose::Object::MakeMethods::Generic (
30   scalar => [ qw(client) ],
31 );
32
33
34 sub new {
35   $main::lxdebug->enter_sub();
36
37   my ($type, %params) = @_;
38   my $self            = bless {}, $type;
39
40   $self->_read_auth_config(%params);
41   $self->reset;
42
43   $main::lxdebug->leave_sub();
44
45   return $self;
46 }
47
48 sub reset {
49   my ($self, %params) = @_;
50
51   delete $self->{dbh};
52   $self->{SESSION}            = { };
53   $self->{FULL_RIGHTS}        = { };
54   $self->{RIGHTS}             = { };
55   $self->{unique_counter}     = 0;
56   $self->{column_information} = SL::Auth::ColumnInformation->new(auth => $self);
57   $self->{authenticator}->reset;
58
59   $self->client(undef);
60 }
61
62 sub set_client {
63   my ($self, $id_or_name) = @_;
64
65   $self->client(undef);
66
67   return undef unless $id_or_name;
68
69   my $column = $id_or_name =~ m/^\d+$/ ? 'id' : 'name';
70   my $dbh    = $self->dbconnect;
71
72   return undef unless $dbh;
73
74   $self->client($dbh->selectrow_hashref(qq|SELECT * FROM auth.clients WHERE ${column} = ?|, undef, $id_or_name));
75
76   return $self->client;
77 }
78
79 sub DESTROY {
80   my $self = shift;
81
82   $self->{dbh}->disconnect() if ($self->{dbh});
83 }
84
85 # form isn't loaded yet, so auth needs it's own error.
86 sub mini_error {
87   $::lxdebug->show_backtrace();
88
89   my ($self, @msg) = @_;
90   if ($ENV{HTTP_USER_AGENT}) {
91     print Form->create_http_response(content_type => 'text/html');
92     print "<pre>", join ('<br>', @msg), "</pre>";
93   } else {
94     print STDERR "Error: @msg\n";
95   }
96   ::end_of_request();
97 }
98
99 sub _read_auth_config {
100   $main::lxdebug->enter_sub();
101
102   my ($self, %params) = @_;
103
104   map { $self->{$_} = $::lx_office_conf{authentication}->{$_} } keys %{ $::lx_office_conf{authentication} };
105
106   # Prevent password leakage to log files when dumping Auth instances.
107   $self->{admin_password} = sub { $::lx_office_conf{authentication}->{admin_password} };
108
109   if ($params{unit_tests_database}) {
110     $self->{DB_config}   = $::lx_office_conf{'testing/database'};
111     $self->{module}      = 'DB';
112
113   } else {
114     $self->{DB_config}   = $::lx_office_conf{'authentication/database'};
115     $self->{LDAP_config} = $::lx_office_conf{'authentication/ldap'};
116   }
117
118   if ($self->{module} eq 'DB') {
119     $self->{authenticator} = SL::Auth::DB->new($self);
120
121   } elsif ($self->{module} eq 'LDAP') {
122     $self->{authenticator} = SL::Auth::LDAP->new($self);
123   }
124
125   if (!$self->{authenticator}) {
126     my $locale = Locale->new('en');
127     $self->mini_error($locale->text('No or an unknown authenticantion module specified in "config/kivitendo.conf".'));
128   }
129
130   my $cfg = $self->{DB_config};
131
132   if (!$cfg) {
133     my $locale = Locale->new('en');
134     $self->mini_error($locale->text('config/kivitendo.conf: Key "DB_config" is missing.'));
135   }
136
137   if (!$cfg->{host} || !$cfg->{db} || !$cfg->{user}) {
138     my $locale = Locale->new('en');
139     $self->mini_error($locale->text('config/kivitendo.conf: Missing parameters in "authentication/database". Required parameters are "host", "db" and "user".'));
140   }
141
142   $self->{authenticator}->verify_config();
143
144   $self->{session_timeout} *= 1;
145   $self->{session_timeout}  = 8 * 60 if (!$self->{session_timeout});
146
147   $main::lxdebug->leave_sub();
148 }
149
150 sub has_access_to_client {
151   my ($self, $login) = @_;
152
153   return 0 if !$self->client || !$self->client->{id};
154
155   my $sql = <<SQL;
156     SELECT cu.client_id
157     FROM auth.clients_users cu
158     LEFT JOIN auth."user" u ON (cu.user_id = u.id)
159     WHERE (u.login      = ?)
160       AND (cu.client_id = ?)
161 SQL
162
163   my ($has_access) = $self->dbconnect->selectrow_array($sql, undef, $login, $self->client->{id});
164   return $has_access;
165 }
166
167 sub authenticate_root {
168   $main::lxdebug->enter_sub();
169
170   my ($self, $password) = @_;
171
172   my $session_root_auth = $self->get_session_value(SESSION_KEY_ROOT_AUTH());
173   if (defined $session_root_auth && $session_root_auth == OK) {
174     $::lxdebug->leave_sub;
175     return OK;
176   }
177
178   if (!defined $password) {
179     $::lxdebug->leave_sub;
180     return ERR_PASSWORD;
181   }
182
183   $password             = SL::Auth::Password->hash(login => 'root', password => $password);
184   my $admin_password    = SL::Auth::Password->hash_if_unhashed(login => 'root', password => $self->{admin_password}->());
185
186   my $result = $password eq $admin_password ? OK : ERR_PASSWORD;
187   $self->set_session_value(SESSION_KEY_ROOT_AUTH() => $result);
188
189   $::lxdebug->leave_sub;
190   return $result;
191 }
192
193 sub authenticate {
194   $main::lxdebug->enter_sub();
195
196   my ($self, $login, $password) = @_;
197
198   if (!$self->client || !$self->has_access_to_client($login)) {
199     $::lxdebug->leave_sub;
200     return ERR_PASSWORD;
201   }
202
203   my $session_auth = $self->get_session_value(SESSION_KEY_USER_AUTH());
204   if (defined $session_auth && $session_auth == OK) {
205     $::lxdebug->leave_sub;
206     return OK;
207   }
208
209   if (!defined $password) {
210     $::lxdebug->leave_sub;
211     return ERR_PASSWORD;
212   }
213
214   my $result = $login ? $self->{authenticator}->authenticate($login, $password) : ERR_USER;
215   $self->set_session_value(SESSION_KEY_USER_AUTH() => $result, login => $login, client_id => $self->client->{id});
216
217   $::lxdebug->leave_sub;
218   return $result;
219 }
220
221 sub punish_wrong_login {
222   my $failed_login_penalty = ($::lx_office_conf{authentication} || {})->{failed_login_penalty};
223   sleep $failed_login_penalty if $failed_login_penalty;
224 }
225
226 sub get_stored_password {
227   my ($self, $login) = @_;
228
229   my $dbh            = $self->dbconnect;
230
231   return undef unless $dbh;
232
233   my $query             = qq|SELECT password FROM auth."user" WHERE login = ?|;
234   my ($stored_password) = $dbh->selectrow_array($query, undef, $login);
235
236   return $stored_password;
237 }
238
239 sub dbconnect {
240   $main::lxdebug->enter_sub(2);
241
242   my $self     = shift;
243   my $may_fail = shift;
244
245   if ($self->{dbh}) {
246     $main::lxdebug->leave_sub(2);
247     return $self->{dbh};
248   }
249
250   my $cfg = $self->{DB_config};
251   my $dsn = 'dbi:Pg:dbname=' . $cfg->{db} . ';host=' . $cfg->{host};
252
253   if ($cfg->{port}) {
254     $dsn .= ';port=' . $cfg->{port};
255   }
256
257   $main::lxdebug->message(LXDebug->DEBUG1, "Auth::dbconnect DSN: $dsn");
258
259   $self->{dbh} = SL::DBConnect->connect($dsn, $cfg->{user}, $cfg->{password}, { pg_enable_utf8 => 1, AutoCommit => 1 });
260
261   if (!$may_fail && !$self->{dbh}) {
262     $main::form->error($main::locale->text('The connection to the authentication database failed:') . "\n" . $DBI::errstr);
263   }
264
265   $main::lxdebug->leave_sub(2);
266
267   return $self->{dbh};
268 }
269
270 sub dbdisconnect {
271   $main::lxdebug->enter_sub();
272
273   my $self = shift;
274
275   if ($self->{dbh}) {
276     $self->{dbh}->disconnect();
277     delete $self->{dbh};
278   }
279
280   $main::lxdebug->leave_sub();
281 }
282
283 sub check_tables {
284   $main::lxdebug->enter_sub();
285
286   my ($self, $dbh)    = @_;
287
288   $dbh   ||= $self->dbconnect();
289   my $query   = qq|SELECT COUNT(*) FROM pg_tables WHERE (schemaname = 'auth') AND (tablename = 'user')|;
290
291   my ($count) = $dbh->selectrow_array($query);
292
293   $main::lxdebug->leave_sub();
294
295   return $count > 0;
296 }
297
298 sub check_database {
299   $main::lxdebug->enter_sub();
300
301   my $self = shift;
302
303   my $dbh  = $self->dbconnect(1);
304
305   $main::lxdebug->leave_sub();
306
307   return $dbh ? 1 : 0;
308 }
309
310 sub create_database {
311   $main::lxdebug->enter_sub();
312
313   my $self   = shift;
314   my %params = @_;
315
316   my $cfg    = $self->{DB_config};
317
318   if (!$params{superuser}) {
319     $params{superuser}          = $cfg->{user};
320     $params{superuser_password} = $cfg->{password};
321   }
322
323   $params{template} ||= 'template0';
324   $params{template}   =~ s|[^a-zA-Z0-9_\-]||g;
325
326   my $dsn = 'dbi:Pg:dbname=template1;host=' . $cfg->{host};
327
328   if ($cfg->{port}) {
329     $dsn .= ';port=' . $cfg->{port};
330   }
331
332   $main::lxdebug->message(LXDebug->DEBUG1(), "Auth::create_database DSN: $dsn");
333
334   my $dbh = SL::DBConnect->connect($dsn, $params{superuser}, $params{superuser_password}, { pg_enable_utf8 => 1 });
335
336   if (!$dbh) {
337     $main::form->error($main::locale->text('The connection to the template database failed:') . "\n" . $DBI::errstr);
338   }
339
340   my $query = qq|CREATE DATABASE "$cfg->{db}" OWNER "$cfg->{user}" TEMPLATE "$params{template}" ENCODING 'UNICODE'|;
341
342   $main::lxdebug->message(LXDebug->DEBUG1(), "Auth::create_database query: $query");
343
344   $dbh->do($query);
345
346   if ($dbh->err) {
347     my $error = $dbh->errstr();
348
349     $query                 = qq|SELECT pg_encoding_to_char(encoding) FROM pg_database WHERE datname = 'template0'|;
350     my ($cluster_encoding) = $dbh->selectrow_array($query);
351
352     if ($cluster_encoding && ($cluster_encoding !~ m/^(?:UTF-?8|UNICODE)$/i)) {
353       $error = $::locale->text('Your PostgreSQL installationen does not use Unicode as its encoding. This is not supported anymore.');
354     }
355
356     $dbh->disconnect();
357
358     $main::form->error($main::locale->text('The creation of the authentication database failed:') . "\n" . $error);
359   }
360
361   $dbh->disconnect();
362
363   $main::lxdebug->leave_sub();
364 }
365
366 sub create_tables {
367   $main::lxdebug->enter_sub();
368
369   my $self = shift;
370   my $dbh  = $self->dbconnect();
371
372   $dbh->rollback();
373   SL::DBUpgrade2->new(form => $::form)->process_query($dbh, 'sql/auth_db.sql');
374
375   $main::lxdebug->leave_sub();
376 }
377
378 sub save_user {
379   $main::lxdebug->enter_sub();
380
381   my $self   = shift;
382   my $login  = shift;
383   my %params = @_;
384
385   my $form   = $main::form;
386
387   my $dbh    = $self->dbconnect();
388
389   my ($sth, $query, $user_id);
390
391   $dbh->begin_work;
392
393   $query     = qq|SELECT id FROM auth."user" WHERE login = ?|;
394   ($user_id) = selectrow_query($form, $dbh, $query, $login);
395
396   if (!$user_id) {
397     $query     = qq|SELECT nextval('auth.user_id_seq')|;
398     ($user_id) = selectrow_query($form, $dbh, $query);
399
400     $query     = qq|INSERT INTO auth."user" (id, login) VALUES (?, ?)|;
401     do_query($form, $dbh, $query, $user_id, $login);
402   }
403
404   $query = qq|DELETE FROM auth.user_config WHERE (user_id = ?)|;
405   do_query($form, $dbh, $query, $user_id);
406
407   $query = qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (?, ?, ?)|;
408   $sth   = prepare_query($form, $dbh, $query);
409
410   while (my ($cfg_key, $cfg_value) = each %params) {
411     next if ($cfg_key eq 'password');
412
413     do_statement($form, $sth, $query, $user_id, $cfg_key, $cfg_value);
414   }
415
416   $dbh->commit();
417
418   $main::lxdebug->leave_sub();
419 }
420
421 sub can_change_password {
422   my $self = shift;
423
424   return $self->{authenticator}->can_change_password();
425 }
426
427 sub change_password {
428   $main::lxdebug->enter_sub();
429
430   my ($self, $login, $new_password) = @_;
431
432   my $result = $self->{authenticator}->change_password($login, $new_password);
433
434   $main::lxdebug->leave_sub();
435
436   return $result;
437 }
438
439 sub read_all_users {
440   $main::lxdebug->enter_sub();
441
442   my $self  = shift;
443
444   my $dbh   = $self->dbconnect();
445   my $query = qq|SELECT u.id, u.login, cfg.cfg_key, cfg.cfg_value, s.mtime AS last_action
446
447                  FROM auth."user" AS  u
448
449                  LEFT JOIN auth.user_config AS cfg
450                    ON (cfg.user_id = u.id)
451
452                  LEFT JOIN auth.session_content AS sc_login
453                    ON (sc_login.sess_key = 'login' AND sc_login.sess_value = ('--- ' \|\| u.login \|\| '\n'))
454
455                  LEFT JOIN auth.session AS s
456                    ON (s.id = sc_login.session_id)
457               |;
458   my $sth   = prepare_execute_query($main::form, $dbh, $query);
459
460   my %users;
461
462   while (my $ref = $sth->fetchrow_hashref()) {
463
464     $users{$ref->{login}}                    ||= {
465                                                 'login' => $ref->{login},
466                                                 'id' => $ref->{id},
467                                                 'last_action' => $ref->{last_action},
468                                              };
469     $users{$ref->{login}}->{$ref->{cfg_key}}   = $ref->{cfg_value} if (($ref->{cfg_key} ne 'login') && ($ref->{cfg_key} ne 'id'));
470   }
471
472   $sth->finish();
473
474   $main::lxdebug->leave_sub();
475
476   return %users;
477 }
478
479 sub read_user {
480   $main::lxdebug->enter_sub();
481
482   my ($self, %params) = @_;
483
484   my $dbh   = $self->dbconnect();
485
486   my (@where, @values);
487   if ($params{login}) {
488     push @where,  'u.login = ?';
489     push @values, $params{login};
490   }
491   if ($params{id}) {
492     push @where,  'u.id = ?';
493     push @values, $params{id};
494   }
495   my $where = join ' AND ', '1 = 1', @where;
496   my $query = qq|SELECT u.id, u.login, cfg.cfg_key, cfg.cfg_value
497                  FROM auth.user_config cfg
498                  LEFT JOIN auth."user" u ON (cfg.user_id = u.id)
499                  WHERE $where|;
500   my $sth   = prepare_execute_query($main::form, $dbh, $query, @values);
501
502   my %user_data;
503
504   while (my $ref = $sth->fetchrow_hashref()) {
505     $user_data{$ref->{cfg_key}} = $ref->{cfg_value};
506     @user_data{qw(id login)}    = @{$ref}{qw(id login)};
507   }
508
509   # The XUL/XML & 'CSS new' backed menus have been removed.
510   my %menustyle_map = ( xml => 'new', v4 => 'v3' );
511   $user_data{menustyle} = $menustyle_map{lc($user_data{menustyle} || '')} || $user_data{menustyle};
512
513   # The 'Win2000.css' stylesheet has been removed.
514   $user_data{stylesheet} = 'kivitendo.css' if ($user_data{stylesheet} || '') =~ m/win2000/i;
515
516   # Set default language if selected language does not exist (anymore).
517   $user_data{countrycode} = $::lx_office_conf{system}->{language} unless $user_data{countrycode} && -d "locale/$user_data{countrycode}";
518
519   $sth->finish();
520
521   $main::lxdebug->leave_sub();
522
523   return %user_data;
524 }
525
526 sub get_user_id {
527   $main::lxdebug->enter_sub();
528
529   my $self  = shift;
530   my $login = shift;
531
532   my $dbh   = $self->dbconnect();
533   my ($id)  = selectrow_query($main::form, $dbh, qq|SELECT id FROM auth."user" WHERE login = ?|, $login);
534
535   $main::lxdebug->leave_sub();
536
537   return $id;
538 }
539
540 sub delete_user {
541   $::lxdebug->enter_sub;
542
543   my $self  = shift;
544   my $login = shift;
545
546   my $dbh   = $self->dbconnect;
547   my $id    = $self->get_user_id($login);
548
549   $dbh->rollback and return $::lxdebug->leave_sub if (!$id);
550
551   $dbh->begin_work;
552
553   do_query($::form, $dbh, qq|DELETE FROM auth.user_group WHERE user_id = ?|, $id);
554   do_query($::form, $dbh, qq|DELETE FROM auth.user_config WHERE user_id = ?|, $id);
555   do_query($::form, $dbh, qq|DELETE FROM auth.user WHERE id = ?|, $id);
556
557   # TODO: SL::Auth::delete_user
558   # do_query($::form, $u_dbh, qq|UPDATE employee SET deleted = 't' WHERE login = ?|, $login) if $u_dbh && $user_db_exists;
559
560   $dbh->commit;
561
562   $::lxdebug->leave_sub;
563 }
564
565 # --------------------------------------
566
567 my $session_id;
568
569 sub restore_session {
570   $main::lxdebug->enter_sub();
571
572   my $self = shift;
573
574   $session_id        =  $::request->{cgi}->cookie($self->get_session_cookie_name());
575   $session_id        =~ s|[^0-9a-f]||g if $session_id;
576
577   $self->{SESSION}   = { };
578
579   if (!$session_id) {
580     $main::lxdebug->leave_sub();
581     return $self->session_restore_result(SESSION_NONE());
582   }
583
584   my ($dbh, $query, $sth, $cookie, $ref, $form);
585
586   $form   = $main::form;
587
588   # Don't fail if the auth DB doesn't yet.
589   if (!( $dbh = $self->dbconnect(1) )) {
590     $::lxdebug->leave_sub;
591     return $self->session_restore_result(SESSION_NONE());
592   }
593
594   # Don't fail if the "auth" schema doesn't exist yet, e.g. if the
595   # admin is creating the session tables at the moment.
596   $query  = qq|SELECT *, (mtime < (now() - '$self->{session_timeout}m'::interval)) AS is_expired FROM auth.session WHERE id = ?|;
597
598   if (!($sth = $dbh->prepare($query)) || !$sth->execute($session_id)) {
599     $sth->finish if $sth;
600     $::lxdebug->leave_sub;
601     return $self->session_restore_result(SESSION_NONE());
602   }
603
604   $cookie = $sth->fetchrow_hashref;
605   $sth->finish;
606
607   # The session ID provided is valid in the following cases:
608   #  1. session ID exists in the database
609   #  2. hasn't expired yet
610   #  3. if cookie for the API token is given: the cookie's value equal database column 'auth.session.api_token' for the session ID
611   #  4. if cookie for the API token is NOT given then: the requestee's IP address must match the stored IP address
612   $self->{api_token}   = $cookie->{api_token} if $cookie;
613   my $api_token_cookie = $self->get_api_token_cookie;
614   my $cookie_is_bad    = !$cookie || $cookie->{is_expired};
615   $cookie_is_bad     ||= $api_token_cookie && ($api_token_cookie ne $cookie->{api_token}) if  $api_token_cookie;
616   $cookie_is_bad     ||= $cookie->{ip_address} ne $ENV{REMOTE_ADDR}                       if !$api_token_cookie;
617   if ($cookie_is_bad) {
618     $self->destroy_session();
619     $main::lxdebug->leave_sub();
620     return $self->session_restore_result($cookie ? SESSION_EXPIRED() : SESSION_NONE());
621   }
622
623   if ($self->{column_information}->has('auto_restore')) {
624     $self->_load_with_auto_restore_column($dbh, $session_id);
625   } else {
626     $self->_load_without_auto_restore_column($dbh, $session_id);
627   }
628
629   $main::lxdebug->leave_sub();
630
631   return $self->session_restore_result(SESSION_OK());
632 }
633
634 sub session_restore_result {
635   my $self = shift;
636   if (@_) {
637     $self->{session_restore_result} = $_[0];
638   }
639   return $self->{session_restore_result};
640 }
641
642 sub _load_without_auto_restore_column {
643   my ($self, $dbh, $session_id) = @_;
644
645   my $query = <<SQL;
646     SELECT sess_key, sess_value
647     FROM auth.session_content
648     WHERE (session_id = ?)
649 SQL
650   my $sth = prepare_execute_query($::form, $dbh, $query, $session_id);
651
652   while (my $ref = $sth->fetchrow_hashref) {
653     my $value = SL::Auth::SessionValue->new(auth  => $self,
654                                             key   => $ref->{sess_key},
655                                             value => $ref->{sess_value},
656                                             raw   => 1);
657     $self->{SESSION}->{ $ref->{sess_key} } = $value;
658
659     next if defined $::form->{$ref->{sess_key}};
660
661     my $data                    = $value->get;
662     $::form->{$ref->{sess_key}} = $data if $value->{auto_restore} || !ref $data;
663   }
664 }
665
666 sub _load_with_auto_restore_column {
667   my ($self, $dbh, $session_id) = @_;
668
669   my $auto_restore_keys = join ', ', map { "'${_}'" } qw(login password rpw);
670
671   my $query = <<SQL;
672     SELECT sess_key, sess_value, auto_restore
673     FROM auth.session_content
674     WHERE (session_id = ?)
675       AND (   auto_restore
676            OR sess_key IN (${auto_restore_keys}))
677 SQL
678   my $sth = prepare_execute_query($::form, $dbh, $query, $session_id);
679
680   while (my $ref = $sth->fetchrow_hashref) {
681     my $value = SL::Auth::SessionValue->new(auth         => $self,
682                                             key          => $ref->{sess_key},
683                                             value        => $ref->{sess_value},
684                                             auto_restore => $ref->{auto_restore},
685                                             raw          => 1);
686     $self->{SESSION}->{ $ref->{sess_key} } = $value;
687
688     next if defined $::form->{$ref->{sess_key}};
689
690     my $data                    = $value->get;
691     $::form->{$ref->{sess_key}} = $data if $value->{auto_restore} || !ref $data;
692   }
693
694   $sth->finish;
695
696   $query = <<SQL;
697     SELECT sess_key
698     FROM auth.session_content
699     WHERE (session_id = ?)
700       AND NOT COALESCE(auto_restore, FALSE)
701       AND (sess_key NOT IN (${auto_restore_keys}))
702 SQL
703   $sth = prepare_execute_query($::form, $dbh, $query, $session_id);
704
705   while (my $ref = $sth->fetchrow_hashref) {
706     my $value = SL::Auth::SessionValue->new(auth => $self,
707                                             key  => $ref->{sess_key});
708     $self->{SESSION}->{ $ref->{sess_key} } = $value;
709   }
710 }
711
712 sub destroy_session {
713   $main::lxdebug->enter_sub();
714
715   my $self = shift;
716
717   if ($session_id) {
718     my $dbh = $self->dbconnect();
719
720     $dbh->begin_work;
721
722     do_query($main::form, $dbh, qq|DELETE FROM auth.session_content WHERE session_id = ?|, $session_id);
723     do_query($main::form, $dbh, qq|DELETE FROM auth.session WHERE id = ?|, $session_id);
724
725     $dbh->commit();
726
727     SL::SessionFile->destroy_session($session_id);
728
729     $session_id      = undef;
730     $self->{SESSION} = { };
731   }
732
733   $main::lxdebug->leave_sub();
734 }
735
736 sub active_session_ids {
737   my $self  = shift;
738   my $dbh   = $self->dbconnect;
739
740   my $query = qq|SELECT id FROM auth.session|;
741
742   my @ids   = selectall_array_query($::form, $dbh, $query);
743
744   return @ids;
745 }
746
747 sub expire_sessions {
748   $main::lxdebug->enter_sub();
749
750   my $self  = shift;
751
752   $main::lxdebug->leave_sub and return if !$self->session_tables_present;
753
754   my $dbh   = $self->dbconnect();
755
756   my $query = qq|SELECT id
757                  FROM auth.session
758                  WHERE (mtime < (now() - '$self->{session_timeout}m'::interval))|;
759
760   my @ids   = selectall_array_query($::form, $dbh, $query);
761
762   if (@ids) {
763     $dbh->begin_work;
764
765     SL::SessionFile->destroy_session($_) for @ids;
766
767     $query = qq|DELETE FROM auth.session_content
768                 WHERE session_id IN (| . join(', ', ('?') x scalar(@ids)) . qq|)|;
769     do_query($main::form, $dbh, $query, @ids);
770
771     $query = qq|DELETE FROM auth.session
772                 WHERE id IN (| . join(', ', ('?') x scalar(@ids)) . qq|)|;
773     do_query($main::form, $dbh, $query, @ids);
774
775     $dbh->commit();
776   }
777
778   $main::lxdebug->leave_sub();
779 }
780
781 sub _create_session_id {
782   $main::lxdebug->enter_sub();
783
784   my @data;
785   map { push @data, int(rand() * 255); } (1..32);
786
787   my $id = md5_hex(pack 'C*', @data);
788
789   $main::lxdebug->leave_sub();
790
791   return $id;
792 }
793
794 sub create_or_refresh_session {
795   $session_id ||= shift->_create_session_id;
796 }
797
798 sub save_session {
799   $::lxdebug->enter_sub;
800   my $self         = shift;
801   my $provided_dbh = shift;
802
803   my $dbh          = $provided_dbh || $self->dbconnect(1);
804
805   $::lxdebug->leave_sub && return unless $dbh && $session_id;
806
807   $dbh->begin_work unless $provided_dbh;
808
809   # If this fails then the "auth" schema might not exist yet, e.g. if
810   # the admin is just trying to create the auth database.
811   if (!$dbh->do(qq|LOCK auth.session_content|)) {
812     $dbh->rollback unless $provided_dbh;
813     $::lxdebug->leave_sub;
814     return;
815   }
816
817   my @unfetched_keys = map     { $_->{key}        }
818                        grep    { ! $_->{fetched}  }
819                        values %{ $self->{SESSION} };
820   # $::lxdebug->dump(0, "unfetched_keys", [ sort @unfetched_keys ]);
821   # $::lxdebug->dump(0, "all keys", [ sort map { $_->{key} } values %{ $self->{SESSION} } ]);
822   my $query          = qq|DELETE FROM auth.session_content WHERE (session_id = ?)|;
823   $query            .= qq| AND (sess_key NOT IN (| . join(', ', ('?') x scalar @unfetched_keys) . qq|))| if @unfetched_keys;
824
825   do_query($::form, $dbh, $query, $session_id, @unfetched_keys);
826
827   my ($id) = selectrow_query($::form, $dbh, qq|SELECT id FROM auth.session WHERE id = ?|, $session_id);
828
829   if ($id) {
830     do_query($::form, $dbh, qq|UPDATE auth.session SET mtime = now() WHERE id = ?|, $session_id);
831   } else {
832     do_query($::form, $dbh, qq|INSERT INTO auth.session (id, ip_address, mtime) VALUES (?, ?, now())|, $session_id, $ENV{REMOTE_ADDR});
833   }
834
835   if ($self->{column_information}->has('api_token', 'session')) {
836     my ($stored_api_token) = $dbh->selectrow_array(qq|SELECT api_token FROM auth.session WHERE id = ?|, undef, $session_id);
837     do_query($::form, $dbh, qq|UPDATE auth.session SET api_token = ? WHERE id = ?|, $self->_create_session_id, $session_id) unless $stored_api_token;
838   }
839
840   my @values_to_save = grep    { $_->{fetched} }
841                        values %{ $self->{SESSION} };
842   if (@values_to_save) {
843     my ($columns, $placeholders) = ('', '');
844     my $auto_restore             = $self->{column_information}->has('auto_restore');
845
846     if ($auto_restore) {
847       $columns      .= ', auto_restore';
848       $placeholders .= ', ?';
849     }
850
851     $query  = qq|INSERT INTO auth.session_content (session_id, sess_key, sess_value ${columns}) VALUES (?, ?, ? ${placeholders})|;
852     my $sth = prepare_query($::form, $dbh, $query);
853
854     foreach my $value (@values_to_save) {
855       my @values = ($value->{key}, $value->get_dumped);
856       push @values, $value->{auto_restore} if $auto_restore;
857
858       do_statement($::form, $sth, $query, $session_id, @values);
859     }
860
861     $sth->finish();
862   }
863
864   $dbh->commit() unless $provided_dbh;
865   $::lxdebug->leave_sub;
866 }
867
868 sub set_session_value {
869   $main::lxdebug->enter_sub();
870
871   my $self   = shift;
872   my @params = @_;
873
874   $self->{SESSION} ||= { };
875
876   while (@params) {
877     my $key = shift @params;
878
879     if (ref $key eq 'HASH') {
880       $self->{SESSION}->{ $key->{key} } = SL::Auth::SessionValue->new(key          => $key->{key},
881                                                                       value        => $key->{value},
882                                                                       auto_restore => $key->{auto_restore});
883
884     } else {
885       my $value = shift @params;
886       $self->{SESSION}->{ $key } = SL::Auth::SessionValue->new(key   => $key,
887                                                                value => $value);
888     }
889   }
890
891   $main::lxdebug->leave_sub();
892
893   return $self;
894 }
895
896 sub delete_session_value {
897   $main::lxdebug->enter_sub();
898
899   my $self = shift;
900
901   $self->{SESSION} ||= { };
902   delete @{ $self->{SESSION} }{ @_ };
903
904   $main::lxdebug->leave_sub();
905
906   return $self;
907 }
908
909 sub get_session_value {
910   $main::lxdebug->enter_sub();
911
912   my $self = shift;
913   my $data = $self->{SESSION} && $self->{SESSION}->{ $_[0] } ? $self->{SESSION}->{ $_[0] }->get : undef;
914
915   $main::lxdebug->leave_sub();
916
917   return $data;
918 }
919
920 sub create_unique_sesion_value {
921   my ($self, $value, %params) = @_;
922
923   $self->{SESSION} ||= { };
924
925   my @now                   = gettimeofday();
926   my $key                   = "$$-" . ($now[0] * 1000000 + $now[1]) . "-";
927   $self->{unique_counter} ||= 0;
928
929   my $hashed_key;
930   do {
931     $self->{unique_counter}++;
932     $hashed_key = md5_hex($key . $self->{unique_counter});
933   } while (exists $self->{SESSION}->{$hashed_key});
934
935   $self->set_session_value($hashed_key => $value);
936
937   return $hashed_key;
938 }
939
940 sub save_form_in_session {
941   my ($self, %params) = @_;
942
943   my $form        = delete($params{form}) || $::form;
944   my $non_scalars = delete $params{non_scalars};
945   my $data        = {};
946
947   my %skip_keys   = map { ( $_ => 1 ) } (qw(login password stylesheet version titlebar), @{ $params{skip_keys} || [] });
948
949   foreach my $key (grep { !$skip_keys{$_} } keys %{ $form }) {
950     $data->{$key} = $form->{$key} if !ref($form->{$key}) || $non_scalars;
951   }
952
953   return $self->create_unique_sesion_value($data, %params);
954 }
955
956 sub restore_form_from_session {
957   my ($self, $key, %params) = @_;
958
959   my $data = $self->get_session_value($key);
960   return $self unless $data;
961
962   my $form    = delete($params{form}) || $::form;
963   my $clobber = exists $params{clobber} ? $params{clobber} : 1;
964
965   map { $form->{$_} = $data->{$_} if $clobber || !exists $form->{$_} } keys %{ $data };
966
967   return $self;
968 }
969
970 sub set_cookie_environment_variable {
971   my $self = shift;
972   $ENV{HTTP_COOKIE} = $self->get_session_cookie_name() . "=${session_id}";
973 }
974
975 sub get_session_cookie_name {
976   my ($self, %params) = @_;
977
978   $params{type}     ||= 'id';
979   my $name            = $self->{cookie_name} || 'lx_office_erp_session_id';
980   $name              .= '_api_token' if $params{type} eq 'api_token';
981
982   return $name;
983 }
984
985 sub get_session_id {
986   return $session_id;
987 }
988
989 sub get_api_token_cookie {
990   my ($self) = @_;
991
992   $::request->{cgi}->cookie($self->get_session_cookie_name(type => 'api_token'));
993 }
994
995 sub is_api_token_cookie_valid {
996   my ($self)             = @_;
997   my $provided_api_token = $self->get_api_token_cookie;
998   return $self->{api_token} && $provided_api_token && ($self->{api_token} eq $provided_api_token);
999 }
1000
1001 sub session_tables_present {
1002   $main::lxdebug->enter_sub();
1003
1004   my $self = shift;
1005
1006   # Only re-check for the presence of auth tables if either the check
1007   # hasn't been done before of if they weren't present.
1008   if ($self->{session_tables_present}) {
1009     $main::lxdebug->leave_sub();
1010     return $self->{session_tables_present};
1011   }
1012
1013   my $dbh  = $self->dbconnect(1);
1014
1015   if (!$dbh) {
1016     $main::lxdebug->leave_sub();
1017     return 0;
1018   }
1019
1020   my $query =
1021     qq|SELECT COUNT(*)
1022        FROM pg_tables
1023        WHERE (schemaname = 'auth')
1024          AND (tablename IN ('session', 'session_content'))|;
1025
1026   my ($count) = selectrow_query($main::form, $dbh, $query);
1027
1028   $self->{session_tables_present} = 2 == $count;
1029
1030   $main::lxdebug->leave_sub();
1031
1032   return $self->{session_tables_present};
1033 }
1034
1035 # --------------------------------------
1036
1037 sub all_rights_full {
1038   my $locale = $main::locale;
1039
1040   my @all_rights = (
1041     ["--crm",                          $locale->text("CRM optional software")],
1042     ["crm_search",                     $locale->text("CRM search")],
1043     ["crm_new",                        $locale->text("CRM create customers, vendors and contacts")],
1044     ["crm_service",                    $locale->text("CRM services")],
1045     ["crm_admin",                      $locale->text("CRM admin")],
1046     ["crm_adminuser",                  $locale->text("CRM user")],
1047     ["crm_adminstatus",                $locale->text("CRM status")],
1048     ["crm_email",                      $locale->text("CRM send email")],
1049     ["crm_termin",                     $locale->text("CRM termin")],
1050     ["crm_opportunity",                $locale->text("CRM opportunity")],
1051     ["crm_knowhow",                    $locale->text("CRM know how")],
1052     ["crm_follow",                     $locale->text("CRM follow up")],
1053     ["crm_notices",                    $locale->text("CRM notices")],
1054     ["crm_other",                      $locale->text("CRM other")],
1055     ["--master_data",                  $locale->text("Master Data")],
1056     ["customer_vendor_edit",           $locale->text("Create customers and vendors. Edit all vendors. Edit only customers where salesman equals employee (login)")],
1057     ["customer_vendor_all_edit",       $locale->text("Create customers and vendors. Edit all vendors. Edit all customers")],
1058     ["part_service_assembly_edit",     $locale->text("Create and edit parts, services, assemblies")],
1059     ["part_service_assembly_details",  $locale->text("Show details and reports of parts, services, assemblies")],
1060     ["project_edit",                   $locale->text("Create and edit projects")],
1061     ["--ar",                           $locale->text("AR")],
1062     ["requirement_spec_edit",          $locale->text("Create and edit requirement specs")],
1063     ["sales_quotation_edit",           $locale->text("Create and edit sales quotations")],
1064     ["sales_order_edit",               $locale->text("Create and edit sales orders")],
1065     ["sales_delivery_order_edit",      $locale->text("Create and edit sales delivery orders")],
1066     ["invoice_edit",                   $locale->text("Create and edit invoices and credit notes")],
1067     ["dunning_edit",                   $locale->text("Create and edit dunnings")],
1068     ["sales_all_edit",                 $locale->text("View/edit all employees sales documents")],
1069     ["edit_prices",                    $locale->text("Edit prices and discount (if not used, textfield is ONLY set readonly)")],
1070     ["show_ar_transactions",           $locale->text("Show AR transactions as part of AR invoice report")],
1071     ["delivery_plan",                  $locale->text("Show delivery plan")],
1072     ["--ap",                           $locale->text("AP")],
1073     ["request_quotation_edit",         $locale->text("Create and edit RFQs")],
1074     ["purchase_order_edit",            $locale->text("Create and edit purchase orders")],
1075     ["purchase_delivery_order_edit",   $locale->text("Create and edit purchase delivery orders")],
1076     ["vendor_invoice_edit",            $locale->text("Create and edit vendor invoices")],
1077     ["show_ap_transactions",           $locale->text("Show AP transactions as part of AP invoice report")],
1078     ["--warehouse_management",         $locale->text("Warehouse management")],
1079     ["warehouse_contents",             $locale->text("View warehouse content")],
1080     ["warehouse_management",           $locale->text("Warehouse management")],
1081     ["--general_ledger_cash",          $locale->text("General ledger and cash")],
1082     ["general_ledger",                 $locale->text("Transactions, AR transactions, AP transactions")],
1083     ["datev_export",                   $locale->text("DATEV Export")],
1084     ["cash",                           $locale->text("Receipt, payment, reconciliation")],
1085     ["--reports",                      $locale->text('Reports')],
1086     ["report",                         $locale->text('All reports')],
1087     ["advance_turnover_tax_return",    $locale->text('Advance turnover tax return')],
1088     ["--batch_printing",               $locale->text("Batch Printing")],
1089     ["batch_printing",                 $locale->text("Batch Printing")],
1090     ["--configuration",                $locale->text("Configuration")],
1091     ["config",                         $locale->text("Change kivitendo installation settings (most entries in the 'System' menu)")],
1092     ["admin",                          $locale->text("Client administration: configuration, editing templates, task server control, background jobs (remaining entries in the 'System' menu)")],
1093     ["--others",                       $locale->text("Others")],
1094     ["email_bcc",                      $locale->text("May set the BCC field when sending emails")],
1095     ["productivity",                   $locale->text("Productivity")],
1096     ["display_admin_link",             $locale->text("Show administration link")],
1097     );
1098
1099   return @all_rights;
1100 }
1101
1102 sub all_rights {
1103   return grep !/^--/, map { $_->[0] } all_rights_full();
1104 }
1105
1106 sub read_groups {
1107   $main::lxdebug->enter_sub();
1108
1109   my $self = shift;
1110
1111   my $form   = $main::form;
1112   my $groups = {};
1113   my $dbh    = $self->dbconnect();
1114
1115   my $query  = 'SELECT * FROM auth."group"';
1116   my $sth    = prepare_execute_query($form, $dbh, $query);
1117
1118   my ($row, $group);
1119
1120   while ($row = $sth->fetchrow_hashref()) {
1121     $groups->{$row->{id}} = $row;
1122   }
1123   $sth->finish();
1124
1125   $query = 'SELECT * FROM auth.user_group WHERE group_id = ?';
1126   $sth   = prepare_query($form, $dbh, $query);
1127
1128   foreach $group (values %{$groups}) {
1129     my @members;
1130
1131     do_statement($form, $sth, $query, $group->{id});
1132
1133     while ($row = $sth->fetchrow_hashref()) {
1134       push @members, $row->{user_id};
1135     }
1136     $group->{members} = [ uniq @members ];
1137   }
1138   $sth->finish();
1139
1140   $query = 'SELECT * FROM auth.group_rights WHERE group_id = ?';
1141   $sth   = prepare_query($form, $dbh, $query);
1142
1143   foreach $group (values %{$groups}) {
1144     $group->{rights} = {};
1145
1146     do_statement($form, $sth, $query, $group->{id});
1147
1148     while ($row = $sth->fetchrow_hashref()) {
1149       $group->{rights}->{$row->{right}} |= $row->{granted};
1150     }
1151
1152     map { $group->{rights}->{$_} = 0 if (!defined $group->{rights}->{$_}); } all_rights();
1153   }
1154   $sth->finish();
1155
1156   $main::lxdebug->leave_sub();
1157
1158   return $groups;
1159 }
1160
1161 sub save_group {
1162   $main::lxdebug->enter_sub();
1163
1164   my $self  = shift;
1165   my $group = shift;
1166
1167   my $form  = $main::form;
1168   my $dbh   = $self->dbconnect();
1169
1170   $dbh->begin_work;
1171
1172   my ($query, $sth, $row, $rights);
1173
1174   if (!$group->{id}) {
1175     ($group->{id}) = selectrow_query($form, $dbh, qq|SELECT nextval('auth.group_id_seq')|);
1176
1177     $query = qq|INSERT INTO auth."group" (id, name, description) VALUES (?, '', '')|;
1178     do_query($form, $dbh, $query, $group->{id});
1179   }
1180
1181   do_query($form, $dbh, qq|UPDATE auth."group" SET name = ?, description = ? WHERE id = ?|, map { $group->{$_} } qw(name description id));
1182
1183   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $group->{id});
1184
1185   $query  = qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (?, ?)|;
1186   $sth    = prepare_query($form, $dbh, $query);
1187
1188   foreach my $user_id (uniq @{ $group->{members} }) {
1189     do_statement($form, $sth, $query, $user_id, $group->{id});
1190   }
1191   $sth->finish();
1192
1193   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $group->{id});
1194
1195   $query = qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (?, ?, ?)|;
1196   $sth   = prepare_query($form, $dbh, $query);
1197
1198   foreach my $right (keys %{ $group->{rights} }) {
1199     do_statement($form, $sth, $query, $group->{id}, $right, $group->{rights}->{$right} ? 't' : 'f');
1200   }
1201   $sth->finish();
1202
1203   $dbh->commit();
1204
1205   $main::lxdebug->leave_sub();
1206 }
1207
1208 sub delete_group {
1209   $main::lxdebug->enter_sub();
1210
1211   my $self = shift;
1212   my $id   = shift;
1213
1214   my $form = $main::form;
1215
1216   my $dbh  = $self->dbconnect();
1217   $dbh->begin_work;
1218
1219   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $id);
1220   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $id);
1221   do_query($form, $dbh, qq|DELETE FROM auth."group" WHERE id = ?|, $id);
1222
1223   $dbh->commit();
1224
1225   $main::lxdebug->leave_sub();
1226 }
1227
1228 sub evaluate_rights_ary {
1229   $main::lxdebug->enter_sub(2);
1230
1231   my $ary    = shift;
1232
1233   my $value  = 0;
1234   my $action = '|';
1235
1236   foreach my $el (@{$ary}) {
1237     if (ref $el eq "ARRAY") {
1238       if ($action eq '|') {
1239         $value |= evaluate_rights_ary($el);
1240       } else {
1241         $value &= evaluate_rights_ary($el);
1242       }
1243
1244     } elsif (($el eq '&') || ($el eq '|')) {
1245       $action = $el;
1246
1247     } elsif ($action eq '|') {
1248       $value |= $el;
1249
1250     } else {
1251       $value &= $el;
1252
1253     }
1254   }
1255
1256   $main::lxdebug->leave_sub(2);
1257
1258   return $value;
1259 }
1260
1261 sub _parse_rights_string {
1262   $main::lxdebug->enter_sub(2);
1263
1264   my $self   = shift;
1265
1266   my $login  = shift;
1267   my $access = shift;
1268
1269   my @stack;
1270   my $cur_ary = [];
1271
1272   push @stack, $cur_ary;
1273
1274   while ($access =~ m/^([a-z_0-9]+|\||\&|\(|\)|\s+)/) {
1275     my $token = $1;
1276     substr($access, 0, length $1) = "";
1277
1278     next if ($token =~ /\s/);
1279
1280     if ($token eq "(") {
1281       my $new_cur_ary = [];
1282       push @stack, $new_cur_ary;
1283       push @{$cur_ary}, $new_cur_ary;
1284       $cur_ary = $new_cur_ary;
1285
1286     } elsif ($token eq ")") {
1287       pop @stack;
1288
1289       if (!@stack) {
1290         $main::lxdebug->leave_sub(2);
1291         return 0;
1292       }
1293
1294       $cur_ary = $stack[-1];
1295
1296     } elsif (($token eq "|") || ($token eq "&")) {
1297       push @{$cur_ary}, $token;
1298
1299     } else {
1300       push @{$cur_ary}, $self->{RIGHTS}->{$login}->{$token} * 1;
1301     }
1302   }
1303
1304   my $result = ($access || (1 < scalar @stack)) ? 0 : evaluate_rights_ary($stack[0]);
1305
1306   $main::lxdebug->leave_sub(2);
1307
1308   return $result;
1309 }
1310
1311 sub check_right {
1312   $main::lxdebug->enter_sub(2);
1313
1314   my $self    = shift;
1315   my $login   = shift;
1316   my $right   = shift;
1317   my $default = shift;
1318
1319   $self->{FULL_RIGHTS}           ||= { };
1320   $self->{FULL_RIGHTS}->{$login} ||= { };
1321
1322   if (!defined $self->{FULL_RIGHTS}->{$login}->{$right}) {
1323     $self->{RIGHTS}           ||= { };
1324     $self->{RIGHTS}->{$login} ||= $self->load_rights_for_user($login);
1325
1326     $self->{FULL_RIGHTS}->{$login}->{$right} = $self->_parse_rights_string($login, $right);
1327   }
1328
1329   my $granted = $self->{FULL_RIGHTS}->{$login}->{$right};
1330   $granted    = $default if (!defined $granted);
1331
1332   $main::lxdebug->leave_sub(2);
1333
1334   return $granted;
1335 }
1336
1337 sub assert {
1338   $::lxdebug->enter_sub(2);
1339   my ($self, $right, $dont_abort) = @_;
1340
1341   if ($self->check_right($::myconfig{login}, $right)) {
1342     $::lxdebug->leave_sub(2);
1343     return 1;
1344   }
1345
1346   if (!$dont_abort) {
1347     delete $::form->{title};
1348     $::form->show_generic_error($::locale->text("You do not have the permissions to access this function."));
1349   }
1350
1351   $::lxdebug->leave_sub(2);
1352
1353   return 0;
1354 }
1355
1356 sub load_rights_for_user {
1357   $::lxdebug->enter_sub;
1358
1359   my ($self, $login) = @_;
1360   my $dbh   = $self->dbconnect;
1361   my ($query, $sth, $row, $rights);
1362
1363   $rights = { map { $_ => 0 } all_rights() };
1364
1365   $query =
1366     qq|SELECT gr."right", gr.granted
1367        FROM auth.group_rights gr
1368        WHERE group_id IN
1369          (SELECT ug.group_id
1370           FROM auth.user_group ug
1371           LEFT JOIN auth."user" u ON (ug.user_id = u.id)
1372           WHERE u.login = ?)
1373        AND group_id IN
1374          (SELECT cg.group_id
1375           FROM auth.clients_groups cg
1376           WHERE cg.client_id = ?)|;
1377
1378   $sth = prepare_execute_query($::form, $dbh, $query, $login, $self->client->{id});
1379
1380   while ($row = $sth->fetchrow_hashref()) {
1381     $rights->{$row->{right}} |= $row->{granted};
1382   }
1383   $sth->finish();
1384
1385   $::lxdebug->leave_sub;
1386
1387   return $rights;
1388 }
1389
1390 1;
1391 __END__
1392
1393 =pod
1394
1395 =encoding utf8
1396
1397 =head1 NAME
1398
1399 SL::Auth - Authentication and session handling
1400
1401 =head1 FUNCTIONS
1402
1403 =over 4
1404
1405 =item C<set_session_value @values>
1406
1407 =item C<set_session_value %values>
1408
1409 Store all values of C<@values> or C<%values> in the session. Each
1410 member of C<@values> is tested if it is a hash reference. If it is
1411 then it must contain the keys C<key> and C<value> and can optionally
1412 contain the key C<auto_restore>. In this case C<value> is associated
1413 with C<key> and restored to C<$::form> upon the next request
1414 automatically if C<auto_restore> is trueish or if C<value> is a scalar
1415 value.
1416
1417 If the current member of C<@values> is not a hash reference then it
1418 will be used as the C<key> and the next entry of C<@values> is used as
1419 the C<value> to store. In this case setting C<auto_restore> is not
1420 possible.
1421
1422 Therefore the following two invocations are identical:
1423
1424   $::auth-E<gt>set_session_value(name =E<gt> "Charlie");
1425   $::auth-E<gt>set_session_value({ key =E<gt> "name", value =E<gt> "Charlie" });
1426
1427 All of these values are copied back into C<$::form> for the next
1428 request automatically if they're scalar values or if they have
1429 C<auto_restore> set to trueish.
1430
1431 The values can be any Perl structure. They are stored as YAML dumps.
1432
1433 =item C<get_session_value $key>
1434
1435 Retrieve a value from the session. Returns C<undef> if the value
1436 doesn't exist.
1437
1438 =item C<create_unique_sesion_value $value, %params>
1439
1440 Create a unique key in the session and store C<$value>
1441 there.
1442
1443 Returns the key created in the session.
1444
1445 =item C<save_session>
1446
1447 Stores the session values in the database. This is the only function
1448 that actually stores stuff in the database. Neither the various
1449 setters nor the deleter access the database.
1450
1451 =item <save_form_in_session %params>
1452
1453 Stores the content of C<$params{form}> (default: C<$::form>) in the
1454 session using L</create_unique_sesion_value>.
1455
1456 If C<$params{non_scalars}> is trueish then non-scalar values will be
1457 stored as well. Default is to only store scalar values.
1458
1459 The following keys will never be saved: C<login>, C<password>,
1460 C<stylesheet>, C<titlebar>, C<version>. Additional keys not to save
1461 can be given as an array ref in C<$params{skip_keys}>.
1462
1463 Returns the unique key under which the form is stored.
1464
1465 =item <restore_form_from_session $key, %params>
1466
1467 Restores the form from the session into C<$params{form}> (default:
1468 C<$::form>).
1469
1470 If C<$params{clobber}> is falsish then existing values with the same
1471 key in C<$params{form}> will not be overwritten. C<$params{clobber}>
1472 is on by default.
1473
1474 Returns C<$self>.
1475
1476 =back
1477
1478 =head1 BUGS
1479
1480 Nothing here yet.
1481
1482 =head1 AUTHOR
1483
1484 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
1485
1486 =cut