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