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